import StgSyn
-import Id ( setIdArity, getIdArity, Id )
+import Id ( setIdArityInfo, idArity, setIdOccInfo, Id )
import VarSet
import VarEnv
-import IdInfo ( ArityInfo(..) )
-import Maybes ( maybeToBool )
-import Name ( isLocallyDefined )
+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
StgNonRec binder rhs -> [(binder,rhs)]
StgRec pairs -> pairs
- binders' = [ binder `setIdArity` ArityExactly (rhsArity rhs)
+ binders' = [ binder `setIdArityInfo` ArityExactly (rhsArity rhs)
| (binder, rhs) <- pairs
]
rhs_fvs = body_fvs `minusFVBinders` args
rhs_escs = body_escs `minusVarSet` set_of_args
binder_info = lookupFVInfo scope_fv_info binder
- upd' | null args && isPAP body2 = SingleEntry
+ upd' | null args && isPAP body2 = ReEntrant
| otherwise = upd
in
returnLne (StgRhsClosure cc binder_info srt (getFVs rhs_fvs) upd'
any top-level PAPs.
\begin{code}
-isPAP (StgApp f args)
- = case getIdArity f of
- ArityExactly n -> n > n_args
- ArityAtLeast n -> n > n_args
- _ -> False
- where n_args = length args
-isPAP _ = False
+isPAP (StgApp f args) = idArity f > length args
+isPAP _ = False
\end{code}
\begin{code}
= mapAndUnzipLne var_atom atoms `thenLne` \ (args', fvs_lists) ->
returnLne (args', unionFVInfos fvs_lists)
where
- var_atom a@(StgConArg _) = returnLne (a, emptyFVInfo)
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}
%************************************************************************
decisions. Hence no black holes.
\begin{code}
+varsExpr (StgLit l) = returnLne (StgLit l, emptyFVInfo, emptyVarSet)
+
varsExpr (StgApp f args) = varsApp Nothing f args
-varsExpr (StgCon con args res_ty)
- = getVarsLiveInCont `thenLne` \ live_in_cont ->
- varsAtoms args `thenLne` \ (args', args_fvs) ->
- returnLne (StgCon con args' res_ty, args_fvs, getFVSet args_fvs)
+varsExpr (StgConApp con args)
+ = varsAtoms args `thenLne` \ (args', args_fvs) ->
+ returnLne (StgConApp con args', 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 (StgSCC label expr)
+varsExpr (StgSCC cc expr)
= varsExpr expr `thenLne` ( \ (expr2, fvs, escs) ->
- returnLne (StgSCC label expr2, fvs, escs) )
+ returnLne (StgSCC cc expr2, fvs, escs) )
\end{code}
Cases require a little more real work.
vars_alts alts `thenLne` \ (alts2, alts_fvs, alts_escs) ->
lookupLiveVarsForSet alts_fvs `thenLne` \ alts_lvs ->
let
+ -- 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 = live_in_cont `unionVarSet`
- (alts_lvs `minusVarSet` unitVarSet bndr)
+ 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.
live_in_whole_case = live_in_alts `unionVarSet` scrut_lvs
in
returnLne (
- StgCase scrut2 live_in_whole_case live_in_alts bndr srt alts2,
+ StgCase scrut2 live_in_whole_case live_in_alts bndr' srt alts2,
(scrut_fvs `unionFVInfo` alts_fvs)
`minusFVBinders` [bndr],
- (alts_escs `unionVarSet` (getFVSet scrut_fvs))
- `minusVarSet` unitVarSet 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)
= mapAndUnzip3Lne vars_alg_alt alts
returnLne (new_let, fvs, escs)
\end{code}
+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
+
+\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
let
n_args = length args
not_letrec_bound = not (isLetrecBound how_bound)
- f_arity = getIdArity f'
+ 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 -- Letrec bound; must have its arity
- = case f_arity of
- ArityExactly 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"
-
- | otherwise -> stgNormalOcc
+ | 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
- | otherwise = case f_arity of -- Letrec bound, so must have its arity
- ArityExactly arity
- | arity == n_args -> emptyVarSet
- -- Function doesn't escape
- | otherwise -> myself
- -- Inexact application; it does escape
+ 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:
-- 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
+ 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
-- this let(rec)
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
new_let,
free_in_whole_let,
let_escs,
- no_binder_escapes
+ checked_no_binder_escapes
))
where
set_of_binders = mkVarSet binders
StgRec pairs -> map fst pairs
mk_binding bind_lvs (binder,rhs)
- = (binder `setIdArity` ArityExactly (stgArity rhs),
+ = (binder `setIdArityInfo` ArityExactly (stgArity rhs),
LetrecBound False -- Not top level
live_vars
)
in
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}
%************************************************************************
rhsArity (StgRhsClosure _ _ _ _ _ args _) = length args
zapArity :: Id -> Id
-zapArity id = id `setIdArity` UnknownArity
+zapArity id = id `setIdArityInfo` UnknownArity
\end{code}
projects / ghc-hetmet.git / blobdiff