+
+%************************************************************************
+%* *
+ Interesting arguments
+%* *
+%************************************************************************
+
+Note [Interesting arguments]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+An argument is interesting if it deserves a discount for unfoldings
+with a discount in that argument position. The idea is to avoid
+unfolding a function that is applied only to variables that have no
+unfolding (i.e. they are probably lambda bound): f x y z There is
+little point in inlining f here.
+
+Generally, *values* (like (C a b) and (\x.e)) deserve discounts. But
+we must look through lets, eg (let x = e in C a b), because the let will
+float, exposing the value, if we inline. That makes it different to
+exprIsHNF.
+
+Before 2009 we said it was interesting if the argument had *any* structure
+at all; i.e. (hasSomeUnfolding v). But does too much inlining; see Trac #3016.
+
+But we don't regard (f x y) as interesting, unless f is unsaturated.
+If it's saturated and f hasn't inlined, then it's probably not going
+to now!
+
+\begin{code}
+data ArgSummary = TrivArg -- Nothing interesting
+ | NonTrivArg -- Arg has structure
+ | ValueArg -- Arg is a con-app or PAP
+
+interestingArg :: CoreExpr -> ArgSummary
+-- See Note [Interesting arguments]
+interestingArg e = go e 0
+ where
+ -- n is # value args to which the expression is applied
+ go (Lit {}) _ = ValueArg
+ go (Var v) n
+ | isDataConWorkId v = ValueArg
+ | idArity v > n = ValueArg -- Catches (eg) primops with arity but no unfolding
+ | n > 0 = NonTrivArg -- Saturated or unknown call
+ | evald_unfolding = ValueArg -- n==0; look for a value
+ | otherwise = TrivArg -- n==0, no useful unfolding
+ where
+ evald_unfolding = isEvaldUnfolding (idUnfolding v)
+
+ go (Type _) _ = TrivArg
+ go (App fn (Type _)) n = go fn n
+ go (App fn _) n = go fn (n+1)
+ go (Note _ a) n = go a n
+ go (Cast e _) n = go e n
+ go (Lam v e) n
+ | isTyVar v = go e n
+ | n>0 = go e (n-1)
+ | otherwise = ValueArg
+ go (Let _ e) n = case go e n of { ValueArg -> ValueArg; _ -> NonTrivArg }
+ go (Case {}) _ = NonTrivArg
+
+nonTriv :: ArgSummary -> Bool
+nonTriv TrivArg = False
+nonTriv _ = True
+\end{code}
+
+
+%************************************************************************
+%* *
+ The Very Simple Optimiser
+%* *
+%************************************************************************
+
+
+\begin{code}
+simpleOptExpr :: Subst -> CoreExpr -> CoreExpr
+-- Return an occur-analysed and slightly optimised expression
+-- The optimisation is very straightforward: just
+-- inline non-recursive bindings that are used only once,
+-- or wheere the RHS is trivial
+
+simpleOptExpr subst expr
+ = go subst (occurAnalyseExpr expr)
+ where
+ go subst (Var v) = lookupIdSubst subst v
+ go subst (App e1 e2) = App (go subst e1) (go subst e2)
+ go subst (Type ty) = Type (substTy subst ty)
+ go _ (Lit lit) = Lit lit
+ go subst (Note note e) = Note note (go subst e)
+ go subst (Cast e co) = Cast (go subst e) (substTy subst co)
+ go subst (Let bind body) = go_bind subst bind body
+ go subst (Lam bndr body) = Lam bndr' (go subst' body)
+ where
+ (subst', bndr') = substBndr subst bndr
+
+ go subst (Case e b ty as) = Case (go subst e) b'
+ (substTy subst ty)
+ (map (go_alt subst') as)
+ where
+ (subst', b') = substBndr subst b
+
+
+ ----------------------
+ go_alt subst (con, bndrs, rhs) = (con, bndrs', go subst' rhs)
+ where
+ (subst', bndrs') = substBndrs subst bndrs
+
+ ----------------------
+ go_bind subst (Rec prs) body = Let (Rec (bndrs' `zip` rhss'))
+ (go subst' body)
+ where
+ (bndrs, rhss) = unzip prs
+ (subst', bndrs') = substRecBndrs subst bndrs
+ rhss' = map (go subst') rhss
+
+ go_bind subst (NonRec b r) body = go_nonrec subst b (go subst r) body
+
+ ----------------------
+ go_nonrec subst b (Type ty') body
+ | isTyVar b = go (extendTvSubst subst b ty') body
+ -- let a::* = TYPE ty in <body>
+ go_nonrec subst b r' body
+ | isId b -- let x = e in <body>
+ , exprIsTrivial r' || safe_to_inline (idOccInfo b)
+ = go (extendIdSubst subst b r') body
+ go_nonrec subst b r' body
+ = Let (NonRec b' r') (go subst' body)
+ where
+ (subst', b') = substBndr subst b
+
+ ----------------------
+ -- Unconditionally safe to inline
+ safe_to_inline :: OccInfo -> Bool
+ safe_to_inline IAmDead = True
+ safe_to_inline (OneOcc in_lam one_br _) = not in_lam && one_br
+ safe_to_inline (IAmALoopBreaker {}) = False
+ safe_to_inline NoOccInfo = False
+\end{code}
\ No newline at end of file
projects / ghc-hetmet.git / blobdiff