analyse other = Nothing
\end{code}
-The arity of an expression (in the code-generator sense, i.e. the
-number of lambdas at the beginning).
-
-\begin{code}
-exprArity :: CoreExpr -> Int
-exprArity (Lam x e)
- | isTyVar x = exprArity e
- | otherwise = 1 + exprArity e
-exprArity (Note _ e)
- -- Ignore coercions. Top level sccs are removed by the final
- -- profiling pass, so we ignore those too.
- = exprArity e
-exprArity _ = 0
-\end{code}
%************************************************************************
--
-- Consider let x = expensive in \y z -> E
-- We want this to have arity 2 if the \y-abstraction is a 1-shot lambda
--- Hence the extra Bool returned by go1
+--
+-- Hence the list of Bools returned by go1
-- NB: this is particularly important/useful for IO state
-- transformers, where we often get
-- let x = E in \ s -> ...
go1 (Note n e) | ok_note n = go1 e
go1 (Var v) = replicate (idArity v) False -- When the type of the Id
-- encodes one-shot-ness, use
- -- th iinfo here
+ -- the idinfo here
-- Lambdas; increase arity
go1 (Lam x e) | isId x = isOneShotLambda x : go1 e
\end{code}
+exprArity is a cheap-and-cheerful version of exprEtaExpandArity.
+It tells how many things the expression can be applied to before doing
+any work. It doesn't look inside cases, lets, etc. The idea is that
+exprEtaExpandArity will do the hard work, leaving something that's easy
+for exprArity to grapple with. In particular, Simplify uses exprArity to
+compute the ArityInfo for the Id.
+
+Originally I thought that it was enough just to look for top-level lambdas, but
+it isn't. I've seen this
+
+ foo = PrelBase.timesInt
+
+We want foo to get arity 2 even though the eta-expander will leave it
+unchanged, in the expectation that it'll be inlined. But occasionally it
+isn't, because foo is blacklisted (used in a rule).
+
+Similarly, see the ok_note check in exprEtaExpandArity. So
+ f = __inline_me (\x -> e)
+won't be eta-expanded.
+
+And in any case it seems more robust to have exprArity be a bit more intelligent.
+
+\begin{code}
+exprArity :: CoreExpr -> Int
+exprArity e = go e `max` 0
+ where
+ go (Lam x e) | isId x = go e + 1
+ | otherwise = go e
+ go (Note _ e) = go e
+ go (App e (Type t)) = go e
+ go (App f a) = go f - 1
+ go (Var v) = idArity v
+ go _ = 0
+\end{code}
+
+
%************************************************************************
%* *
\subsection{Equality}
coreTopBindToStg env body_fvs (NonRec id rhs)
= let
caf_info = hasCafRefs env rhs
- arity = exprArity rhs
- env' = extendVarEnv env id (LetBound how_bound emptyLVS arity)
+ env' = extendVarEnv env id (LetBound how_bound emptyLVS (predictArity rhs))
how_bound | mayHaveCafRefs caf_info = TopLevelHasCafs
| otherwise = TopLevelNoCafs
bind = StgNonRec (SRTEntries cafs) id stg_rhs
in
+ ASSERT2(predictArity rhs == stgRhsArity stg_rhs, ppr id)
ASSERT2(consistent caf_info bind, ppr id)
-- WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info)
(env', fvs' `unionFVInfo` body_fvs, bind)
caf_info = hasCafRefss env1{-NB: not env'-} rhss
env' = extendVarEnvList env
- [ (b, LetBound how_bound emptyLVS (exprArity rhs))
+ [ (b, LetBound how_bound emptyLVS (predictArity rhs))
| (b,rhs) <- pairs ]
how_bound | mayHaveCafRefs caf_info = TopLevelHasCafs
bind = StgRec (SRTEntries cafs) (zip binders stg_rhss)
in
+ ASSERT2(and [predictArity rhs == stgRhsArity stg_rhs | (rhs,stg_rhs) <- rhss `zip` stg_rhss], ppr binders)
ASSERT2(consistent caf_info bind, ppr binders)
-- WARN(not (consistent caf_info bind), ppr binders <+> ppr cafs <+> ppCafInfo caf_info)
(env', fvs' `unionFVInfo` body_fvs, bind)
not_letrec_bound = not (isLetBound how_bound)
fun_fvs = singletonFVInfo f how_bound fun_occ
- -- Mostly, the arity info of a function is in the fn's IdInfo
- -- But new bindings introduced by CoreSat may not have no
- -- arity info; it would do us no good anyway. For example:
- -- let f = \ab -> e in f
- -- No point in having correct arity info for f!
- -- Hence the hasArity stuff below.
f_arity = case how_bound of
LetBound _ _ arity -> arity
_ -> 0
mk_binding bind_lvs bind_cafs binder rhs
= (binder, LetBound NotTopLevelBound -- Not top level
- live_vars (exprArity rhs)
+ live_vars (predictArity rhs)
)
where
live_vars = if let_no_escape then
freeVarsToLiveVars bind_fvs `thenLne` \ (bind_lvs, bind_cafs) ->
let
- env_ext_item@(binder', _) = mk_binding bind_lvs bind_cafs binder rhs
+ env_ext_item = mk_binding bind_lvs bind_cafs binder rhs
in
- returnLne (StgNonRec (SRTEntries bind_cafs) binder' rhs2,
+ returnLne (StgNonRec (SRTEntries bind_cafs) binder rhs2,
bind_fvs, escs, bind_lvs, bind_cafs, [env_ext_item])
%************************************************************************
%* *
+\subsection{Arity prediction}
+%* *
+%************************************************************************
+
+To avoid yet another knot, we predict the arity of each function from
+its Core form, based on the number of visible top-level lambdas.
+It should be the same as the arity of the STG RHS!
+
+\begin{code}
+predictArity :: CoreExpr -> Int
+predictArity (Lam x e)
+ | isTyVar x = predictArity e
+ | otherwise = 1 + predictArity e
+predictArity (Note _ e)
+ -- Ignore coercions. Top level sccs are removed by the final
+ -- profiling pass, so we ignore those too.
+ = predictArity e
+predictArity _ = 0
+\end{code}
+
+
+%************************************************************************
+%* *
\subsection[LNE-monad]{A little monad for this let-no-escaping pass}
%* *
%************************************************************************
projects / ghc-hetmet.git / commitdiff