import DataCon ( dataConTyCon )
import TyCon ( isProductTyCon, isRecursiveTyCon )
import Id ( Id, idType, idDemandInfo,
- isDataConId, isImplicitId, isGlobalId,
+ isDataConId, isGlobalId, idArity,
idNewStrictness, idNewStrictness_maybe, getNewStrictness, setIdNewStrictness,
idNewDemandInfo, setIdNewDemandInfo, newStrictnessFromOld )
import IdInfo ( newDemand )
-> CoreBind
-> (SigEnv, CoreBind)
dmdAnalTopBind sigs (NonRec id rhs)
- | isImplicitId id -- Don't touch the info on constructors, selectors etc
- = (sigs, NonRec id rhs) -- It's pre-computed in MkId.lhs
- | otherwise
= let
- (sigs', _, (id', rhs')) = downRhs TopLevel sigs (id, rhs)
+ (sigs', _, (id', rhs')) = dmdAnalRhs TopLevel sigs (id, rhs)
in
(sigs', NonRec id' rhs')
-- We still want to mark x as demanded, because it will be when we
-- enter the let. If we analyse f's arg with a Lazy demand, we'll
-- just mark x as Lazy
+ -- c) The application rule wouldn't be right either
+ -- Evaluating (f x) in a L demand does *not* cause
+ -- evaluation of f in a C(L) demand!
dmdAnal sigs dmd (Lit lit)
where
(fun_ty, fun') = dmdAnal sigs dmd fun
-dmdAnal sigs dmd (App fun arg) -- Non-type arguments
+-- Lots of the other code is there to make this
+-- beautiful, compositional, application rule :-)
+dmdAnal sigs dmd e@(App fun arg) -- Non-type arguments
= let -- [Type arg handled above]
(fun_ty, fun') = dmdAnal sigs (Call dmd) fun
(arg_ty, arg') = dmdAnal sigs arg_dmd arg
dmdAnal sigs dmd (Let (NonRec id rhs) body)
= let
- (sigs', lazy_fv, (id1, rhs')) = downRhs NotTopLevel sigs (id, rhs)
+ (sigs', lazy_fv, (id1, rhs')) = dmdAnalRhs NotTopLevel sigs (id, rhs)
(body_ty, body') = dmdAnal sigs' dmd body
(body_ty1, id2) = annotateBndr body_ty id1
body_ty2 = addLazyFVs body_ty1 lazy_fv
-> (SigEnv, DmdEnv,
[(Id,CoreExpr)]) -- Binders annotated with stricness info
-dmdFix top_lvl sigs pairs
- = loop 1 initial_sigs pairs
+dmdFix top_lvl sigs orig_pairs
+ = loop 1 initial_sigs orig_pairs
where
- bndrs = map fst pairs
+ bndrs = map fst orig_pairs
initial_sigs = extendSigEnvList sigs [(id, (initial_sig id, top_lvl)) | id <- bndrs]
loop :: Int
-- processing the RHSs with sigs (= sigs'), whereas pairs
-- is the result of processing the RHSs with the *previous*
-- iteration of sigs.
- | n >= 5 = pprTrace "dmdFix loop" (ppr n <+> (vcat
+ | n >= 10 = pprTrace "dmdFix loop" (ppr n <+> (vcat
[ text "Sigs:" <+> ppr [(id,lookup sigs id, lookup sigs' id) | (id,_) <- pairs],
text "env:" <+> ppr (ufmToList sigs),
text "binds:" <+> pprCoreBinding (Rec pairs)]))
- (loop (n+1) sigs' pairs')
+ (emptySigEnv, emptyDmdEnv, orig_pairs) -- Safe output
| otherwise = loop (n+1) sigs' pairs'
where
-- Use the new signature to do the next pair
((sigs', lazy_fv'), pair')
-- )
where
- (sigs', lazy_fv1, pair') = downRhs top_lvl sigs (id,rhs)
+ (sigs', lazy_fv1, pair') = dmdAnalRhs top_lvl sigs (id,rhs)
lazy_fv' = plusUFM_C both lazy_fv lazy_fv1
-- old_sig = lookup sigs id
-- new_sig = lookup sigs' id
lookup sigs var = case lookupVarEnv sigs var of
Just (sig,_) -> sig
-downRhs :: TopLevelFlag
+dmdAnalRhs :: TopLevelFlag
-> SigEnv -> (Id, CoreExpr)
-> (SigEnv, DmdEnv, (Id, CoreExpr))
-- Process the RHS of the binding, add the strictness signature
-- to the Id, and augment the environment with the signature as well.
-downRhs top_lvl sigs (id, rhs)
+dmdAnalRhs top_lvl sigs (id, rhs)
= (sigs', lazy_fv, (id', rhs'))
where
arity = exprArity rhs -- The idArity may not be up to date
\begin{code}
splitDmdTy :: DmdType -> (Demand, DmdType)
-- Split off one function argument
+-- We already have a suitable demand on all
+-- free vars, so no need to add more!
splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty)
-splitDmdTy ty@(DmdType fv [] TopRes) = (Lazy, ty)
-splitDmdTy ty@(DmdType fv [] BotRes) = (Bot, ty)
+splitDmdTy ty@(DmdType fv [] TopRes) = (Lazy, ty)
+splitDmdTy ty@(DmdType fv [] BotRes) = (Bot, ty)
-- NB: Bot not Abs
-splitDmdTy (DmdType fv [] RetCPR) = panic "splitDmdTy"
- -- We already have a suitable demand on all
- -- free vars, so no need to add more!
+splitDmdTy ty@(DmdType fv [] RetCPR) = panic "splitDmdTy"
+ -- We should not be applying a product as a function!
\end{code}
\begin{code}
------ DATA CONSTRUCTOR
| isDataConId var, -- Data constructor
- Seq k ds <- res_dmd, -- and the demand looks inside its fields
- let StrictSig dmd_ty = idNewStrictness var, -- It must have a strictness sig
- let DmdType _ con_ds con_res = dmd_ty
- = if length con_ds == length ds then -- Saturated, so unleash the demand
- -- ds can be empty, when we are just seq'ing the thing
+ Seq k ds <- res_dmd -- and the demand looks inside its fields
+ = let
+ StrictSig dmd_ty = idNewStrictness var -- It must have a strictness sig
+ DmdType _ _ con_res = dmd_ty
+ arity = idArity var
+ in
+ if arity == call_depth then -- Saturated, so unleash the demand
let
+ -- ds can be empty, when we are just seq'ing the thing
+ -- If so we must make up a suitable bunch of demands
+ dmd_ds | null ds = replicate arity Abs
+ | otherwise = ASSERT( length ds == arity ) ds
+
arg_ds = case k of
- Keep -> zipWith lub ds con_ds
- Drop -> ds
- Defer -> ds
+ Keep -> bothLazy_s dmd_ds
+ Drop -> dmd_ds
+ Defer -> pprTrace "dmdTransform: surprising!" (ppr var)
+ -- I don't think this can happen
+ dmd_ds
-- Important! If we Keep the constructor application, then
- -- we need the demands the constructor places (usually lazy)
+ -- we need the demands the constructor places (always lazy)
-- If not, we don't need to. For example:
-- f p@(x,y) = (p,y) -- S(AL)
-- g a b = f (a,b)
-- Notice that we throw away info about both arguments and results
-- For example, f = let ... in \x -> x
-- We don't want to get a stricness type V->T for f.
+ -- Peter??
---------------
bothLazy :: Demand -> Demand
-----------------------------------
-- (t1 `bothType` t2) takes the argument/result info from t1,
-- using t2 just for its free-var info
+-- NB: Don't forget about r2! It might be BotRes, which is
+-- a bottom demand on all the in-scope variables.
+-- Peter: can this be done more neatly?
bothType (DmdType fv1 ds1 r1) (DmdType fv2 ds2 r2)
= DmdType both_fv2 ds1 (r1 `bothRes` r2)
where
-- If either diverges, the whole thing does
-- Otherwise take CPR info from the first
-bothRes BotRes r2 = BotRes
-bothRes r1 BotRes = BotRes
-bothRes r1 r2 = r1
+bothRes r1 BotRes = BotRes
+bothRes r1 r2 = r1
\end{code}
\begin{code}
lub Bot d = d
lub Err Bot = Err
+lub Err Abs = Lazy -- E.g. f x = if ... then True else error x
lub Err d = d
lub Lazy d = Lazy
get_changes_bind (NonRec id rhs) = get_changes_pr (id,rhs)
get_changes_pr (id,rhs)
- | isImplicitId id = empty -- We don't look inside these
- | otherwise = get_changes_var id $$ get_changes_expr rhs
+ = get_changes_var id $$ get_changes_expr rhs
get_changes_var var
| isId var = get_changes_str var $$ get_changes_dmd var
projects / ghc-hetmet.git / blobdiff