+calcSpecStrictness :: Id -- The original function
+ -> [Var] -> [CoreExpr] -- Call pattern
+ -> StrictSig -- Strictness of specialised thing
+-- See Note [Transfer strictness]
+calcSpecStrictness fn qvars pats
+ = StrictSig (mkTopDmdType spec_dmds TopRes)
+ where
+ spec_dmds = [ lookupVarEnv dmd_env qv `orElse` lazyDmd | qv <- qvars, isId qv ]
+ StrictSig (DmdType _ dmds _) = idNewStrictness fn
+
+ dmd_env = go emptyVarEnv dmds pats
+
+ go env ds (Type {} : pats) = go env ds pats
+ go env (d:ds) (pat : pats) = go (go_one env d pat) ds pats
+ go env _ _ = env
+
+ go_one env d (Var v) = extendVarEnv_C both env v d
+ go_one env (Box d) e = go_one env d e
+ go_one env (Eval (Prod ds)) e
+ | (Var _, args) <- collectArgs e = go env ds args
+ go_one env _ _ = env
+