+
+%************************************************************************
+%* *
+ Demand transformer
+%* *
+%************************************************************************
+
+\begin{code}
+dmdTransform :: SigEnv -- The strictness environment
+ -> Id -- The function
+ -> Demand -- The demand on the function
+ -> DmdType -- The demand type of the function in this context
+ -- Returned DmdEnv includes the demand on
+ -- this function plus demand on its free variables
+
+dmdTransform sigs var dmd
+
+------ DATA CONSTRUCTOR
+ | isDataConWorkId var -- Data constructor
+ = let
+ StrictSig dmd_ty = idStrictness 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
+ -- Important! If we Keep the constructor application, then
+ -- 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)
+ -- It's vital that we don't calculate Absent for a!
+ dmd_ds = case res_dmd of
+ Box (Eval ds) -> mapDmds box ds
+ Eval ds -> ds
+ _ -> Poly Top
+
+ -- ds can be empty, when we are just seq'ing the thing
+ -- If so we must make up a suitable bunch of demands
+ arg_ds = case dmd_ds of
+ Poly d -> replicate arity d
+ Prod ds -> ASSERT( ds `lengthIs` arity ) ds
+
+ in
+ mkDmdType emptyDmdEnv arg_ds con_res
+ -- Must remember whether it's a product, hence con_res, not TopRes
+ else
+ topDmdType
+
+------ IMPORTED FUNCTION
+ | isGlobalId var, -- Imported function
+ let StrictSig dmd_ty = idStrictness var
+ = -- pprTrace "strict-sig" (ppr var $$ ppr dmd_ty) $
+ if dmdTypeDepth dmd_ty <= call_depth then -- Saturated, so unleash the demand
+ dmd_ty
+ else
+ topDmdType
+
+------ LOCAL LET/REC BOUND THING
+ | Just (StrictSig dmd_ty, top_lvl) <- lookupSigEnv sigs var
+ = let
+ fn_ty | dmdTypeDepth dmd_ty <= call_depth = dmd_ty
+ | otherwise = deferType dmd_ty
+ -- NB: it's important to use deferType, and not just return topDmdType
+ -- Consider let { f x y = p + x } in f 1
+ -- The application isn't saturated, but we must nevertheless propagate
+ -- a lazy demand for p!
+ in
+ if isTopLevel top_lvl then fn_ty -- Don't record top level things
+ else addVarDmd fn_ty var dmd
+
+------ LOCAL NON-LET/REC BOUND THING
+ | otherwise -- Default case
+ = unitVarDmd var dmd
+
+ where
+ (call_depth, res_dmd) = splitCallDmd dmd
+\end{code}
+
projects / ghc-hetmet.git / blobdiff