import StgSyn
-import Id ( setIdArity, getIdArity, Id )
+import Id ( isLocalId, setIdArityInfo, idArity, setIdOccInfo, Id )
import VarSet
import VarEnv
import Var
-import IdInfo ( ArityInfo(..), InlinePragInfo(..),
- setInlinePragInfo )
-import Maybes ( maybeToBool )
-import Name ( isLocallyDefined )
+import IdInfo ( ArityInfo(..), OccInfo(..) )
+import PrimOp ( PrimOp(..), ccallMayGC )
+import TysWiredIn ( isForeignObjTy )
+import Maybes ( maybeToBool, orElse )
+import Name ( 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
]
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 cc expr)
= varsExpr expr `thenLne` ( \ (expr2, fvs, escs) ->
let
-- determine whether the default binder is dead or not
bndr'= if (bndr `elementOfFVInfo` alts_fvs)
- then modifyIdInfo (`setInlinePragInfo` NoInlinePragInfo) bndr
- else modifyIdInfo (`setInlinePragInfo` IAmDead) bndr
+ 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.
)
)
where
- vars_alts (StgAlgAlts ty alts deflt)
+ vars_alts (StgAlgAlts tycon alts deflt)
= mapAndUnzip3Lne vars_alg_alt alts
`thenLne` \ (alts2, alts_fvs_list, alts_escs_list) ->
let
in
vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) ->
returnLne (
- StgAlgAlts ty alts2 deflt2,
+ StgAlgAlts tycon alts2 deflt2,
alts_fvs `unionFVInfo` deflt_fvs,
alts_escs `unionVarSet` deflt_escs
)
-- any of these binders
))
- vars_alts (StgPrimAlts ty alts deflt)
+ vars_alts (StgPrimAlts tycon alts deflt)
= mapAndUnzip3Lne vars_prim_alt alts
`thenLne` \ (alts2, alts_fvs_list, alts_escs_list) ->
let
in
vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) ->
returnLne (
- StgPrimAlts ty alts2 deflt2,
+ StgPrimAlts tycon alts2 deflt2,
alts_fvs `unionFVInfo` deflt_fvs,
alts_escs `unionVarSet` deflt_escs
)
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}
%************************************************************************
sw env lvs_cont
where
do_one v
- = if isLocallyDefined v then
+ = if isLocalId v then
case (lookupVarEnv env v) of
Just (_, LetrecBound _ lvs) -> extendVarSet lvs v
- Just _ -> unitVarSet v
+ Just _ -> unitVarSet v
Nothing -> pprPanic "lookupVarEnv/do_one:" (ppr v)
else
emptyVarSet
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