[commit: ghc] wip/dmd-arity: Don't treat trivial RHS specially (085cd6a)

[git at git.haskell.org]

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

On branch  : wip/dmd-arity
Link       : http://ghc.haskell.org/trac/ghc/changeset/085cd6af4eca15d544afc4e56f988822dae0b13f/ghc

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

commit 085cd6af4eca15d544afc4e56f988822dae0b13f
Author: Sebastian Graf <sebastian.graf at kit.edu>
Date:   Thu Feb 7 17:21:43 2019 +0100

    Don't treat trivial RHS specially


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

085cd6af4eca15d544afc4e56f988822dae0b13f
 compiler/stranal/DmdAnal.hs | 42 ------------------------------------------
 1 file changed, 42 deletions(-)

diff --git a/compiler/stranal/DmdAnal.hs b/compiler/stranal/DmdAnal.hs
index 082a7e7..8872a1a 100644
--- a/compiler/stranal/DmdAnal.hs
+++ b/compiler/stranal/DmdAnal.hs
@@ -287,9 +287,6 @@ dmdAnal' env dmd (Case scrut case_bndr ty alts)
 -- This is the LetUp rule in the paper “Higher-Order Cardinality Analysis”.
 dmdAnal' env dmd (Let (NonRec id rhs) body)
   | useLetUp id
-  , Nothing <- unpackTrivial rhs
-      -- dmdAnalRhsLetDown treats trivial right hand sides specially
-      -- so if we have a trival right hand side, fall through to that.
   = (final_ty, Let (NonRec id' rhs') body')
   where
     (body_ty, body')   = dmdAnal env dmd body
@@ -582,25 +579,6 @@ environment, which effectively assigns them 'nopSig' (see "getStrictness")
 
 -}
 
--- Trivial RHS
--- See Note [Demand analysis for trivial right-hand sides]
-dmdAnalTrivialRhs ::
-    AnalEnv -> Id -> CoreExpr -> Var ->
-    (DmdEnv, Id, CoreExpr)
-dmdAnalTrivialRhs env id rhs fn
-  = (fn_fv, set_idStrictness env id fn_str, rhs)
-  where
-    fn_str = getStrictness env fn
-    fn_fv | isLocalId fn = unitVarEnv fn topDmd
-          | otherwise    = emptyDmdEnv
-    -- Note [Remember to demand the function itself]
-    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-    -- fn_fv: don't forget to produce a demand for fn itself
-    -- Lacking this caused Trac #9128
-    -- The demand is very conservative (topDmd), but that doesn't
-    -- matter; trivial bindings are usually inlined, so it only
-    -- kicks in for top-level bindings and NOINLINE bindings
-
 -- Let bindings can be processed in two ways:
 -- Down (RHS before body) or Up (body before RHS).
 -- dmdAnalRhsLetDown implements the Down variant:
@@ -621,10 +599,6 @@ dmdAnalRhsLetDown :: TopLevelFlag
 -- Process the RHS of the binding, add the strictness signature
 -- to the Id, and augment the environment with the signature as well.
 dmdAnalRhsLetDown top_lvl rec_flag env let_dmd id rhs
-  | Just fn <- unpackTrivial rhs   -- See Note [Demand analysis for trivial right-hand sides]
-  = dmdAnalTrivialRhs env id rhs fn
-
-  | otherwise
   = (lazy_fv, id', mkLams bndrs' body')
   where
     (bndrs, body, body_dmd)
@@ -678,16 +652,6 @@ mkBodyDmd env arity body
        Nothing            -> cleanEvalDmd
        Just (dc, _, _, _) -> cleanEvalProdDmd (dataConRepArity dc)
 
-unpackTrivial :: CoreExpr -> Maybe Id
--- Returns (Just v) if the arg is really equal to v, modulo
--- casts, type applications etc
--- See Note [Demand analysis for trivial right-hand sides]
-unpackTrivial (Var v)                 = Just v
-unpackTrivial (Cast e _)              = unpackTrivial e
-unpackTrivial (Lam v e) | isTyVar v   = unpackTrivial e
-unpackTrivial (App e a) | isTypeArg a = unpackTrivial e
-unpackTrivial _                       = Nothing
-
 -- | If given the let-bound 'Id', 'useLetUp' determines whether we should
 -- process the binding up (body before rhs) or down (rhs before body).
 --
@@ -1168,12 +1132,6 @@ extendSigEnv top_lvl sigs var sig = extendVarEnv sigs var (sig, top_lvl)
 lookupSigEnv :: AnalEnv -> Id -> Maybe (StrictSig, TopLevelFlag)
 lookupSigEnv env id = lookupVarEnv (ae_sigs env) id
 
-getStrictness :: AnalEnv -> Id -> StrictSig
-getStrictness env fn
-  | isGlobalId fn                        = idStrictness fn
-  | Just (sig, _) <- lookupSigEnv env fn = sig
-  | otherwise                            = nopSig
-
 nonVirgin :: AnalEnv -> AnalEnv
 nonVirgin env = env { ae_virgin = False }