summaryrefslogtreecommitdiff
path: root/compiler/stranal
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/stranal')
-rw-r--r--compiler/stranal/DmdAnal.lhs33
-rw-r--r--compiler/stranal/WorkWrap.lhs1
-rw-r--r--compiler/stranal/WwLib.lhs27
3 files changed, 34 insertions, 27 deletions
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index 192d06f563..afa722fa8a 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -18,6 +18,7 @@ import StaticFlags ( opt_MaxWorkerArgs )
import Demand -- All of it
import CoreSyn
import PprCore
+import Coercion ( isCoVarType )
import CoreUtils ( exprIsHNF, exprIsTrivial )
import CoreArity ( exprArity )
import DataCon ( dataConTyCon, dataConRepStrictness )
@@ -28,19 +29,20 @@ import Id ( Id, idType, idInlineActivation,
setIdStrictness, idDemandInfo, idUnfolding,
idDemandInfo_maybe, setIdDemandInfo
)
-import Var ( Var )
+import Var ( Var, isTyVar )
import VarEnv
import TysWiredIn ( unboxedPairDataCon )
import TysPrim ( realWorldStatePrimTy )
import UniqFM ( addToUFM_Directly, lookupUFM_Directly,
minusUFM, filterUFM )
-import Type ( isUnLiftedType, coreEqType, splitTyConApp_maybe )
+import Type ( isUnLiftedType, eqType, splitTyConApp_maybe )
import Coercion ( coercionKind )
import Util ( mapAndUnzip, lengthIs, zipEqual )
import BasicTypes ( Arity, TopLevelFlag(..), isTopLevel, isNeverActive,
RecFlag(..), isRec, isMarkedStrict )
import Maybes ( orElse, expectJust )
import Outputable
+import Pair
import Data.List
import FastString
\end{code}
@@ -144,6 +146,7 @@ dmdAnal env dmd e
dmdAnal _ _ (Lit lit) = (topDmdType, Lit lit)
dmdAnal _ _ (Type ty) = (topDmdType, Type ty) -- Doesn't happen, in fact
+dmdAnal _ _ (Coercion co) = (topDmdType, Coercion co)
dmdAnal env dmd (Var var)
= (dmdTransform env var dmd, Var var)
@@ -152,7 +155,7 @@ dmdAnal env dmd (Cast e co)
= (dmd_ty, Cast e' co)
where
(dmd_ty, e') = dmdAnal env dmd' e
- to_co = snd (coercionKind co)
+ to_co = pSnd (coercionKind co)
dmd'
| Just (tc, _) <- splitTyConApp_maybe to_co
, isRecursiveTyCon tc = evalDmd
@@ -173,6 +176,11 @@ dmdAnal env dmd (App fun (Type ty))
where
(fun_ty, fun') = dmdAnal env dmd fun
+dmdAnal sigs dmd (App fun (Coercion co))
+ = (fun_ty, App fun' (Coercion co))
+ where
+ (fun_ty, fun') = dmdAnal sigs dmd fun
+
-- Lots of the other code is there to make this
-- beautiful, compositional, application rule :-)
dmdAnal env dmd (App fun arg) -- Non-type arguments
@@ -184,7 +192,7 @@ dmdAnal env dmd (App fun arg) -- Non-type arguments
(res_ty `bothType` arg_ty, App fun' arg')
dmdAnal env dmd (Lam var body)
- | isTyCoVar var
+ | isTyVar var
= let
(body_ty, body') = dmdAnal env dmd body
in
@@ -328,7 +336,7 @@ dmdAnalAlt env dmd (con,bndrs,rhs)
-- ; print len }
io_hack_reqd = con == DataAlt unboxedPairDataCon &&
- idType (head bndrs) `coreEqType` realWorldStatePrimTy
+ idType (head bndrs) `eqType` realWorldStatePrimTy
in
(final_alt_ty, (con, bndrs', rhs'))
@@ -838,7 +846,7 @@ annotateBndr :: DmdType -> Var -> (DmdType, Var)
-- The returned var is annotated with demand info
-- No effect on the argument demands
annotateBndr dmd_ty@(DmdType fv ds res) var
- | isTyCoVar var = (dmd_ty, var)
+ | isTyVar var = (dmd_ty, var)
| otherwise = (DmdType fv' ds res, setIdDemandInfo var dmd)
where
(fv', dmd) = removeFV fv var res
@@ -888,10 +896,15 @@ removeFV fv id res = (fv', zapUnlifted id dmd)
zapUnlifted :: Id -> Demand -> Demand
-- For unlifted-type variables, we are only
-- interested in Bot/Abs/Box Abs
-zapUnlifted _ Bot = Bot
-zapUnlifted _ Abs = Abs
-zapUnlifted id dmd | isUnLiftedType (idType id) = lazyDmd
- | otherwise = dmd
+zapUnlifted id dmd
+ = case dmd of
+ _ | isCoVarType ty -> lazyDmd -- For coercions, ignore str/abs totally
+ Bot -> Bot
+ Abs -> Abs
+ _ | isUnLiftedType ty -> lazyDmd -- For unlifted types, ignore strictness
+ | otherwise -> dmd
+ where
+ ty = idType id
\end{code}
Note [Lamba-bound unfoldings]
diff --git a/compiler/stranal/WorkWrap.lhs b/compiler/stranal/WorkWrap.lhs
index 5cf5e92692..ac10b1b773 100644
--- a/compiler/stranal/WorkWrap.lhs
+++ b/compiler/stranal/WorkWrap.lhs
@@ -100,6 +100,7 @@ matching by looking for strict arguments of the correct type.
wwExpr :: CoreExpr -> UniqSM CoreExpr
wwExpr e@(Type {}) = return e
+wwExpr e@(Coercion {}) = return e
wwExpr e@(Lit {}) = return e
wwExpr e@(Var {}) = return e
diff --git a/compiler/stranal/WwLib.lhs b/compiler/stranal/WwLib.lhs
index e7d0edf0f8..391c07c089 100644
--- a/compiler/stranal/WwLib.lhs
+++ b/compiler/stranal/WwLib.lhs
@@ -23,10 +23,9 @@ import MkId ( realWorldPrimId, voidArgId,
import TysPrim ( realWorldStatePrimTy )
import TysWiredIn ( tupleCon )
import Type
-import Coercion ( mkSymCoercion, splitNewTypeRepCo_maybe )
+import Coercion ( mkSymCo, splitNewTypeRepCo_maybe )
import BasicTypes ( Boxity(..) )
import Literal ( absentLiteralOf )
-import Var ( Var )
import UniqSupply
import Unique
import Util ( zipWithEqual )
@@ -244,7 +243,7 @@ mkWWargs subst fun_ty arg_info
= do { (wrap_args, wrap_fn_args, work_fn_args, res_ty)
<- mkWWargs subst rep_ty arg_info
; return (wrap_args,
- \e -> Cast (wrap_fn_args e) (mkSymCoercion co),
+ \e -> Cast (wrap_fn_args e) (mkSymCo co),
\e -> work_fn_args (Cast e co),
res_ty) }
@@ -271,7 +270,7 @@ mkWWargs subst fun_ty arg_info
<- mkWWargs subst fun_ty' arg_info'
; return (id : wrap_args,
Lam id . wrap_fn_args,
- work_fn_args . (`App` Var id),
+ work_fn_args . (`App` varToCoreExpr id),
res_ty) }
| otherwise
@@ -291,18 +290,12 @@ mk_wrap_arg uniq ty dmd one_shot
Note [Freshen type variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-mkWWargs may be given a type like (a~b) => <blah>
-Which really means forall (co:a~b). <blah>
-Because the name of the coercion variable, 'co', isn't mentioned in <blah>,
-nested coercion foralls may all use the same variable; and sometimes do
-see Var.mkWildCoVar.
-
-However, when we do a worker/wrapper split, we must not use shadowed names,
+Wen we do a worker/wrapper split, we must not use shadowed names,
else we'll get
- f = /\ co /\co. fw co co
-which is obviously wrong. Actually, the same is true of type variables, which
-can in principle shadow, within a type (e.g. forall a. a -> forall a. a->a).
-But type variables *are* mentioned in <blah>, so we must substitute.
+ f = /\ a /\a. fw a a
+which is obviously wrong. Type variables can can in principle shadow,
+within a type (e.g. forall a. a -> forall a. a->a). But type
+variables *are* mentioned in <blah>, so we must substitute.
That's why we carry the TvSubst through mkWWargs
@@ -339,7 +332,7 @@ mkWWstr (arg : args) = do
-- brings into scope wrap_arg (via lets)
mkWWstr_one :: Var -> UniqSM ([Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
mkWWstr_one arg
- | isTyCoVar arg
+ | isTyVar arg
= return ([arg], nop_fn, nop_fn)
| otherwise
@@ -525,7 +518,7 @@ mk_absent_let arg
| Just (tc, _) <- splitTyConApp_maybe arg_ty
, Just lit <- absentLiteralOf tc
= Just (Let (NonRec arg (Lit lit)))
- | arg_ty `coreEqType` realWorldStatePrimTy
+ | arg_ty `eqType` realWorldStatePrimTy
= Just (Let (NonRec arg (Var realWorldPrimId)))
| otherwise
= WARN( True, ptext (sLit "No absent value for") <+> ppr arg_ty )
View Lorry Controller Status