| ... |
... |
@@ -23,7 +23,7 @@ import GHC.Core.DataCon |
|
23
|
23
|
import GHC.Core.Utils
|
|
24
|
24
|
import GHC.Core.TyCon
|
|
25
|
25
|
import GHC.Core.Type
|
|
26
|
|
-import GHC.Core.FVs ( rulesRhsFreeIds, bndrRuleAndUnfoldingIds )
|
|
|
26
|
+import GHC.Core.FVs ( rulesRhsFreeIds, bndrRuleAndUnfoldingVars )
|
|
27
|
27
|
import GHC.Core.Coercion ( Coercion )
|
|
28
|
28
|
import GHC.Core.TyCo.FVs ( coVarsOfCos )
|
|
29
|
29
|
import GHC.Core.TyCo.Compare ( eqType )
|
| ... |
... |
@@ -112,23 +112,27 @@ dmdAnalProgram opts fam_envs rules binds |
|
112
|
112
|
-- orphan RULES
|
|
113
|
113
|
keep_alive_roots env ids = plusDmdEnvs (map (demandRoot env) (filter is_root ids))
|
|
114
|
114
|
|
|
115
|
|
- is_root :: Id -> Bool
|
|
116
|
|
- is_root id = isExportedId id || elemVarSet id rule_fvs
|
|
|
115
|
+ is_root :: Var -> Bool
|
|
|
116
|
+ is_root v = isId v && (isExportedId v || elemVarSet v rule_fvs)
|
|
117
|
117
|
|
|
118
|
118
|
rule_fvs :: IdSet
|
|
119
|
119
|
rule_fvs = rulesRhsFreeIds rules
|
|
120
|
120
|
|
|
121
|
121
|
demandRoot :: AnalEnv -> Id -> DmdEnv
|
|
122
|
122
|
-- See Note [Absence analysis for stable unfoldings and RULES]
|
|
123
|
|
-demandRoot env id = fst (dmdAnalStar env topDmd (Var id))
|
|
|
123
|
+demandRoot env id = assertPpr (isId id) (ppr id) $
|
|
|
124
|
+ fst (dmdAnalStar env topDmd (Var id))
|
|
124
|
125
|
|
|
125
|
|
-demandRoots :: AnalEnv -> [Id] -> DmdEnv
|
|
|
126
|
+demandRootSet :: AnalEnv -> VarSet -> DmdEnv
|
|
126
|
127
|
-- See Note [Absence analysis for stable unfoldings and RULES]
|
|
127
|
|
-demandRoots env roots = plusDmdEnvs (map (demandRoot env) roots)
|
|
|
128
|
+demandRootSet env ids
|
|
|
129
|
+ = nonDetStrictFoldVarSet do_one nopDmdEnv ids
|
|
|
130
|
+ -- It's OK to use a non-deterministic fold because plusDmdType is commutative
|
|
|
131
|
+ where
|
|
|
132
|
+ do_one :: Var -> DmdEnv -> DmdEnv
|
|
|
133
|
+ do_one v acc | not (isId v) = acc
|
|
|
134
|
+ | otherwise = demandRoot env v `plusDmdEnv` acc
|
|
128
|
135
|
|
|
129
|
|
-demandRootSet :: AnalEnv -> IdSet -> DmdEnv
|
|
130
|
|
-demandRootSet env ids = demandRoots env (nonDetEltsUniqSet ids)
|
|
131
|
|
- -- It's OK to use nonDetEltsUniqSet here because plusDmdType is commutative
|
|
132
|
136
|
|
|
133
|
137
|
-- | We attach useful (e.g. not 'topDmd') 'idDemandInfo' to top-level bindings
|
|
134
|
138
|
-- that satisfy this function.
|
| ... |
... |
@@ -353,7 +357,7 @@ dmdAnalBindLetUp top_lvl env id rhs anal_body = WithDmdType final_ty (R (NonRec |
|
353
|
357
|
(rhs_ty, rhs') = dmdAnalStar env id_dmd' rhs
|
|
354
|
358
|
|
|
355
|
359
|
-- See Note [Absence analysis for stable unfoldings and RULES]
|
|
356
|
|
- rule_fvs = bndrRuleAndUnfoldingIds id
|
|
|
360
|
+ rule_fvs = bndrRuleAndUnfoldingVars id
|
|
357
|
361
|
final_ty = body_ty' `plusDmdType` rhs_ty `plusDmdType` demandRootSet env rule_fvs
|
|
358
|
362
|
|
|
359
|
363
|
-- | Let bindings can be processed in two ways:
|
| ... |
... |
@@ -1021,6 +1025,7 @@ dmdTransform env var sd |
|
1021
|
1025
|
= -- pprTraceWith "dmdTransform:DataCon" (\ty -> ppr con $$ ppr sd $$ ppr ty) $
|
|
1022
|
1026
|
dmdTransformDataConSig (dataConRepStrictness con) sd
|
|
1023
|
1027
|
-- See Note [DmdAnal for DataCon wrappers]
|
|
|
1028
|
+
|
|
1024
|
1029
|
| Just rhs <- dataConWrapUnfolding_maybe var
|
|
1025
|
1030
|
, WithDmdType dmd_ty _rhs' <- dmdAnal env sd rhs
|
|
1026
|
1031
|
= dmd_ty
|
| ... |
... |
@@ -1056,7 +1061,7 @@ dmdTransform env var sd |
|
1056
|
1061
|
-- * Lambda binders
|
|
1057
|
1062
|
-- * Case and constructor field binders
|
|
1058
|
1063
|
| otherwise
|
|
1059
|
|
- = -- pprTrace "dmdTransform:other" (vcat [ppr var, ppr boxity, ppr sd]) $
|
|
|
1064
|
+ = -- pprTrace "dmdTransform:other" (vcat [ppr var, ppr sd]) $
|
|
1060
|
1065
|
noArgsDmdType (addVarDmdEnv nopDmdEnv var (C_11 :* sd))
|
|
1061
|
1066
|
|
|
1062
|
1067
|
{- *********************************************************************
|
| ... |
... |
@@ -1136,7 +1141,7 @@ dmdAnalRhsSig top_lvl rec_flag env let_sd id rhs |
|
1136
|
1141
|
NonRecursive -> rhs_env
|
|
1137
|
1142
|
|
|
1138
|
1143
|
-- See Note [Absence analysis for stable unfoldings and RULES]
|
|
1139
|
|
- rhs_env2 = rhs_env1 `plusDmdEnv` demandRootSet env (bndrRuleAndUnfoldingIds id)
|
|
|
1144
|
+ rhs_env2 = rhs_env1 `plusDmdEnv` demandRootSet env (bndrRuleAndUnfoldingVars id)
|
|
1140
|
1145
|
|
|
1141
|
1146
|
-- See Note [Lazy and unleashable free variables]
|
|
1142
|
1147
|
!(!sig_env, !weak_fvs) = splitWeakDmds rhs_env2
|