[commit: ghc] wip/T10613: SpecConstr: Transport strictness annotation to specialization’s argument’s binders (25577ef)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/T10613
Link       : http://ghc.haskell.org/trac/ghc/changeset/25577effced37a165a09b82405b0463258e5881b/ghc

>---------------------------------------------------------------

commit 25577effced37a165a09b82405b0463258e5881b
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Tue Mar 22 15:39:06 2016 +0100

    SpecConstr: Transport strictness annotation to specialization’s argument’s binders
    
    This is a result of the discussion in ticket:11731#comment:9.


>---------------------------------------------------------------

25577effced37a165a09b82405b0463258e5881b
 compiler/specialise/SpecConstr.hs | 16 +++++++++++++++-
 1 file changed, 15 insertions(+), 1 deletion(-)

diff --git a/compiler/specialise/SpecConstr.hs b/compiler/specialise/SpecConstr.hs
index 10d5614..7e75a4f 100644
--- a/compiler/specialise/SpecConstr.hs
+++ b/compiler/specialise/SpecConstr.hs
@@ -1648,12 +1648,18 @@ spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)
                              `setIdStrictness` spec_str
                              `setIdArity` count isId spec_lam_args
               spec_str   = calcSpecStrictness fn spec_lam_args pats
+
+
                 -- Conditionally use result of new worker-wrapper transform
               (spec_lam_args, spec_call_args) = mkWorkerArgs (sc_dflags env) qvars NoOneShotInfo body_ty
                 -- Usual w/w hack to avoid generating
                 -- a spec_rhs of unlifted type and no args
 
-              spec_rhs   = mkLams spec_lam_args spec_body
+              spec_lam_args_str = handOutStrictnessInformation (fst (splitStrictSig spec_str)) spec_lam_args
+                -- ^ Annotate the variables with the strictness information from
+                --   the function
+
+              spec_rhs   = mkLams spec_lam_args_str spec_body
               body_ty    = exprType spec_body
               rule_rhs   = mkVarApps (Var spec_id) spec_call_args
               inline_act = idInlineActivation fn
@@ -1663,6 +1669,14 @@ spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)
                            -- See Note [Transfer activation]
         ; return (spec_usg, OS call_pat rule spec_id spec_rhs) }
 
+handOutStrictnessInformation :: [Demand] -> [Var] -> [Var]
+handOutStrictnessInformation = go
+  where
+    go _ [] = []
+    go [] vs = vs
+    go (d:dmds) (v:vs) | isId v = setIdDemandInfo v d : go dmds vs
+    go dmds (v:vs) = v : go dmds vs
+
 calcSpecStrictness :: Id                     -- The original function
                    -> [Var] -> [CoreExpr]    -- Call pattern
                    -> StrictSig              -- Strictness of specialised thing