%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
\section[StgVarInfo]{Sets free/live variable info in STG syntax}
let-no-escapes.
\begin{code}
-#include "HsVersions.h"
-
module StgVarInfo ( setStgVarInfo ) where
-IMPORT_Trace -- ToDo: rm (debugging only)
-import Pretty
-import Outputable
+#include "HsVersions.h"
import StgSyn
-import Id ( getIdArity, externallyVisibleId )
-import IdInfo -- ( arityMaybe, ArityInfo )
-
-import IdEnv
-import Maybes ( maybeToBool, Maybe(..) )
-import UniqSet
-import Util
+import Id ( setIdArityInfo, idArity, setIdOccInfo, Id )
+import VarSet
+import VarEnv
+import Var
+import IdInfo ( ArityInfo(..), OccInfo(..),
+ setInlinePragInfo )
+import PrimOp ( PrimOp(..), ccallMayGC )
+import TysWiredIn ( isForeignObjTy )
+import Maybes ( maybeToBool, orElse )
+import Name ( isLocallyDefined, getOccName )
+import OccName ( occNameUserString )
+import BasicTypes ( Arity )
+import Outputable
infixr 9 `thenLne`, `thenLne_`
\end{code}
(There is other relevant documentation in codeGen/CgLetNoEscape.)
+March 97: setStgVarInfo guarantees to leave every variable's arity correctly
+set. The lambda lifter makes some let-bound variables (which have arities)
+and turns them into lambda-bound ones (which should not, else we get Vap trouble),
+so this guarantee is necessary, as well as desirable.
+
+The arity information is used in the code generator, when deciding if
+a right-hand side is a saturated application so we can generate a VAP
+closure.
+
The actual Stg datatype is decorated with {\em live variable}
information, as well as {\em free variable} information. The two are
{\em not} the same. Liveness is an operational property rather than a
variable's stack slot (if it has one):
\begin{enumerate}
\item
-should be stubbed to avoid space leaks, and
+should be stubbed to avoid space leaks, and
\item
may be reused for something else.
\end{enumerate}
There ought to be a better way to say this. Here are some examples:
\begin{verbatim}
let v = [q] \[x] -> e
- in
+ in
...v... (but no q's)
\end{verbatim}
Just after the `in', v is live, but q is dead. If the whole of that
let expression was enclosed in a case expression, thus:
\begin{verbatim}
- case (let v = [q] \[x] -> e in ...v...) of
+ case (let v = [q] \[x] -> e in ...v...) of
alts[...q...]
\end{verbatim}
(ie @alts@ mention @q@), then @q@ is live even after the `in'; because
Let-no-escapes make this a bit more interesting:
\begin{verbatim}
let-no-escape v = [q] \ [x] -> e
- in
+ in
...v...
\end{verbatim}
Here, @q@ is still live at the `in', because @v@ is represented not by
Top-level:
\begin{code}
setStgVarInfo :: Bool -- True <=> do let-no-escapes
- -> [PlainStgBinding] -- input
- -> [PlainStgBinding] -- result
+ -> [StgBinding] -- input
+ -> [StgBinding] -- result
-setStgVarInfo want_LNEs pgm
- = pgm'
+setStgVarInfo want_LNEs pgm
+ = pgm'
where
(pgm', _) = initLne want_LNEs (varsTopBinds pgm)
-
+
\end{code}
For top-level guys, we basically aren't worried about this
as we step through the bindings (using @extendVarEnv@).
\begin{code}
-varsTopBinds :: [PlainStgBinding] -> LneM ([PlainStgBinding], FreeVarsInfo)
+varsTopBinds :: [StgBinding] -> LneM ([StgBinding], FreeVarsInfo)
varsTopBinds [] = returnLne ([], emptyFVInfo)
varsTopBinds (bind:binds)
- = extendVarEnv env_extension (
- varsTopBinds binds `thenLne` \ (binds', fv_binds) ->
- varsTopBind fv_binds bind `thenLne` \ (bind', fv_bind) ->
+ = extendVarEnvLne env_extension (
+ varsTopBinds binds `thenLne` \ (binds', fv_binds) ->
+ varsTopBind binders' fv_binds bind `thenLne` \ (bind', fv_bind) ->
returnLne ((bind' : binds'),
- (fv_binds `unionFVInfo` fv_bind) `minusFVBinders` binders
+ (fv_binds `unionFVInfo` fv_bind) `minusFVBinders` binders'
)
-
+
)
where
- env_extension = [(b, LetrecBound
- True {- top level -}
- (rhsArity rhs)
- emptyUniqSet)
- | (b,rhs) <- pairs]
-
pairs = case bind of
StgNonRec binder rhs -> [(binder,rhs)]
StgRec pairs -> pairs
- binders = [b | (b,_) <- pairs]
+ binders' = [ binder `setIdArityInfo` ArityExactly (rhsArity rhs)
+ | (binder, rhs) <- pairs
+ ]
+
+ env_extension = binders' `zip` repeat how_bound
+ how_bound = LetrecBound
+ True {- top level -}
+ emptyVarSet
-varsTopBind :: FreeVarsInfo -- Info about the body
- -> PlainStgBinding
- -> LneM (PlainStgBinding, FreeVarsInfo)
-varsTopBind body_fvs (StgNonRec binder rhs)
+varsTopBind :: [Id] -- New binders (with correct arity)
+ -> FreeVarsInfo -- Info about the body
+ -> StgBinding
+ -> LneM (StgBinding, FreeVarsInfo)
+
+varsTopBind [binder'] body_fvs (StgNonRec binder rhs)
= varsRhs body_fvs (binder,rhs) `thenLne` \ (rhs2, fvs, _) ->
- returnLne (StgNonRec binder rhs2, fvs)
+ returnLne (StgNonRec binder' rhs2, fvs)
-varsTopBind body_fvs (StgRec pairs)
- = let
- (binders, rhss) = unzip pairs
- in
- fixLne (\ ~(_, rec_rhs_fvs) ->
- let
+varsTopBind binders' body_fvs (StgRec pairs)
+ = fixLne (\ ~(_, rec_rhs_fvs) ->
+ let
scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
in
mapAndUnzip3Lne (varsRhs scope_fvs) pairs `thenLne` \ (rhss2, fvss, _) ->
let
fvs = unionFVInfos fvss
in
- returnLne (StgRec (binders `zip` rhss2), fvs)
+ returnLne (StgRec (binders' `zip` rhss2), fvs)
)
\end{code}
\begin{code}
varsRhs :: FreeVarsInfo -- Free var info for the scope of the binding
- -> (Id,PlainStgRhs)
- -> LneM (PlainStgRhs, FreeVarsInfo, EscVarsSet)
+ -> (Id,StgRhs)
+ -> LneM (StgRhs, FreeVarsInfo, EscVarsSet)
varsRhs scope_fv_info (binder, StgRhsCon cc con args)
- = varsAtoms args `thenLne` \ fvs ->
- returnLne (StgRhsCon cc con args, fvs, getFVSet fvs)
+ = varsAtoms args `thenLne` \ (args', fvs) ->
+ returnLne (StgRhsCon cc con args', fvs, getFVSet fvs)
-varsRhs scope_fv_info (binder, StgRhsClosure cc _ _ upd args body)
- = extendVarEnv [ (a, LambdaBound) | a <- args ] (
+varsRhs scope_fv_info (binder, StgRhsClosure cc _ srt _ upd args body)
+ = extendVarEnvLne [ (zapArity a, LambdaBound) | a <- args ] (
do_body args body `thenLne` \ (body2, body_fvs, body_escs) ->
let
- set_of_args = mkUniqSet args
+ set_of_args = mkVarSet args
rhs_fvs = body_fvs `minusFVBinders` args
- rhs_escs = body_escs `minusUniqSet` set_of_args
- binder_info = lookupFVInfo scope_fv_info binder
+ rhs_escs = body_escs `minusVarSet` set_of_args
+ binder_info = lookupFVInfo scope_fv_info binder
+ upd' | null args && isPAP body2 = ReEntrant
+ | otherwise = upd
in
- returnLne (StgRhsClosure cc binder_info (getFVs rhs_fvs) upd args body2,
- rhs_fvs, rhs_escs)
+ returnLne (StgRhsClosure cc binder_info srt (getFVs rhs_fvs) upd'
+ args body2, rhs_fvs, rhs_escs)
)
where
-- Pick out special case of application in body of thunk
- do_body [] (StgApp (StgVarAtom f) args _) = varsApp (Just upd) f args
- do_body _ other_body = varsExpr other_body
+ do_body [] (StgApp f args) = varsApp (Just upd) f args
+ do_body _ other_body = varsExpr other_body
\end{code}
+Detect thunks which will reduce immediately to PAPs, and make them
+non-updatable. This has several advantages:
+
+ - the non-updatable thunk behaves exactly like the PAP,
+
+ - the thunk is more efficient to enter, because it is
+ specialised to the task.
+
+ - we save one update frame, one stg_update_PAP, one update
+ and lots of PAP_enters.
+
+ - in the case where the thunk is top-level, we save building
+ a black hole and futhermore the thunk isn't considered to
+ be a CAF any more, so it doesn't appear in any SRTs.
+
+We do it here, because the arity information is accurate, and we need
+to do it before the SRT pass to save the SRT entries associated with
+any top-level PAPs.
+
\begin{code}
-varsAtoms :: [PlainStgAtom]
- -> LneM FreeVarsInfo
+isPAP (StgApp f args) = idArity f > length args
+isPAP _ = False
+\end{code}
+
+\begin{code}
+varsAtoms :: [StgArg]
+ -> LneM ([StgArg], FreeVarsInfo)
+ -- It's not *really* necessary to return fresh arguments,
+ -- because the only difference is that the argument variable
+ -- arities are correct. But it seems safer to do so.
varsAtoms atoms
- = mapLne var_atom atoms `thenLne` \ fvs_lists ->
- returnLne (unionFVInfos fvs_lists)
+ = mapAndUnzipLne var_atom atoms `thenLne` \ (args', fvs_lists) ->
+ returnLne (args', unionFVInfos fvs_lists)
where
- var_atom a@(StgLitAtom _) = returnLne emptyFVInfo
- var_atom a@(StgVarAtom v)
- = lookupVarEnv v `thenLne` \ how_bound ->
- returnLne (singletonFVInfo v how_bound stgArgOcc)
+ var_atom a@(StgVarArg v)
+ = lookupVarLne v `thenLne` \ (v', how_bound) ->
+ returnLne (StgVarArg v', singletonFVInfo v' how_bound stgArgOcc)
+ var_atom a = returnLne (a, emptyFVInfo)
\end{code}
%************************************************************************
@varsExpr@ carries in a monad-ised environment, which binds each
let(rec) variable (ie non top level, not imported, not lambda bound,
not case-alternative bound) to:
- - its STG arity, and
- - its set of live vars.
+ - its STG arity, and
+ - its set of live vars.
For normal variables the set of live vars is just the variable
itself. For let-no-escaped variables, the set of live vars is the set
live at the moment the variable is entered. The set is guaranteed to
have no further let-no-escaped vars in it.
\begin{code}
-varsExpr :: PlainStgExpr
- -> LneM (PlainStgExpr, -- Decorated expr
+varsExpr :: StgExpr
+ -> LneM (StgExpr, -- Decorated expr
FreeVarsInfo, -- Its free vars (NB free, not live)
EscVarsSet) -- Its escapees, a subset of its free vars;
-- also a subset of the domain of the envt
-- because we are only interested in the escapees
- -- for vars which might be turned into
+ -- for vars which might be turned into
-- let-no-escaped ones.
\end{code}
decisions. Hence no black holes.
\begin{code}
-varsExpr (StgApp lit@(StgLitAtom _) args _)
- = --(if null args then id else (trace (ppShow 80 (ppr PprShowAll args)))) (
- returnLne (StgApp lit [] emptyUniqSet, emptyFVInfo, emptyUniqSet)
- --)
+varsExpr (StgLit l) = returnLne (StgLit l, emptyFVInfo, emptyVarSet)
-varsExpr (StgApp fun@(StgVarAtom f) args _) = varsApp Nothing f args
+varsExpr (StgApp f args) = varsApp Nothing f args
-varsExpr (StgConApp con args _)
- = getVarsLiveInCont `thenLne` \ live_in_cont ->
- varsAtoms args `thenLne` \ args_fvs ->
+varsExpr (StgConApp con args)
+ = varsAtoms args `thenLne` \ (args', args_fvs) ->
+ returnLne (StgConApp con args', args_fvs, getFVSet args_fvs)
- returnLne (StgConApp con args live_in_cont, args_fvs, getFVSet args_fvs)
+varsExpr (StgPrimApp op args res_ty)
+ = varsAtoms args `thenLne` \ (args', args_fvs) ->
+ returnLne (StgPrimApp op args' res_ty, args_fvs, getFVSet args_fvs)
-varsExpr (StgPrimApp op args _)
- = getVarsLiveInCont `thenLne` \ live_in_cont ->
- varsAtoms args `thenLne` \ args_fvs ->
-
- returnLne (StgPrimApp op args live_in_cont, args_fvs, getFVSet args_fvs)
-
-varsExpr (StgSCC ty label expr)
+varsExpr (StgSCC cc expr)
= varsExpr expr `thenLne` ( \ (expr2, fvs, escs) ->
- returnLne (StgSCC ty label expr2, fvs, escs) )
+ returnLne (StgSCC cc expr2, fvs, escs) )
\end{code}
Cases require a little more real work.
\begin{code}
-varsExpr (StgCase scrut _ _ uniq alts)
+varsExpr (StgCase scrut _ _ bndr srt alts)
= getVarsLiveInCont `thenLne` \ live_in_cont ->
+ extendVarEnvLne [(zapArity bndr, CaseBound)] (
vars_alts alts `thenLne` \ (alts2, alts_fvs, alts_escs) ->
lookupLiveVarsForSet alts_fvs `thenLne` \ alts_lvs ->
let
- live_in_alts = live_in_cont `unionUniqSets` alts_lvs
+ -- determine whether the default binder is dead or not
+ bndr'= if (bndr `elementOfFVInfo` alts_fvs)
+ then bndr `setIdOccInfo` NoOccInfo
+ else bndr `setIdOccInfo` IAmDead
+
+ -- for a _ccall_GC_, some of the *arguments* need to live across the
+ -- call (see findLiveArgs comments.), so we annotate them as being live
+ -- in the alts to achieve the desired effect.
+ mb_live_across_case =
+ case scrut of
+ StgPrimApp (CCallOp ccall) args _
+ | ccallMayGC ccall
+ -> Just (foldl findLiveArgs emptyVarSet args)
+ _ -> Nothing
+
+ -- don't consider the default binder as being 'live in alts',
+ -- since this is from the point of view of the case expr, where
+ -- the default binder is not free.
+ live_in_alts = orElse (FMAP unionVarSet mb_live_across_case) id $
+ live_in_cont `unionVarSet`
+ (alts_lvs `minusVarSet` unitVarSet bndr)
in
-- we tell the scrutinee that everything live in the alts
-- is live in it, too.
) `thenLne` \ (scrut2, scrut_fvs, scrut_escs) ->
lookupLiveVarsForSet scrut_fvs `thenLne` \ scrut_lvs ->
let
- live_in_whole_case = live_in_alts `unionUniqSets` scrut_lvs
+ live_in_whole_case = live_in_alts `unionVarSet` scrut_lvs
in
returnLne (
- StgCase scrut2 live_in_whole_case live_in_alts uniq alts2,
- scrut_fvs `unionFVInfo` alts_fvs,
- alts_escs `unionUniqSets` (getFVSet scrut_fvs) -- All free vars in the scrutinee escape
+ StgCase scrut2 live_in_whole_case live_in_alts bndr' srt alts2,
+ (scrut_fvs `unionFVInfo` alts_fvs)
+ `minusFVBinders` [bndr],
+ (alts_escs `minusVarSet` unitVarSet bndr) `unionVarSet` getFVSet scrut_fvs
+ -- You might think we should have scrut_escs, not (getFVSet scrut_fvs),
+ -- but actually we can't call, and then return from, a let-no-escape thing.
+ )
)
where
vars_alts (StgAlgAlts ty alts deflt)
`thenLne` \ (alts2, alts_fvs_list, alts_escs_list) ->
let
alts_fvs = unionFVInfos alts_fvs_list
- alts_escs = unionManyUniqSets alts_escs_list
+ alts_escs = unionVarSets alts_escs_list
in
vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) ->
returnLne (
StgAlgAlts ty alts2 deflt2,
alts_fvs `unionFVInfo` deflt_fvs,
- alts_escs `unionUniqSets` deflt_escs
+ alts_escs `unionVarSet` deflt_escs
)
where
vars_alg_alt (con, binders, worthless_use_mask, rhs)
- = extendVarEnv [(b, CaseBound) | b <- binders] (
+ = extendVarEnvLne [(zapArity b, CaseBound) | b <- binders] (
varsExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
let
good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders ]
returnLne (
(con, binders, good_use_mask, rhs2),
rhs_fvs `minusFVBinders` binders,
- rhs_escs `minusUniqSet` mkUniqSet binders -- ToDo: remove the minusUniqSet;
+ rhs_escs `minusVarSet` mkVarSet binders -- ToDo: remove the minusVarSet;
-- since escs won't include
-- any of these binders
))
`thenLne` \ (alts2, alts_fvs_list, alts_escs_list) ->
let
alts_fvs = unionFVInfos alts_fvs_list
- alts_escs = unionManyUniqSets alts_escs_list
+ alts_escs = unionVarSets alts_escs_list
in
vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) ->
returnLne (
StgPrimAlts ty alts2 deflt2,
alts_fvs `unionFVInfo` deflt_fvs,
- alts_escs `unionUniqSets` deflt_escs
+ alts_escs `unionVarSet` deflt_escs
)
where
vars_prim_alt (lit, rhs)
returnLne ((lit, rhs2), rhs_fvs, rhs_escs)
vars_deflt StgNoDefault
- = returnLne (StgNoDefault, emptyFVInfo, emptyUniqSet)
+ = returnLne (StgNoDefault, emptyFVInfo, emptyVarSet)
- vars_deflt (StgBindDefault binder _ rhs)
- = extendVarEnv [(binder, CaseBound)] (
- varsExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
- let
- used_in_rhs = binder `elementOfFVInfo` rhs_fvs
- in
- returnLne (
- StgBindDefault binder used_in_rhs rhs2,
- rhs_fvs `minusFVBinders` [binder],
- rhs_escs `minusUniqSet` singletonUniqSet binder
- ))
+ vars_deflt (StgBindDefault rhs)
+ = varsExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
+ returnLne ( StgBindDefault rhs2, rhs_fvs, rhs_escs )
\end{code}
Lets not only take quite a bit of work, but this is where we convert
\begin{code}
varsExpr (StgLetNoEscape _ _ _ _) = panic "varsExpr: unexpected StgLetNoEscape"
-varsExpr (StgLet bind body)
+varsExpr (StgLet bind body)
= isSwitchSetLne {-StgDoLetNoEscapes-} `thenLne` \ want_LNEs ->
(fixLne (\ ~(_, _, _, no_binder_escapes) ->
- let
+ let
non_escaping_let = want_LNEs && no_binder_escapes
in
- vars_let non_escaping_let bind body
+ vars_let non_escaping_let bind body
)) `thenLne` \ (new_let, fvs, escs, _) ->
returnLne (new_let, fvs, escs)
\end{code}
-\begin{code}
-#ifdef DPH
--- rest of varsExpr goes here
+If we've got a case containing a _ccall_GC_ primop, we need to
+ensure that the arguments are kept live for the duration of the
+call. This only an issue
-#endif {- Data Parallel Haskell -}
+\begin{code}
+findLiveArgs :: StgLiveVars -> StgArg -> StgLiveVars
+findLiveArgs lvs (StgVarArg x)
+ | isForeignObjTy (idType x) = extendVarSet lvs x
+ | otherwise = lvs
+findLiveArgs lvs arg = lvs
\end{code}
+
Applications:
\begin{code}
varsApp :: Maybe UpdateFlag -- Just upd <=> this application is
-- x = [...] \upd [] -> the_app
-- with specified update flag
-> Id -- Function
- -> [PlainStgAtom] -- Arguments
- -> LneM (PlainStgExpr, FreeVarsInfo, EscVarsSet)
+ -> [StgArg] -- Arguments
+ -> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
varsApp maybe_thunk_body f args
= getVarsLiveInCont `thenLne` \ live_in_cont ->
- varsAtoms args `thenLne` \ args_fvs ->
-
- lookupVarEnv f `thenLne` \ how_bound ->
-
- let
- n_args = length args
-
- fun_fvs = singletonFVInfo f how_bound fun_occ
-
- fun_occ =
- case how_bound of
- LetrecBound _ arity _
- | n_args == 0 -> stgFakeFunAppOcc -- Function Application
- -- with no arguments.
- -- used by the lambda lifter.
- | arity > n_args -> stgUnsatOcc -- Unsaturated
-
-
- | arity == n_args &&
- maybeToBool maybe_thunk_body -> -- Exactly saturated,
- -- and rhs of thunk
- case maybe_thunk_body of
- Just Updatable -> stgStdHeapOcc
- Just SingleEntry -> stgNoUpdHeapOcc
- other -> panic "varsApp"
+ varsAtoms args `thenLne` \ (args', args_fvs) ->
- | otherwise -> stgNormalOcc
- -- record only that it occurs free
+ lookupVarLne f `thenLne` \ (f', how_bound) ->
- other -> NoStgBinderInfo
- -- uninteresting variable
-
- myself = singletonUniqSet f
-
- fun_escs = case how_bound of
-
- LetrecBound _ arity lvs ->
- if arity == n_args then
- emptyUniqSet -- Function doesn't escape
- else
- myself -- Inexact application; it does escape
-
- other -> emptyUniqSet -- Only letrec-bound escapees
- -- are interesting
+ let
+ n_args = length args
+ not_letrec_bound = not (isLetrecBound how_bound)
+ f_arity = idArity f' -- Will have an exact arity by now
+ fun_fvs = singletonFVInfo f' how_bound fun_occ
+
+ fun_occ
+ | not_letrec_bound = NoStgBinderInfo -- Uninteresting variable
+
+ -- Otherwise it is letrec bound; must have its arity
+ | n_args == 0 = stgFakeFunAppOcc -- Function Application
+ -- with no arguments.
+ -- used by the lambda lifter.
+ | f_arity > n_args = stgUnsatOcc -- Unsaturated
+
+
+ | f_arity == n_args &&
+ maybeToBool maybe_thunk_body -- Exactly saturated,
+ -- and rhs of thunk
+ = case maybe_thunk_body of
+ Just Updatable -> stgStdHeapOcc
+ Just SingleEntry -> stgNoUpdHeapOcc
+ other -> panic "varsApp"
+
+ | otherwise = stgNormalOcc
+ -- Record only that it occurs free
+
+ myself = unitVarSet f'
+
+ fun_escs | not_letrec_bound = emptyVarSet -- Only letrec-bound escapees are interesting
+ | f_arity == n_args = emptyVarSet -- Function doesn't escape
+ | otherwise = myself -- Inexact application; it does escape
-- At the moment of the call:
-- continuation, but it does no harm to just union the
-- two regardless.
- live_at_call
- = live_in_cont `unionUniqSets` case how_bound of
- LetrecBound _ _ lvs -> lvs `minusUniqSet` myself
- other -> emptyUniqSet
+ -- XXX not needed?
+ -- live_at_call
+ -- = live_in_cont `unionVarSet` case how_bound of
+ -- LetrecBound _ lvs -> lvs `minusVarSet` myself
+ -- other -> emptyVarSet
in
returnLne (
- StgApp (StgVarAtom f) args live_at_call,
+ StgApp f' args',
fun_fvs `unionFVInfo` args_fvs,
- fun_escs `unionUniqSets` (getFVSet args_fvs)
+ fun_escs `unionVarSet` (getFVSet args_fvs)
-- All the free vars of the args are disqualified
-- from being let-no-escaped.
)
The magic for lets:
\begin{code}
vars_let :: Bool -- True <=> yes, we are let-no-escaping this let
- -> PlainStgBinding -- bindings
- -> PlainStgExpr -- body
- -> LneM (PlainStgExpr, -- new let
+ -> StgBinding -- bindings
+ -> StgExpr -- body
+ -> LneM (StgExpr, -- new let
FreeVarsInfo, -- variables free in the whole let
EscVarsSet, -- variables that escape from the whole let
Bool) -- True <=> none of the binders in the bindings
-- we ain't in a let-no-escape world
getVarsLiveInCont `thenLne` \ live_in_cont ->
setVarsLiveInCont
- (if let_no_escape then live_in_cont else emptyUniqSet)
+ (if let_no_escape then live_in_cont else emptyVarSet)
(vars_bind rec_bind_lvs rec_body_fvs bind)
`thenLne` \ (bind2, bind_fvs, bind_escs, env_ext) ->
-- by virtue of being accessible via the free vars of the binding (lvs_from_fvs)
-- together with the live_in_cont ones
lookupLiveVarsForSet (bind_fvs `minusFVBinders` binders) `thenLne` \ lvs_from_fvs ->
- let
- bind_lvs = lvs_from_fvs `unionUniqSets` live_in_cont
+ let
+ bind_lvs = lvs_from_fvs `unionVarSet` live_in_cont
in
-- bind_fvs and bind_escs still include the binders of the let(rec)
-- but bind_lvs does not
-- Do the body
- extendVarEnv env_ext (
- varsExpr body `thenLne` \ (body2, body_fvs, body_escs) ->
- lookupLiveVarsForSet body_fvs `thenLne` \ body_lvs ->
+ extendVarEnvLne env_ext (
+ varsExpr body `thenLne` \ (body2, body_fvs, body_escs) ->
+ lookupLiveVarsForSet body_fvs `thenLne` \ body_lvs ->
- returnLne (bind2, bind_fvs, bind_escs, bind_lvs,
- body2, body_fvs, body_escs, body_lvs)
+ returnLne (bind2, bind_fvs, bind_escs, bind_lvs,
+ body2, body_fvs, body_escs, body_lvs)
)) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs,
body2, body_fvs, body_escs, body_lvs) ->
-- Compute the new let-expression
- let
- new_let = if let_no_escape then
- -- trace "StgLetNoEscape!" (
- StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
- -- )
- else
- StgLet bind2 body2
+ let
+ new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
+ | otherwise = StgLet bind2 body2
free_in_whole_let
= (bind_fvs `unionFVInfo` body_fvs) `minusFVBinders` binders
live_in_whole_let
- = bind_lvs `unionUniqSets` (body_lvs `minusUniqSet` set_of_binders)
+ = bind_lvs `unionVarSet` (body_lvs `minusVarSet` set_of_binders)
- real_bind_escs = if let_no_escape then
+ real_bind_escs = if let_no_escape then
bind_escs
else
getFVSet bind_fvs
-- Everything escapes which is free in the bindings
- let_escs = (real_bind_escs `unionUniqSets` body_escs) `minusUniqSet` set_of_binders
+ let_escs = (real_bind_escs `unionVarSet` body_escs) `minusVarSet` set_of_binders
- all_escs = bind_escs `unionUniqSets` body_escs -- Still includes binders of
+ all_escs = bind_escs `unionVarSet` body_escs -- Still includes binders of
-- this let(rec)
- no_binder_escapes = isEmptyUniqSet (set_of_binders `intersectUniqSets` all_escs)
- -- Mustn't depend on the passed-in let_no_escape flag, since
+ no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs)
+
+#ifdef DEBUG
+ -- Debugging code as requested by Andrew Kennedy
+ checked_no_binder_escapes
+ | not no_binder_escapes && any is_join_var binders
+ = pprTrace "Interesting! A join var that isn't let-no-escaped" (ppr binders)
+ False
+ | otherwise = no_binder_escapes
+#else
+ checked_no_binder_escapes = no_binder_escapes
+#endif
+
+ -- Mustn't depend on the passed-in let_no_escape flag, since
-- no_binder_escapes is used by the caller to derive the flag!
in
returnLne (
new_let,
free_in_whole_let,
let_escs,
- no_binder_escapes
+ checked_no_binder_escapes
))
where
- binders = case bind of
- StgNonRec binder rhs -> [binder]
- StgRec pairs -> map fst pairs
- set_of_binders = mkUniqSet binders
+ set_of_binders = mkVarSet binders
+ binders = case bind of
+ StgNonRec binder rhs -> [binder]
+ StgRec pairs -> map fst pairs
mk_binding bind_lvs (binder,rhs)
- = (binder,
+ = (binder `setIdArityInfo` ArityExactly (stgArity rhs),
LetrecBound False -- Not top level
- (stgArity rhs)
live_vars
)
where
- live_vars = if let_no_escape then
- bind_lvs `unionUniqSets` singletonUniqSet binder
- else
- singletonUniqSet binder
+ live_vars = if let_no_escape then
+ extendVarSet bind_lvs binder
+ else
+ unitVarSet binder
- vars_bind :: PlainStgLiveVars
+ vars_bind :: StgLiveVars
-> FreeVarsInfo -- Free var info for body of binding
- -> PlainStgBinding
- -> LneM (PlainStgBinding,
+ -> StgBinding
+ -> LneM (StgBinding,
FreeVarsInfo, EscVarsSet, -- free vars; escapee vars
[(Id, HowBound)])
-- extension to environment
vars_bind rec_bind_lvs rec_body_fvs (StgNonRec binder rhs)
= varsRhs rec_body_fvs (binder,rhs) `thenLne` \ (rhs2, fvs, escs) ->
let
- env_ext = [mk_binding rec_bind_lvs (binder,rhs)]
+ env_ext_item@(binder', _) = mk_binding rec_bind_lvs (binder,rhs)
in
- returnLne (StgNonRec binder rhs2, fvs, escs, env_ext)
+ returnLne (StgNonRec binder' rhs2, fvs, escs, [env_ext_item])
vars_bind rec_bind_lvs rec_body_fvs (StgRec pairs)
= let
- (binders, rhss) = unzip pairs
- env_ext = map (mk_binding rec_bind_lvs) pairs
+ env_ext = map (mk_binding rec_bind_lvs) pairs
+ binders' = map fst env_ext
in
- extendVarEnv env_ext (
+ extendVarEnvLne env_ext (
fixLne (\ ~(_, rec_rhs_fvs, _, _) ->
- let
+ let
rec_scope_fvs = unionFVInfo rec_body_fvs rec_rhs_fvs
in
mapAndUnzip3Lne (varsRhs rec_scope_fvs) pairs `thenLne` \ (rhss2, fvss, escss) ->
let
fvs = unionFVInfos fvss
- escs = unionManyUniqSets escss
+ escs = unionVarSets escss
in
- returnLne (StgRec (binders `zip` rhss2), fvs, escs, env_ext)
+ returnLne (StgRec (binders' `zip` rhss2), fvs, escs, env_ext)
))
+
+is_join_var :: Id -> Bool
+-- A hack (used only for compiler debuggging) to tell if
+-- a variable started life as a join point ($j)
+is_join_var j = occNameUserString (getOccName j) == "$j"
\end{code}
%************************************************************************
\begin{code}
type LneM a = Bool -- True <=> do let-no-escapes
- -> IdEnv HowBound
- -> PlainStgLiveVars -- vars live in continuation
+ -> IdEnv (Id, HowBound) -- Use the Id at all occurrences; it has correct
+ -- arity information inside it.
+ -> StgLiveVars -- vars live in continuation
-> a
-type Arity = Int
-
data HowBound
= ImportBound
| CaseBound
| LambdaBound
- | LetrecBound
- Bool -- True <=> bound at top level
- Arity -- Arity
- PlainStgLiveVars -- Live vars... see notes below
+ | LetrecBound
+ Bool -- True <=> bound at top level
+ StgLiveVars -- Live vars... see notes below
+
+isLetrecBound (LetrecBound _ _) = True
+isLetrecBound other = False
\end{code}
-For a let(rec)-bound variable, x, we record what varibles are live if
-x is live. For "normal" variables that is just x alone. If x is
+For a let(rec)-bound variable, x, we record what varibles are live if
+x is live. For "normal" variables that is just x alone. If x is
a let-no-escaped variable then x is represented by a code pointer and
a stack pointer (well, one for each stack). So all of the variables
needed in the execution of x are live if x is, and are therefore recorded
The std monad functions:
\begin{code}
initLne :: Bool -> LneM a -> a
-initLne want_LNEs m = m want_LNEs nullIdEnv emptyUniqSet
+initLne want_LNEs m = m want_LNEs emptyVarEnv emptyVarSet
-#ifdef __GLASGOW_HASKELL__
{-# INLINE thenLne #-}
{-# INLINE thenLne_ #-}
{-# INLINE returnLne #-}
-#endif
returnLne :: a -> LneM a
returnLne e sw env lvs_cont = e
thenLne :: LneM a -> (a -> LneM b) -> LneM b
-(m `thenLne` k) sw env lvs_cont
+thenLne m k sw env lvs_cont
= case (m sw env lvs_cont) of
m_result -> k m_result sw env lvs_cont
thenLne_ :: LneM a -> LneM b -> LneM b
-(m `thenLne_` k) sw env lvs_cont
+thenLne_ m k sw env lvs_cont
= case (m sw env lvs_cont) of
_ -> k sw env lvs_cont
Functions specific to this monad:
\begin{code}
-{- NOT USED:
-ifSwitchSetLne :: GlobalSwitch -> LneM a -> LneM a -> LneM a
-ifSwitchSetLne switch then_ else_ switch_checker env lvs_cont
- = (if switch_checker switch then then_ else else_) switch_checker env lvs_cont
--}
-
isSwitchSetLne :: LneM Bool
isSwitchSetLne want_LNEs env lvs_cont
= want_LNEs
-getVarsLiveInCont :: LneM PlainStgLiveVars
+getVarsLiveInCont :: LneM StgLiveVars
getVarsLiveInCont sw env lvs_cont = lvs_cont
-setVarsLiveInCont :: PlainStgLiveVars -> LneM a -> LneM a
+setVarsLiveInCont :: StgLiveVars -> LneM a -> LneM a
setVarsLiveInCont new_lvs_cont expr sw env lvs_cont
= expr sw env new_lvs_cont
-extendVarEnv :: [(Id, HowBound)] -> LneM a -> LneM a
-extendVarEnv extension expr sw env lvs_cont
- = expr sw (growIdEnvList env extension) lvs_cont
+extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
+extendVarEnvLne ids_w_howbound expr sw env lvs_cont
+ = expr sw (extendVarEnvList env [(id, pair) | pair@(id,_) <- ids_w_howbound]) lvs_cont
-lookupVarEnv :: Id -> LneM HowBound
-lookupVarEnv v sw env lvs_cont
+
+lookupVarLne :: Id -> LneM (Id, HowBound)
+lookupVarLne v sw env lvs_cont
= returnLne (
- case (lookupIdEnv env v) of
+ case (lookupVarEnv env v) of
Just xx -> xx
Nothing -> --false:ASSERT(not (isLocallyDefined v))
- ImportBound
+ (v, ImportBound)
) sw env lvs_cont
-- The result of lookupLiveVarsForSet, a set of live variables, is
-- only ever tacked onto a decorated expression. It is never used as
-- the basis of a control decision, which might give a black hole.
-lookupLiveVarsForSet :: FreeVarsInfo -> LneM PlainStgLiveVars
+lookupLiveVarsForSet :: FreeVarsInfo -> LneM StgLiveVars
lookupLiveVarsForSet fvs sw env lvs_cont
- = returnLne (unionManyUniqSets (map do_one (getFVs fvs)))
+ = returnLne (unionVarSets (map do_one (getFVs fvs)))
sw env lvs_cont
where
do_one v
= if isLocallyDefined v then
- case (lookupIdEnv env v) of
- Just (LetrecBound _ _ lvs) -> lvs `unionUniqSets` singletonUniqSet v
- Just _ -> singletonUniqSet v
- Nothing -> pprPanic "lookupVarEnv/do_one:" (ppr PprShowAll v)
+ case (lookupVarEnv env v) of
+ Just (_, LetrecBound _ lvs) -> extendVarSet lvs v
+ Just _ -> unitVarSet v
+ Nothing -> pprPanic "lookupVarEnv/do_one:" (ppr v)
else
- emptyUniqSet
+ emptyVarSet
\end{code}
%************************************************************************
\begin{code}
-type FreeVarsInfo = IdEnv (Id, Bool, StgBinderInfo)
+type FreeVarsInfo = IdEnv (Id, Bool, StgBinderInfo)
-- If f is mapped to NoStgBinderInfo, that means
-- that f *is* mentioned (else it wouldn't be in the
-- IdEnv at all), but only in a saturated applications.
- --
+ --
-- All case/lambda-bound things are also mapped to
-- NoStgBinderInfo, since we aren't interested in their
-- occurence info.
--
-- The Bool is True <=> the Id is top level letrec bound
-type EscVarsSet = UniqSet Id
+type EscVarsSet = IdSet
\end{code}
\begin{code}
emptyFVInfo :: FreeVarsInfo
-emptyFVInfo = nullIdEnv
+emptyFVInfo = emptyVarEnv
singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
-singletonFVInfo id ImportBound info = nullIdEnv
-singletonFVInfo id (LetrecBound top_level _ _) info = unitIdEnv id (id, top_level, info)
-singletonFVInfo id other info = unitIdEnv id (id, False, info)
+singletonFVInfo id ImportBound info = emptyVarEnv
+singletonFVInfo id (LetrecBound top_level _) info = unitVarEnv id (id, top_level, info)
+singletonFVInfo id other info = unitVarEnv id (id, False, info)
unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
-unionFVInfo fv1 fv2 = combineIdEnvs plusFVInfo fv1 fv2
+unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
minusFVBinders :: FreeVarsInfo -> [Id] -> FreeVarsInfo
-minusFVBinders fv ids = fv `delManyFromIdEnv` ids
+minusFVBinders fv ids = fv `delVarEnvList` ids
elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
-elementOfFVInfo id fvs = maybeToBool (lookupIdEnv fvs id)
+elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id)
lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo
-lookupFVInfo fvs id = case lookupIdEnv fvs id of
+lookupFVInfo fvs id = case lookupVarEnv fvs id of
Nothing -> NoStgBinderInfo
Just (_,_,info) -> info
getFVs :: FreeVarsInfo -> [Id] -- Non-top-level things only
-getFVs fvs = [id | (id,False,_) <- rngIdEnv fvs]
+getFVs fvs = [id | (id,False,_) <- rngVarEnv fvs]
-getFVSet :: FreeVarsInfo -> UniqSet Id
-getFVSet fvs = mkUniqSet (getFVs fvs)
+getFVSet :: FreeVarsInfo -> IdSet
+getFVSet fvs = mkVarSet (getFVs fvs)
plusFVInfo (id1,top1,info1) (id2,top2,info2)
= ASSERT (id1 == id2 && top1 == top2)
\end{code}
\begin{code}
-rhsArity :: PlainStgRhs -> Arity
+rhsArity :: StgRhs -> Arity
rhsArity (StgRhsCon _ _ _) = 0
-rhsArity (StgRhsClosure _ _ _ _ args _) = length args
+rhsArity (StgRhsClosure _ _ _ _ _ args _) = length args
+
+zapArity :: Id -> Id
+zapArity id = id `setIdArityInfo` UnknownArity
\end{code}