Fix some breakagewip/ext-arity

5 files changed, 35 insertions, 32 deletions

diff --git a/compiler/coreSyn/CoreOpt.hs b/compiler/coreSyn/CoreOpt.hs
index dd95fe29f6..18f5a7974f 100644
--- a/compiler/coreSyn/CoreOpt.hs
+++ b/compiler/coreSyn/CoreOpt.hs
@@ -1327,7 +1327,7 @@ pushCoValArg co
   | otherwise
   = Nothing
   where
-    arg = argTy tyR
+    arg = funArgTy tyR
     Pair tyL tyR = coercionKind co
 
 pushCoercionIntoLambda
diff --git a/compiler/coreSyn/MkCore.hs b/compiler/coreSyn/MkCore.hs
index 377d878d5a..1792db0440 100644
--- a/compiler/coreSyn/MkCore.hs
+++ b/compiler/coreSyn/MkCore.hs
@@ -160,7 +160,7 @@ mkCoreAppTyped _ (fun, fun_ty) (Type ty)
   = (App fun (Type ty), piResultTy fun_ty ty)
 mkCoreAppTyped _ (fun, fun_ty) (Coercion co)
   = (App fun (Coercion co), funResultTy fun_ty)
-mkCoreAppTyped d (fun, fun_ty) arg
+mkCoreAppTyped _ (fun, fun_ty) arg
   | isFunTy fun_ty
   = (mkValApp fun arg arg_ty res_ty, res_ty)
   where
@@ -169,7 +169,7 @@ mkCoreAppTyped d (fun, fun_ty) arg
   = ASSERT2( isFunTildeTy fun_ty, ppr fun $$ ppr arg $$ d )
     (mkValApp fun arg arg_ty res_ty, res_ty)
   where
-    (arg_ty, res_ty) = splitTildeFunTy fun_ty
+    (arg_ty, res_ty) = splitFunTildeTy fun_ty
 
 mkValApp :: CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr
 -- Build an application (e1 e2),
diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs
index 7f1f0cbe6b..795b0f5654 100644
--- a/compiler/simplCore/Simplify.hs
+++ b/compiler/simplCore/Simplify.hs
@@ -1888,7 +1888,7 @@ rebuildCall env info@(ArgInfo { ai_encl = encl_rules, ai_type = fun_ty
         ; rebuildCall env (addValArgTo info' arg') cont }
   where
     info'  = info { ai_strs = strs, ai_discs = discs }
-    arg_ty = argTy fun_ty
+    arg_ty = funArgTy fun_ty
 
     -- Use this for lazy arguments
     cci_lazy | encl_rules = RuleArgCtxt
diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs
index 00d448dfa8..f5da3e8dba 100644
--- a/compiler/types/Type.hs
+++ b/compiler/types/Type.hs
@@ -28,7 +28,7 @@ module Type (
 
         mkVisFunTy, mkInvisFunTy, mkVisFunTys, mkInvisFunTys,
         splitFunTy, splitFunTy_maybe,
-        splitFunTys, funResultTy, funArgTy, argTy,
+        splitFunTys, funResultTy, funArgTy,
         splitFunTildeTy, splitFunTildeTy_maybe, funTildeArgTy, funTildeResultTy,
 
         toShallowFunTildeType, toDeepFunTildeType,
@@ -107,7 +107,7 @@ module Type (
         funTyCon, funTildeTyCon,
 
         -- ** Predicates on types
-        isTyVarTy, isFunTy, isFunTildeTy, isDictTy,
+        isTyVarTy, isFunTy, isFunTildeTy,
         isCoercionTy, isCoercionTy_maybe,
         isForAllTy, isForAllTy_ty, isForAllTy_co,
         isPiTy, isTauTy, isFamFreeTy,
@@ -792,8 +792,11 @@ tcRepSplitAppTy_maybe (FunTy { ft_af = af, ft_arg = ty1, ft_res = ty2 })
     rep2 = getRuntimeRep ty2
 
 tcRepSplitAppTy_maybe (FunTildeTy ty1 ty2)
-  | isConstraintKind (typeKind ty1)
-  = Nothing  -- See Note [Decomposing fat arrow c=>t]
+  -- TODO: I don't think we ever call this function on a FunTildeTy. Even if we
+  -- did, there can never be a fat squiggly arrow, syntactically, because tilde
+  -- stuff isn't part of source syntax.
+  -- | False -- isConstraintKind (typeKind ty1)
+  -- = Nothing  -- See Note [Decomposing fat arrow c=>t]
 
   | otherwise
   = Just (TyConApp funTildeTyCon [rep1, rep2, ty1], ty2)
@@ -1014,7 +1017,8 @@ funTildeResultTy ty            = pprPanic "funTildeResultTy" (ppr ty)
 funArgTy :: Type -> Type
 -- ^ Extract the function argument type and panic if that is not possible
 funArgTy ty | Just ty' <- coreView ty = funArgTy ty'
-funArgTy (FunTy { ft_arg = arg })    = arg
+funArgTy (FunTy { ft_arg = arg })     = arg
+funArgTy (FunTildeTy{ ft_arg = arg }) = arg
 funArgTy ty                           = pprPanic "funArgTy" (ppr ty)
 
 funTildeArgTy :: Type -> Type
@@ -1022,13 +1026,6 @@ funTildeArgTy ty | Just ty' <- coreView ty = funTildeArgTy ty'
 funTildeArgTy (FunTildeTy arg _res) = arg
 funTildeArgTy ty                    = pprPanic "funTildeArgTy" (ppr ty)
 
-argTy :: Type -> Type
-argTy ty | Just ty' <- coreView ty = argTy ty'
-argTy (FunTy arg _res)      = arg
-argTy (FunTildeTy arg _res) = arg
-argTy ty                    = pprPanic "argTy" (ppr ty)
-
-
 piResultTy :: HasDebugCallStack => Type -> Type ->  Type
 piResultTy ty arg = case piResultTy_maybe ty arg of
                       Just res -> res
@@ -1176,8 +1173,10 @@ liftFunTildeTys (TyVarTy v) = TyVarTy v
 liftFunTildeTys (AppTy a b) = AppTy (liftFunTildeTys a) (liftFunTildeTys b)
 liftFunTildeTys (TyConApp k tys) = TyConApp k (map liftFunTildeTys tys)
 liftFunTildeTys (ForAllTy bndr ty) = ForAllTy bndr (liftFunTildeTys ty)
-liftFunTildeTys (FunTy arg res) = FunTy (liftFunTildeTys arg) (liftFunTildeTys res)
-liftFunTildeTys (FunTildeTy arg res) = FunTy (liftFunTildeTys arg) (liftFunTildeTys res)
+liftFunTildeTys ty@(FunTy{ ft_arg = arg, ft_res = res })
+  = ty { ft_arg = liftFunTildeTys arg, ft_res =  liftFunTildeTys res }
+liftFunTildeTys ty@(FunTildeTy{ ft_arg = arg, ft_res = res })
+  = mkVisFunTy (liftFunTildeTys arg) (liftFunTildeTys res)
 liftFunTildeTys (LitTy l) = LitTy l
 liftFunTildeTys (CastTy ty co) = CastTy (liftFunTildeTys ty) co
 liftFunTildeTys (CoercionTy co) = CoercionTy co
@@ -1187,8 +1186,10 @@ liftFunTildeTys (CoercionTy co) = CoercionTy co
 -- e.g.  a -> (b -> c) -> d  ==> a ~> (b -> c) ~> d
 toShallowFunTildeType :: Type -> Type
 toShallowFunTildeType (ForAllTy tv body_ty) = ForAllTy tv (toShallowFunTildeType body_ty)
-toShallowFunTildeType (FunTy arg res)       = FunTy arg (toShallowFunTildeType res)
-toShallowFunTildeType (FunTy arg res)       = FunTildeTy arg (toShallowFunTildeType res)
+toShallowFunTildeType (FunTy{ ft_arg = arg, ft_res = res })
+  = mkFunTildeTy arg (toShallowFunTildeType res)
+toShallowFunTildeType ty@(FunTildeTy{ ft_res = res })
+  = ty{ ft_res = toShallowFunTildeType res }
 toShallowFunTildeType ty                    = ty
 
 -- | Change the top level arrows and higher-order functions into extensional
@@ -1196,8 +1197,10 @@ toShallowFunTildeType ty                    = ty
 -- e.g.  a -> (b -> c) -> d ==> a ~> (b ~> c) ~> d
 toDeepFunTildeType :: Type -> Type
 toDeepFunTildeType (ForAllTy tv body_ty) = ForAllTy tv (toDeepFunTildeType body_ty)
-toDeepFunTildeType (FunTy arg res)       = FunTildeTy (toDeepFunTildeType arg) (toDeepFunTildeType res)
-toDeepFunTildeType (FunTildeTy arg res)  = FunTildeTy (toDeepFunTildeType arg) (toDeepFunTildeType res)
+toDeepFunTildeType (FunTy{ ft_arg = arg, ft_res = res })
+  = mkFunTildeTy (toDeepFunTildeType arg) (toDeepFunTildeType res)
+toDeepFunTildeType (FunTildeTy{ ft_arg = arg, ft_res = res })
+  = mkFunTildeTy (toDeepFunTildeType arg) (toDeepFunTildeType res)
 toDeepFunTildeType ty                    = ty
 
 
@@ -1697,7 +1700,7 @@ splitPiTy_maybe ty = go ty
     go (FunTy { ft_af = af, ft_arg = arg, ft_res = res})
                           = Just (Anon af arg, res)
     go (FunTildeTy { ft_arg = arg, ft_res = res})
-                          = Just (Anon af arg, res)
+                          = Just (Anon VisArg arg, res)
     go _                  = Nothing
 
 -- | Takes a forall type apart, or panics
diff --git a/compiler/workwrap/WwLib.hs b/compiler/workwrap/WwLib.hs
index 8720733d65..013ee3b5a1 100644
--- a/compiler/workwrap/WwLib.hs
+++ b/compiler/workwrap/WwLib.hs
@@ -18,7 +18,7 @@ import GhcPrelude
 import BasicTypes
 import CoreArity
 import CoreSyn
-import CoreUtils        ( exprType, mkCast )
+import CoreUtils        ( exprType, mkCast, mkDefaultCase, mkSingleAltCase )
 import Id
 import IdInfo           ( JoinArity, vanillaIdInfo )
 import DataCon
@@ -32,7 +32,8 @@ import Literal          ( absentLiteralOf )
 import VarEnv           ( mkInScopeSet )
 import VarSet           ( VarSet )
 import Type
-import RepType          ( isVoidTy )
+import Predicate        ( isClassPred )
+import RepType          ( isVoidTy, typePrimRep )
 import Coercion
 import FamInstEnv
 import BasicTypes       ( Boxity(..) )
@@ -141,7 +142,7 @@ mkWwBodies :: DynFlags
 -- wrap_fn_str E        = case x of { (a,b) ->
 --                        case a of { (a1,a2) ->
 --                        E a1 a2 b y }}
--- work_fn_str E        = \a2 a2 b y ->
+-- work_fn_str E        = \a1 a2 b y ->
 --                        let a = (a1,a2) in
 --                        let x = (a,b) in
 --                        E
@@ -153,14 +154,14 @@ mkWwBodies dflags fam_envs rhs_called_arity_map rhs_fvs fun_id demands res_info
         ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)
              <- mkWWargs empty_subst fun_ty demands
 
-        ; (useful1, work_args, wrap_fn_str, work_fn_str)
+        ; (useful_str, work_args, wrap_fn_str, work_fn_str)
              <- mkWWstr dflags fam_envs has_inlineable_prag wrap_args
 
         -- Do CPR w/w.  See Note [Always do CPR w/w]
-        ; (useful2, wrap_fn_cpr, work_fn_cpr, cpr_res_ty)
+        ; (useful_cpr, wrap_fn_cpr, work_fn_cpr, cpr_res_ty)
               <- mkWWcpr (gopt Opt_CprAnal dflags) fam_envs res_ty res_info
 
-        ; (useful3, wrap_fn_eta_arity, work_fn_eta_arity, work_ty)
+        ; (useful_eta, wrap_fn_eta_arity, work_fn_eta_arity, work_ty)
               <- mkWWetaArity do_eta_arity fun_id
 
         ; let (work_lam_args, work_call_args) = mkWorkerArgs dflags work_args cpr_res_ty
@@ -176,10 +177,9 @@ mkWwBodies dflags fam_envs rhs_called_arity_map rhs_fvs fun_id demands res_info
                           . work_fn_cpr
                           . work_fn_eta_arity
                           . work_fn_args
-        ; if (useful3 && do_eta_arity)
-             || (isWorkerSmallEnough dflags work_args
+        ; if isWorkerSmallEnough dflags work_args
              && not (too_many_args_for_join_point wrap_args)
-             && ((useful1 && not only_one_void_argument) || useful2))
+             && ((useful_str && not only_one_void_argument) || useful_cpr || (useful_eta && do_eta_arity))
           then return (Just (worker_args_dmds
                             ,length work_call_args
                             ,wrapper_body