coreToStg :: DynFlags -> [CoreBind] -> IO [StgBinding]
coreToStg dflags pgm
= return pgm'
- where (env', fvs, pgm') = coreTopBindsToStg emptyVarEnv pgm
+ where (_, _, pgm') = coreTopBindsToStg emptyVarEnv pgm
coreExprToStg :: CoreExpr -> StgExpr
coreExprToStg expr
coreTopBindsToStg env [] = (env, emptyFVInfo, [])
coreTopBindsToStg env (b:bs)
- = (env2, fvs1, b':bs')
+ = (env2, fvs2, b':bs')
where
-- env accumulates down the list of binds, fvs accumulates upwards
(env1, fvs2, b' ) = coreTopBindToStg env fvs1 b
coreTopBindToStg env body_fvs (NonRec id rhs)
= let
caf_info = hasCafRefs env rhs
- arity = exprArity rhs
- env' = extendVarEnv env id (LetBound how_bound emptyVarSet 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)
-- to calculate caf_info, we initially map all the binders to
-- TopLevelNoCafs.
env1 = extendVarEnvList env
- [ (b, LetBound TopLevelNoCafs emptyVarSet (error "no arity"))
+ [ (b, LetBound TopLevelNoCafs emptyLVS (error "no arity"))
| b <- binders ]
caf_info = hasCafRefss env1{-NB: not env'-} rhss
env' = extendVarEnvList env
- [ (b, LetBound how_bound emptyVarSet (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)
where
binder_info = lookupFVInfo scope_fv_info binder
-bogus_rhs = StgRhsClosure noCCS noBinderInfo [] ReEntrant [] bogus_expr
-bogus_expr = (StgLit (MachInt 1))
-
mkStgRhs :: TopLevelFlag -> FreeVarsInfo -> StgBinderInfo
-> StgExpr -> StgRhs
lookupVarLne f `thenLne` \ how_bound ->
let
- n_args = length args
+ n_val_args = valArgCount args
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
fun_occ
- | not_letrec_bound = noBinderInfo -- Uninteresting variable
- | f_arity > 0 && f_arity <= n_args = stgSatOcc -- Saturated or over-saturated function call
- | otherwise = stgUnsatOcc -- Unsaturated function or thunk
+ | not_letrec_bound = noBinderInfo -- Uninteresting variable
+ | f_arity > 0 && f_arity <= n_val_args = stgSatOcc -- Saturated or over-saturated function call
+ | otherwise = stgUnsatOcc -- Unsaturated function or thunk
fun_escs
- | not_letrec_bound = emptyVarSet -- Only letrec-bound escapees are interesting
- | f_arity == n_args = emptyVarSet -- A function *or thunk* with an exactly
+ | not_letrec_bound = emptyVarSet -- Only letrec-bound escapees are interesting
+ | f_arity == n_val_args = emptyVarSet -- A function *or thunk* with an exactly
-- saturated call doesn't escape
-- (let-no-escape applies to 'thunks' too)
-- is among the escaping vars
coreToStgLet let_no_escape bind body
- = fixLne (\ ~(_, _, _, _, _, rec_body_fvs, _, _) ->
+ = fixLne (\ ~(_, _, _, _, _, _, rec_body_fvs, _, _) ->
-- Do the bindings, setting live_in_cont to empty if
-- we ain't in a let-no-escape world
getVarsLiveInCont `thenLne` \ live_in_cont ->
setVarsLiveInCont (if let_no_escape
then live_in_cont
- else (emptyVarSet,emptyVarSet))
+ else emptyLVS)
(vars_bind rec_body_fvs bind)
- `thenLne` \ (bind2, bind_fvs, bind_escs, bind_lvs, env_ext) ->
+ `thenLne` \ ( bind2, bind_fvs, bind_escs
+ , bind_lvs, bind_cafs, env_ext) ->
-- Do the body
extendVarEnvLne env_ext (
coreToStgExpr body `thenLne` \(body2, body_fvs, body_escs) ->
freeVarsToLiveVars body_fvs `thenLne` \(body_lvs, _) ->
- returnLne (bind2, bind_fvs, bind_escs, bind_lvs,
+ returnLne (bind2, bind_fvs, bind_escs, bind_lvs, bind_cafs,
body2, body_fvs, body_escs, body_lvs)
)
- ) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs,
+ ) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs, bind_cafs,
body2, body_fvs, body_escs, body_lvs) ->
NonRec binder rhs -> [binder]
Rec pairs -> map fst pairs
- mk_binding bind_lvs binder rhs
+ 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
- extendVarSet bind_lvs binder
+ (extendVarSet bind_lvs binder, bind_cafs)
else
- unitVarSet binder
+ (unitVarSet binder, emptyVarSet)
vars_bind :: FreeVarsInfo -- Free var info for body of binding
-> CoreBind
FreeVarsInfo,
EscVarsSet, -- free vars; escapee vars
StgLiveVars, -- vars live in binding
+ IdSet, -- CAFs live in binding
[(Id, HowBound)]) -- extension to environment
freeVarsToLiveVars bind_fvs `thenLne` \ (bind_lvs, bind_cafs) ->
let
- env_ext_item@(binder', _) = mk_binding bind_lvs binder rhs
+ env_ext_item = mk_binding bind_lvs bind_cafs binder rhs
in
- returnLne (StgNonRec (SRTEntries bind_cafs) binder' rhs2,
- bind_fvs, escs, bind_lvs, [env_ext_item])
+ returnLne (StgNonRec (SRTEntries bind_cafs) binder rhs2,
+ bind_fvs, escs, bind_lvs, bind_cafs, [env_ext_item])
vars_bind body_fvs (Rec pairs)
- = fixLne (\ ~(_, rec_rhs_fvs, _, bind_lvs, _) ->
+ = fixLne (\ ~(_, rec_rhs_fvs, _, bind_lvs, bind_cafs, _) ->
let
rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
binders = map fst pairs
- env_ext = [ mk_binding bind_lvs b rhs | (b,rhs) <- pairs ]
+ env_ext = [ mk_binding bind_lvs bind_cafs b rhs
+ | (b,rhs) <- pairs ]
in
extendVarEnvLne env_ext (
mapAndUnzip3Lne (coreToStgRhs rec_scope_fvs NotTopLevel) pairs
in
freeVarsToLiveVars (binders `minusFVBinders` bind_fvs)
`thenLne` \ (bind_lvs, bind_cafs) ->
+
returnLne (StgRec (SRTEntries bind_cafs) (binders `zip` rhss2),
- bind_fvs, escs, bind_lvs, env_ext)
+ bind_fvs, escs, bind_lvs, bind_cafs, env_ext)
)
)
%************************************************************************
%* *
+\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}
%* *
%************************************************************************
| LambdaBound
| LetBound
TopLevelCafInfo
- StgLiveVars -- Live vars... see notes below
- Arity -- its arity (local Ids don't have arity info at this point)
+ (StgLiveVars, IdSet) -- (Live vars, Live CAFs)... see notes below
+ Arity -- its arity (local Ids don't have arity info at this point)
isLetBound (LetBound _ _ _) = True
isLetBound other = False
The std monad functions:
\begin{code}
initLne :: IdEnv HowBound -> LneM a -> a
-initLne env m = m env (emptyVarSet,emptyVarSet)
+initLne env m = m env emptyLVS
+
+emptyLVS = (emptyVarSet,emptyVarSet)
{-# INLINE thenLne #-}
{-# INLINE returnLne #-}
freeVarsToLiveVars :: FreeVarsInfo -> LneM (StgLiveVars, IdSet)
freeVarsToLiveVars fvs env live_in_cont
- = returnLne (lvs `unionVarSet` lvs_cont,
- mkVarSet cafs `unionVarSet` cafs_cont)
- env live_in_cont
+ = returnLne (lvs, cafs) env live_in_cont
where
(lvs_cont, cafs_cont) = live_in_cont -- not a strict pattern match!
(local, global) = partition isLocalId (allFVs fvs)
- cafs = filter is_caf_one global
- lvs = unionVarSets (map do_one local)
+ (lvs_from_fvs, caf_extras) = unzip (map do_one local)
+
+ lvs = unionVarSets lvs_from_fvs
+ `unionVarSet` lvs_cont
+
+ cafs = mkVarSet (filter is_caf_one global)
+ `unionVarSet` (unionVarSets caf_extras)
+ `unionVarSet` cafs_cont
do_one v
- = if isLocalId v then
- case (lookupVarEnv env v) of
- Just (LetBound _ lvs _) -> extendVarSet lvs v
- Just _ -> unitVarSet v
+ = case (lookupVarEnv env v) of
+ Just (LetBound _ (lvs,cafs) _) -> (extendVarSet lvs v, cafs)
+ Just _ -> (unitVarSet v, emptyVarSet)
Nothing -> pprPanic "lookupLiveVarsForSet/do_one:" (ppr v)
- else
- emptyVarSet
is_caf_one v
= case lookupVarEnv env v of
- Just (LetBound TopLevelHasCafs lvs _) ->
+ Just (LetBound TopLevelHasCafs (lvs,_) _) ->
ASSERT( isEmptyVarSet lvs ) True
Just (LetBound _ _ _) -> False
_otherwise -> mayHaveCafRefs (idCafInfo v)
projects / ghc-hetmet.git / blobdiff