summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/coreSyn/CoreOpt.hs2
-rw-r--r--compiler/coreSyn/MkCore.hs4
-rw-r--r--compiler/simplCore/Simplify.hs2
-rw-r--r--compiler/types/Type.hs41
-rw-r--r--compiler/workwrap/WwLib.hs18
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
View Lorry Controller Status