+
+addDataConPatDmds :: AltCon -> [Var] -> DmdType -> DmdType
+-- See Note [Add demands for strict constructors]
+addDataConPatDmds DEFAULT _ dmd_ty = dmd_ty
+addDataConPatDmds (LitAlt _) _ dmd_ty = dmd_ty
+addDataConPatDmds (DataAlt con) bndrs dmd_ty
+ = foldr add dmd_ty str_bndrs
+ where
+ add bndr dmd_ty = addVarDmd dmd_ty bndr seqDmd
+ str_bndrs = [ b | (b,s) <- zipEqual "addDataConPatBndrs"
+ (filter isId bndrs)
+ (dataConRepStrictness con)
+ , isMarkedStrict s ]
+\end{code}
+
+Note [Add demands for strict constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this program (due to Roman):
+
+ data X a = X !a
+
+ foo :: X Int -> Int -> Int
+ foo (X a) n = go 0
+ where
+ go i | i < n = a + go (i+1)
+ | otherwise = 0
+
+We want the worker for 'foo' too look like this:
+
+ $wfoo :: Int# -> Int# -> Int#
+
+with the first argument unboxed, so that it is not eval'd each time
+around the loop (which would otherwise happen, since 'foo' is not
+strict in 'a'. It is sound for the wrapper to pass an unboxed arg
+because X is strict, so its argument must be evaluated. And if we
+*don't* pass an unboxed argument, we can't even repair it by adding a
+`seq` thus:
+
+ foo (X a) n = a `seq` go 0
+
+because the seq is discarded (very early) since X is strict!
+
+There is the usual danger of reboxing, which as usual we ignore. But
+if X is monomorphic, and has an UNPACK pragma, then this optimisation
+is even more important. We don't want the wrapper to rebox an unboxed
+argument, and pass an Int to $wfoo!
+
+
+%************************************************************************
+%* *
+ Demand transformer
+%* *
+%************************************************************************
+
+\begin{code}
+dmdTransform :: AnalEnv -- 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 env 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 env 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