diff options
Diffstat (limited to 'compiler/GHC')
| -rw-r--r-- | compiler/GHC/Core/Opt/DmdAnal.hs | 8 | ||||
| -rw-r--r-- | compiler/GHC/Types/Demand.hs | 23 |
2 files changed, 5 insertions, 26 deletions
diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs index d3e3b7c87b..c8776d8788 100644 --- a/compiler/GHC/Core/Opt/DmdAnal.hs +++ b/compiler/GHC/Core/Opt/DmdAnal.hs @@ -574,8 +574,7 @@ dmdAnalRhsLetDown rec_flag env let_dmd id rhs rhs_fv2 = rhs_fv1 `keepAliveDmdEnv` extra_fvs -- See Note [Lazy and unleashable free variables] - (lazy_fv, sig_fv) = splitFVs is_thunk rhs_fv2 - is_thunk = not (exprIsHNF rhs) && not (isJoinId id) + (lazy_fv, sig_fv) = partitionVarEnv isWeakDmd rhs_fv2 -- Find the RHS free vars of the unfoldings and RULES -- See Note [Absence analysis for stable unfoldings and RULES] @@ -595,8 +594,9 @@ dmdAnalRhsLetDown rec_flag env let_dmd id rhs mkRhsDmd :: AnalEnv -> Arity -> CoreExpr -> CleanDemand mkRhsDmd _env rhs_arity _rhs = mkCallDmds rhs_arity cleanEvalDmd --- | If given the let-bound 'Id', 'useLetUp' determines whether we should --- process the binding up (body before rhs) or down (rhs before body). +-- | If given the (local, non-recursive) let-bound 'Id', 'useLetUp' determines +-- whether we should process the binding up (body before rhs) or down (rhs +-- before body). -- -- We use LetDown if there is a chance to get a useful strictness signature to -- unleash at call sites. LetDown is generally more precise than LetUp if we can diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs index ac1a14d818..b01bb8f444 100644 --- a/compiler/GHC/Types/Demand.hs +++ b/compiler/GHC/Types/Demand.hs @@ -42,7 +42,7 @@ module GHC.Types.Demand ( seqDemand, seqDemandList, seqDmdType, seqStrictSig, evalDmd, cleanEvalDmd, cleanEvalProdDmd, isStrictDmd, - splitDmdTy, splitFVs, deferAfterPreciseException, + splitDmdTy, isWeakDmd, deferAfterPreciseException, postProcessUnsat, postProcessDmdType, splitProdDmd_maybe, peelCallDmd, peelManyCalls, mkCallDmd, mkCallDmds, @@ -796,22 +796,6 @@ cleanUseDmd_maybe :: Demand -> Maybe UseDmd cleanUseDmd_maybe (JD { ud = Use _ u }) = Just u cleanUseDmd_maybe _ = Nothing -splitFVs :: Bool -- Thunk - -> DmdEnv -> (DmdEnv, DmdEnv) -splitFVs is_thunk rhs_fvs - | is_thunk = strictPairToTuple $ - nonDetStrictFoldUFM_Directly add (emptyVarEnv :*: emptyVarEnv) rhs_fvs - -- It's OK to use a non-deterministic fold because we - -- immediately forget the ordering by putting the elements - -- in the envs again - | otherwise = partitionVarEnv isWeakDmd rhs_fvs - where - add uniq dmd@(JD { sd = s, ud = u }) (lazy_fv :*: sig_fv) - | Lazy <- s = addToUFM_Directly lazy_fv uniq dmd :*: sig_fv - | otherwise = addToUFM_Directly lazy_fv uniq (JD { sd = Lazy, ud = u }) - :*: - addToUFM_Directly sig_fv uniq (JD { sd = s, ud = Abs }) - keepAliveDmdEnv :: DmdEnv -> IdSet -> DmdEnv -- (keepAliveDmdType dt vs) makes sure that the Ids in vs have -- /some/ usage in the returned demand types -- they are not Absent @@ -842,11 +826,6 @@ splitProdDmd_maybe (JD { sd = s, ud = u }) (Lazy, Use _ (UProd ux)) -> Just (mkJointDmds (replicate (length ux) Lazy) ux) _ -> Nothing -data StrictPair a b = !a :*: !b - -strictPairToTuple :: StrictPair a b -> (a, b) -strictPairToTuple (x :*: y) = (x, y) - {- ********************************************************************* * * TypeShape and demand trimming |