import Id ( emptyIdSet, mkIdSet, minusIdSet,
unionIdSets, unionManyIdSets, isEmptyIdSet,
unitIdSet, intersectIdSets,
+ addIdArity, getIdArity,
addOneToIdSet, SYN_IE(IdSet),
nullIdEnv, growIdEnvList, lookupIdEnv,
unitIdEnv, combineIdEnvs, delManyFromIdEnv,
rngIdEnv, SYN_IE(IdEnv),
- GenId{-instance Eq-}
+ GenId{-instance Eq-}, SYN_IE(Id)
)
+import IdInfo ( ArityInfo(..) )
import Maybes ( maybeToBool )
import Name ( isLocallyDefined )
+import TyCon ( SYN_IE(Arity) )
import PprStyle ( PprStyle(..) )
import PprType ( GenType{-instance Outputable-} )
import Util ( panic, pprPanic, assertPanic )
-
+import Pretty ( Doc )
+#if __GLASGOW_HASKELL__ >= 202
+import Outputable ( Outputable(..) )
+#endif
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
varsTopBinds [] = returnLne ([], emptyFVInfo)
varsTopBinds (bind:binds)
= extendVarEnv env_extension (
- varsTopBinds binds `thenLne` \ (binds', fv_binds) ->
- varsTopBind fv_binds bind `thenLne` \ (bind', fv_bind) ->
+ 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)
- emptyIdSet)
- | (b,rhs) <- pairs]
-
pairs = case bind of
StgNonRec binder rhs -> [(binder,rhs)]
StgRec pairs -> pairs
- binders = [b | (b,_) <- pairs]
+ binders' = [ binder `addIdArity` ArityExactly (rhsArity rhs)
+ | (binder, rhs) <- pairs
+ ]
+
+ env_extension = binders' `zip` repeat how_bound
+ how_bound = LetrecBound
+ True {- top level -}
+ emptyIdSet
-varsTopBind :: FreeVarsInfo -- Info about the body
+
+varsTopBind :: [Id] -- New binders (with correct arity)
+ -> FreeVarsInfo -- Info about the body
-> StgBinding
-> LneM (StgBinding, FreeVarsInfo)
-varsTopBind body_fvs (StgNonRec binder rhs)
+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) ->
+varsTopBind binders' body_fvs (StgRec pairs)
+ = fixLne (\ ~(_, rec_rhs_fvs) ->
let
scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
in
let
fvs = unionFVInfos fvss
in
- returnLne (StgRec (binders `zip` rhss2), fvs)
+ returnLne (StgRec (binders' `zip` rhss2), fvs)
)
\end{code}
-> 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 ] (
+ = extendVarEnv [ (zapArity a, LambdaBound) | a <- args ] (
do_body args body `thenLne` \ (body2, body_fvs, body_escs) ->
let
set_of_args = mkIdSet args
do_body _ other_body = varsExpr other_body
\end{code}
+
\begin{code}
varsAtoms :: [StgArg]
- -> LneM FreeVarsInfo
+ -> 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@(StgLitArg _) = returnLne emptyFVInfo
- var_atom a@(StgConArg _) = returnLne emptyFVInfo
+ var_atom a@(StgLitArg _) = returnLne (a, emptyFVInfo)
+ var_atom a@(StgConArg _) = returnLne (a, emptyFVInfo)
var_atom a@(StgVarArg v)
- = lookupVarEnv v `thenLne` \ how_bound ->
- returnLne (singletonFVInfo v how_bound stgArgOcc)
+ = lookupVarEnv v `thenLne` \ (v', how_bound) ->
+ returnLne (StgVarArg v', singletonFVInfo v' how_bound stgArgOcc)
\end{code}
%************************************************************************
varsExpr (StgCon con args _)
= getVarsLiveInCont `thenLne` \ live_in_cont ->
- varsAtoms args `thenLne` \ args_fvs ->
+ varsAtoms args `thenLne` \ (args', args_fvs) ->
- returnLne (StgCon con args live_in_cont, args_fvs, getFVSet args_fvs)
+ returnLne (StgCon con args' live_in_cont, args_fvs, getFVSet args_fvs)
varsExpr (StgPrim op args _)
= getVarsLiveInCont `thenLne` \ live_in_cont ->
- varsAtoms args `thenLne` \ args_fvs ->
-
- returnLne (StgPrim op args live_in_cont, args_fvs, getFVSet args_fvs)
+ varsAtoms args `thenLne` \ (args', args_fvs) ->
+ returnLne (StgPrim op args' live_in_cont, args_fvs, getFVSet args_fvs)
varsExpr (StgSCC ty label expr)
= varsExpr expr `thenLne` ( \ (expr2, fvs, escs) ->
)
where
vars_alg_alt (con, binders, worthless_use_mask, rhs)
- = extendVarEnv [(b, CaseBound) | b <- binders] (
+ = extendVarEnv [(zapArity b, CaseBound) | b <- binders] (
varsExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
let
good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders ]
= returnLne (StgNoDefault, emptyFVInfo, emptyIdSet)
vars_deflt (StgBindDefault binder _ rhs)
- = extendVarEnv [(binder, CaseBound)] (
+ = extendVarEnv [(zapArity binder, CaseBound)] (
varsExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
let
used_in_rhs = binder `elementOfFVInfo` rhs_fvs
varsApp maybe_thunk_body f args
= getVarsLiveInCont `thenLne` \ live_in_cont ->
- varsAtoms args `thenLne` \ args_fvs ->
+ varsAtoms args `thenLne` \ (args', args_fvs) ->
- lookupVarEnv f `thenLne` \ how_bound ->
+ lookupVarEnv f `thenLne` \ (f', 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 = length args
+ not_letrec_bound = not (isLetrecBound how_bound)
+ f_arity = getIdArity f'
+ 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.
other -> panic "varsApp"
| otherwise -> stgNormalOcc
- -- record only that it occurs free
-
- other -> NoStgBinderInfo
- -- uninteresting variable
+ -- Record only that it occurs free
- myself = unitIdSet f
+ myself = unitIdSet f'
- fun_escs = case how_bound of
-
- LetrecBound _ arity lvs ->
- if arity == n_args then
- emptyIdSet -- Function doesn't escape
- else
- myself -- Inexact application; it does escape
-
- other -> emptyIdSet -- Only letrec-bound escapees
- -- are interesting
+ fun_escs | not_letrec_bound = emptyIdSet -- Only letrec-bound escapees are interesting
+ | otherwise = case f_arity of -- Letrec bound, so must have its arity
+ ArityExactly arity
+ | arity == n_args -> emptyIdSet
+ -- Function doesn't escape
+ | otherwise -> myself
+ -- Inexact application; it does escape
-- At the moment of the call:
live_at_call
= live_in_cont `unionIdSets` case how_bound of
- LetrecBound _ _ lvs -> lvs `minusIdSet` myself
- other -> emptyIdSet
+ LetrecBound _ lvs -> lvs `minusIdSet` myself
+ other -> emptyIdSet
in
returnLne (
- StgApp (StgVarArg f) args live_at_call,
+ StgApp (StgVarArg f') args' live_at_call,
fun_fvs `unionFVInfo` args_fvs,
fun_escs `unionIdSets` (getFVSet args_fvs)
-- All the free vars of the args are disqualified
no_binder_escapes
))
where
- binders = case bind of
- StgNonRec binder rhs -> [binder]
- StgRec pairs -> map fst pairs
- set_of_binders = mkIdSet binders
+ set_of_binders = mkIdSet binders
+ binders = case bind of
+ StgNonRec binder rhs -> [binder]
+ StgRec pairs -> map fst pairs
mk_binding bind_lvs (binder,rhs)
- = (binder,
+ = (binder `addIdArity` ArityExactly (stgArity rhs),
LetrecBound False -- Not top level
- (stgArity rhs)
live_vars
)
where
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 (
fixLne (\ ~(_, rec_rhs_fvs, _, _) ->
fvs = unionFVInfos fvss
escs = unionManyIdSets escss
in
- returnLne (StgRec (binders `zip` rhss2), fvs, escs, env_ext)
+ returnLne (StgRec (binders' `zip` rhss2), fvs, escs, env_ext)
))
\end{code}
\begin{code}
type LneM a = Bool -- True <=> do let-no-escapes
- -> IdEnv HowBound
+ -> IdEnv (Id, HowBound) -- Use the Id at all occurrences; it has correct
+ -- arity information inside it.
-> StgLiveVars -- vars live in continuation
-> a
| LambdaBound
| LetrecBound
Bool -- True <=> bound at top level
- Arity -- Arity
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
= 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
+extendVarEnv ids_w_howbound expr sw env lvs_cont
+ = expr sw (growIdEnvList env [(id, pair) | pair@(id,_) <- ids_w_howbound]) lvs_cont
-lookupVarEnv :: Id -> LneM HowBound
+
+lookupVarEnv :: Id -> LneM (Id, HowBound)
lookupVarEnv v sw env lvs_cont
= returnLne (
case (lookupIdEnv 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
do_one v
= if isLocallyDefined v then
case (lookupIdEnv env v) of
- Just (LetrecBound _ _ lvs) -> addOneToIdSet lvs v
- Just _ -> unitIdSet v
+ Just (_, LetrecBound _ lvs) -> addOneToIdSet lvs v
+ Just _ -> unitIdSet v
Nothing -> pprPanic "lookupVarEnv/do_one:" (ppr PprShowAll v)
else
emptyIdSet
emptyFVInfo = nullIdEnv
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 = nullIdEnv
+singletonFVInfo id (LetrecBound top_level _) info = unitIdEnv id (id, top_level, info)
+singletonFVInfo id other info = unitIdEnv id (id, False, info)
unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
unionFVInfo fv1 fv2 = combineIdEnvs plusFVInfo fv1 fv2
rhsArity :: StgRhs -> Arity
rhsArity (StgRhsCon _ _ _) = 0
rhsArity (StgRhsClosure _ _ _ _ args _) = length args
+
+zapArity :: Id -> Id
+zapArity id = id `addIdArity` UnknownArity
\end{code}
projects / ghc-hetmet.git / commitdiff