%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
+\section[CoreToStg]{Converts Core to STG Syntax}
+
+And, as we have the info in hand, we may convert some lets to
+let-no-escapes.
+
+\begin{code}
+module CoreToStg ( coreToStg, coreExprToStg ) where
+
+#include "HsVersions.h"
+
+import CoreSyn
+import CoreUtils ( rhsIsStatic, manifestArity, exprType )
+import StgSyn
+
+import Type
+import TyCon ( isAlgTyCon )
+import Id
+import Var ( Var, globalIdDetails, idType )
+import TyCon ( isUnboxedTupleTyCon, isPrimTyCon, isFunTyCon, isHiBootTyCon )
+#ifdef ILX
+import MkId ( unsafeCoerceId )
+#endif
+import IdInfo
+import DataCon
+import CostCentre ( noCCS )
+import VarSet
+import VarEnv
+import Maybes ( maybeToBool )
+import Name ( getOccName, isExternalName, nameOccName )
+import OccName ( occNameUserString, occNameFS )
+import BasicTypes ( Arity )
+import CmdLineOpts ( DynFlags, opt_RuntimeTypes )
+import Outputable
+
+infixr 9 `thenLne`
+\end{code}
+
%************************************************************************
%* *
-\section[CoreToStg]{Converting core syntax to STG syntax}
+\subsection[live-vs-free-doc]{Documentation}
%* *
%************************************************************************
-Convert a @CoreSyntax@ program to a @StgSyntax@ program.
+(There is other relevant documentation in codeGen/CgLetNoEscape.)
+
+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
+semantic one. A variable is live at a particular execution point if
+it can be referred to {\em directly} again. In particular, a dead
+variable's stack slot (if it has one):
+\begin{enumerate}
+\item
+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
+ ...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
+ alts[...q...]
+\end{verbatim}
+(ie @alts@ mention @q@), then @q@ is live even after the `in'; because
+we'll return later to the @alts@ and need it.
+
+Let-no-escapes make this a bit more interesting:
+\begin{verbatim}
+ let-no-escape v = [q] \ [x] -> e
+ in
+ ...v...
+\end{verbatim}
+Here, @q@ is still live at the `in', because @v@ is represented not by
+a closure but by the current stack state. In other words, if @v@ is
+live then so is @q@. Furthermore, if @e@ mentions an enclosing
+let-no-escaped variable, then {\em its} free variables are also live
+if @v@ is.
-\begin{code}
-#include "HsVersions.h"
+%************************************************************************
+%* *
+\subsection[caf-info]{Collecting live CAF info}
+%* *
+%************************************************************************
-module CoreToStg ( topCoreBindsToStg ) where
-
-IMP_Ubiq(){-uitous-}
-IMPORT_1_3(Ratio(numerator,denominator))
-
-import CoreSyn -- input
-import StgSyn -- output
-
-import Bag ( emptyBag, unitBag, unionBags, unionManyBags, bagToList )
-import CoreUtils ( coreExprType )
-import CostCentre ( noCostCentre )
-import Id ( mkSysLocal, idType, isBottomingId, addIdArity,
- externallyVisibleId,
- nullIdEnv, addOneToIdEnv, lookupIdEnv, growIdEnvList,
- SYN_IE(IdEnv), GenId{-instance NamedThing-}
- )
-import IdInfo ( ArityInfo, exactArity )
-import Literal ( mkMachInt, Literal(..) )
-import PrelVals ( unpackCStringId, unpackCString2Id,
- integerZeroId, integerPlusOneId,
- integerPlusTwoId, integerMinusOneId
- )
-import PrimOp ( PrimOp(..) )
-import SpecUtils ( mkSpecialisedCon )
-import SrcLoc ( noSrcLoc )
-import TyCon ( TyCon{-instance Uniquable-} )
-import Type ( maybeAppDataTyCon, getAppDataTyConExpandingDicts )
-import TysWiredIn ( stringTy )
-import Unique ( integerTyConKey, ratioTyConKey, Unique{-instance Eq-} )
-import UniqSupply -- all of it, really
-import Util ( zipLazy, panic, assertPanic{-, pprTrace ToDo:rm-} )
---import Pretty--ToDo:rm
---import PprStyle--ToDo:rm
---import PprType --ToDo:rm
---import Outputable--ToDo:rm
---import PprEnv--ToDo:rm
-
-isLeakFreeType x y = False -- safe option; ToDo
-\end{code}
+In this pass we also collect information on which CAFs are live for
+constructing SRTs (see SRT.lhs).
+
+A top-level Id has CafInfo, which is
+ - MayHaveCafRefs, if it may refer indirectly to
+ one or more CAFs, or
+ - NoCafRefs if it definitely doesn't
- *************** OVERVIEW *********************
+The CafInfo has already been calculated during the CoreTidy pass.
+During CoreToStg, we then pin onto each binding and case expression, a
+list of Ids which represents the "live" CAFs at that point. The meaning
+of "live" here is the same as for live variables, see above (which is
+why it's convenient to collect CAF information here rather than elsewhere).
-The business of this pass is to convert Core to Stg. On the way:
+The later SRT pass takes these lists of Ids and uses them to construct
+the actual nested SRTs, and replaces the lists of Ids with (offset,length)
+pairs.
-* We discard type lambdas and applications. In so doing we discard
- "trivial" bindings such as
- x = y t1 t2
- where t1, t2 are types
-* We pin correct arities on each let(rec)-bound binder, and propagate them
- to their uses. This is used
- a) when emitting arity info into interface files
- b) in the code generator, when deciding if a right-hand side
- is a saturated application so we can generate a VAP closure.
- (b) is rather untidy, but the easiest compromise was to propagate arities here.
+Interaction of let-no-escape with SRTs [Sept 01]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
-* We do *not* pin on the correct free/live var info; that's done later.
- Instead we use bOGUS_LVS and _FVS as a placeholder.
+ let-no-escape x = ...caf1...caf2...
+ in
+ ...x...x...x...
-[Quite a bit of stuff that used to be here has moved
- to tidyCorePgm (SimplCore.lhs) SLPJ Nov 96]
+where caf1,caf2 are CAFs. Since x doesn't have a closure, we
+build SRTs just as if x's defn was inlined at each call site, and
+that means that x's CAF refs get duplicated in the overall SRT.
+
+This is unlike ordinary lets, in which the CAF refs are not duplicated.
+
+We could fix this loss of (static) sharing by making a sort of pseudo-closure
+for x, solely to put in the SRTs lower down.
%************************************************************************
%* *
-\subsection[coreToStg-programs]{Converting a core program and core bindings}
+\subsection[binds-StgVarInfo]{Setting variable info: top-level, binds, RHSs}
%* *
%************************************************************************
-Because we're going to come across ``boring'' bindings like
-\tr{let x = /\ tyvars -> y in ...}, we want to keep a small
-environment, so we can just replace all occurrences of \tr{x}
-with \tr{y}.
-
\begin{code}
-type StgEnv = IdEnv StgArg
-\end{code}
+coreToStg :: DynFlags -> [CoreBind] -> IO [StgBinding]
+coreToStg dflags pgm
+ = return pgm'
+ where (_, _, pgm') = coreTopBindsToStg emptyVarEnv pgm
-No free/live variable information is pinned on in this pass; it's added
-later. For this pass
-we use @bOGUS_LVs@ and @bOGUS_FVs@ as placeholders.
+coreExprToStg :: CoreExpr -> StgExpr
+coreExprToStg expr
+ = new_expr where (new_expr,_,_) = initLne emptyVarEnv (coreToStgExpr expr)
-\begin{code}
-bOGUS_LVs :: StgLiveVars
-bOGUS_LVs = panic "bOGUS_LVs" -- emptyUniqSet (used when pprTracing)
-bOGUS_FVs :: [Id]
-bOGUS_FVs = panic "bOGUS_FVs" -- [] (ditto)
+coreTopBindsToStg
+ :: IdEnv HowBound -- environment for the bindings
+ -> [CoreBind]
+ -> (IdEnv HowBound, FreeVarsInfo, [StgBinding])
+
+coreTopBindsToStg env [] = (env, emptyFVInfo, [])
+coreTopBindsToStg env (b:bs)
+ = (env2, fvs2, b':bs')
+ where
+ -- env accumulates down the list of binds, fvs accumulates upwards
+ (env1, fvs2, b' ) = coreTopBindToStg env fvs1 b
+ (env2, fvs1, bs') = coreTopBindsToStg env1 bs
+
+
+coreTopBindToStg
+ :: IdEnv HowBound
+ -> FreeVarsInfo -- Info about the body
+ -> CoreBind
+ -> (IdEnv HowBound, FreeVarsInfo, StgBinding)
+
+coreTopBindToStg env body_fvs (NonRec id rhs)
+ = let
+ env' = extendVarEnv env id how_bound
+ how_bound = LetBound TopLet (manifestArity rhs)
+
+ (stg_rhs, fvs') =
+ initLne env (
+ coreToTopStgRhs body_fvs (id,rhs) `thenLne` \ (stg_rhs, fvs') ->
+ returnLne (stg_rhs, fvs')
+ )
+
+ bind = StgNonRec id stg_rhs
+ in
+ ASSERT2(manifestArity rhs == stgRhsArity stg_rhs, ppr id)
+ ASSERT2(consistentCafInfo id bind, ppr id)
+-- WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info)
+ (env', fvs' `unionFVInfo` body_fvs, bind)
+
+coreTopBindToStg env body_fvs (Rec pairs)
+ = let
+ (binders, rhss) = unzip pairs
+
+ extra_env' = [ (b, LetBound TopLet (manifestArity rhs))
+ | (b, rhs) <- pairs ]
+ env' = extendVarEnvList env extra_env'
+
+ (stg_rhss, fvs')
+ = initLne env' (
+ mapAndUnzipLne (coreToTopStgRhs body_fvs) pairs
+ `thenLne` \ (stg_rhss, fvss') ->
+ let fvs' = unionFVInfos fvss' in
+ returnLne (stg_rhss, fvs')
+ )
+
+ bind = StgRec (zip binders stg_rhss)
+ in
+ ASSERT2(and [manifestArity rhs == stgRhsArity stg_rhs | (rhs,stg_rhs) <- rhss `zip` stg_rhss], ppr binders)
+ ASSERT2(consistentCafInfo (head binders) bind, ppr binders)
+ (env', fvs' `unionFVInfo` body_fvs, bind)
+
+#ifdef DEBUG
+-- Assertion helper: this checks that the CafInfo on the Id matches
+-- what CoreToStg has figured out about the binding's SRT. The
+-- CafInfo will be exact in all cases except when CorePrep has
+-- floated out a binding, in which case it will be approximate.
+consistentCafInfo id bind
+ | occNameFS (nameOccName (idName id)) == FSLIT("sat")
+ = safe
+ | otherwise
+ = WARN (not exact, ppr id) safe
+ where
+ safe = id_marked_caffy || not binding_is_caffy
+ exact = id_marked_caffy == binding_is_caffy
+ id_marked_caffy = mayHaveCafRefs (idCafInfo id)
+ binding_is_caffy = stgBindHasCafRefs bind
+#endif
\end{code}
\begin{code}
-topCoreBindsToStg :: UniqSupply -- name supply
- -> [CoreBinding] -- input
- -> [StgBinding] -- output
-
-topCoreBindsToStg us core_binds
- = case (initUs us (coreBindsToStg nullIdEnv core_binds)) of
- (_, stuff) -> stuff
+coreToTopStgRhs
+ :: FreeVarsInfo -- Free var info for the scope of the binding
+ -> (Id,CoreExpr)
+ -> LneM (StgRhs, FreeVarsInfo)
+
+coreToTopStgRhs scope_fv_info (bndr, rhs)
+ = coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, _) ->
+ freeVarsToLiveVars rhs_fvs `thenLne` \ lv_info ->
+ returnLne (mkTopStgRhs is_static rhs_fvs (mkSRT lv_info) bndr_info new_rhs, rhs_fvs)
where
- coreBindsToStg :: StgEnv -> [CoreBinding] -> UniqSM [StgBinding]
+ bndr_info = lookupFVInfo scope_fv_info bndr
+ is_static = rhsIsStatic rhs
+
+mkTopStgRhs :: Bool -> FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr
+ -> StgRhs
+
+mkTopStgRhs is_static rhs_fvs srt binder_info (StgLam _ bndrs body)
+ = ASSERT( is_static )
+ StgRhsClosure noCCS binder_info
+ (getFVs rhs_fvs)
+ ReEntrant
+ srt
+ bndrs body
+
+mkTopStgRhs is_static rhs_fvs srt binder_info (StgConApp con args)
+ | is_static -- StgConApps can be updatable (see isCrossDllConApp)
+ = StgRhsCon noCCS con args
+
+mkTopStgRhs is_static rhs_fvs srt binder_info rhs
+ = ASSERT2( not is_static, ppr rhs )
+ StgRhsClosure noCCS binder_info
+ (getFVs rhs_fvs)
+ Updatable
+ srt
+ [] rhs
+\end{code}
+
+
+-- ---------------------------------------------------------------------------
+-- Expressions
+-- ---------------------------------------------------------------------------
- coreBindsToStg env [] = returnUs []
- coreBindsToStg env (b:bs)
- = coreBindToStg env b `thenUs` \ (new_b, new_env) ->
- coreBindsToStg new_env bs `thenUs` \ new_bs ->
- returnUs (new_b ++ new_bs)
+\begin{code}
+coreToStgExpr
+ :: CoreExpr
+ -> LneM (StgExpr, -- Decorated STG 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
+ -- let-no-escaped ones.
\end{code}
-%************************************************************************
-%* *
-\subsection[coreToStg-binds]{Converting bindings}
-%* *
-%************************************************************************
+The second and third components can be derived in a simple bottom up pass, not
+dependent on any decisions about which variables will be let-no-escaped or
+not. The first component, that is, the decorated expression, may then depend
+on these components, but it in turn is not scrutinised as the basis for any
+decisions. Hence no black holes.
\begin{code}
-coreBindToStg :: StgEnv
- -> CoreBinding
- -> UniqSM ([StgBinding], -- Empty or singleton
- StgEnv) -- Floats
+coreToStgExpr (Lit l) = returnLne (StgLit l, emptyFVInfo, emptyVarSet)
+coreToStgExpr (Var v) = coreToStgApp Nothing v []
-coreBindToStg env (NonRec binder rhs)
- = coreRhsToStg env rhs `thenUs` \ stg_rhs ->
- let
- -- Binds to return if RHS is trivial
- binder_w_arity = binder `addIdArity` (rhsArity stg_rhs)
- triv_binds | externallyVisibleId binder = [StgNonRec binder_w_arity stg_rhs] -- Retain it
- | otherwise = [] -- Discard it
+coreToStgExpr expr@(App _ _)
+ = coreToStgApp Nothing f args
+ where
+ (f, args) = myCollectArgs expr
+
+coreToStgExpr expr@(Lam _ _)
+ = let
+ (args, body) = myCollectBinders expr
+ args' = filterStgBinders args
in
- case stg_rhs of
- StgRhsClosure cc bi fvs upd [] (StgApp atom [] lvs) ->
- -- Trivial RHS, so augment envt, and ditch the binding
- returnUs (triv_binds, new_env)
- where
- new_env = addOneToIdEnv env binder atom
-
- StgRhsCon cc con_id [] ->
- -- Trivial RHS, so augment envt, and ditch the binding
- returnUs (triv_binds, new_env)
- where
- new_env = addOneToIdEnv env binder (StgConArg con_id)
-
- other -> -- Non-trivial RHS, so don't augment envt
- returnUs ([StgNonRec binder_w_arity stg_rhs], new_env)
- where
- new_env = addOneToIdEnv env binder (StgVarArg binder_w_arity)
- -- new_env propagates the arity
-
-coreBindToStg env (Rec pairs)
- = -- NB: *** WE DO NOT CHECK FOR TRIV_BINDS in REC BIND ****
- -- (possibly ToDo)
+ extendVarEnvLne [ (a, LambdaBound) | a <- args' ] $
+ coreToStgExpr body `thenLne` \ (body, body_fvs, body_escs) ->
let
- (binders, rhss) = unzip pairs
+ fvs = args' `minusFVBinders` body_fvs
+ escs = body_escs `delVarSetList` args'
+ result_expr | null args' = body
+ | otherwise = StgLam (exprType expr) args' body
in
- mapUs (coreRhsToStg env) rhss `thenUs` \ stg_rhss ->
- let
- binders_w_arities = [ b `addIdArity` rhsArity rhs
- | (b,rhs) <- binders `zip` stg_rhss]
+ returnLne (result_expr, fvs, escs)
+
+coreToStgExpr (Note (SCC cc) expr)
+ = coreToStgExpr expr `thenLne` ( \ (expr2, fvs, escs) ->
+ returnLne (StgSCC cc expr2, fvs, escs) )
+
+#ifdef ILX
+-- For ILX, convert (__coerce__ to_ty from_ty e)
+-- into (coerce to_ty from_ty e)
+-- where coerce is real function
+coreToStgExpr (Note (Coerce to_ty from_ty) expr)
+ = coreToStgExpr (mkApps (Var unsafeCoerceId)
+ [Type from_ty, Type to_ty, expr])
+#endif
+
+coreToStgExpr (Note other_note expr)
+ = coreToStgExpr expr
+
+-- Cases require a little more real work.
+
+coreToStgExpr (Case scrut bndr alts)
+ = extendVarEnvLne [(bndr, LambdaBound)] (
+ mapAndUnzip3Lne vars_alt alts `thenLne` \ (alts2, fvs_s, escs_s) ->
+ returnLne ( alts2,
+ unionFVInfos fvs_s,
+ unionVarSets escs_s )
+ ) `thenLne` \ (alts2, alts_fvs, alts_escs) ->
+ let
+ -- Determine whether the default binder is dead or not
+ -- This helps the code generator to avoid generating an assignment
+ -- for the case binder (is extremely rare cases) ToDo: remove.
+ bndr' | bndr `elementOfFVInfo` alts_fvs = bndr
+ | otherwise = bndr `setIdOccInfo` IAmDead
+
+ -- 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.
+ alts_fvs_wo_bndr = bndr `minusFVBinder` alts_fvs
+ alts_escs_wo_bndr = alts_escs `delVarSet` bndr
in
- returnUs ([StgRec (binders_w_arities `zip` stg_rhss)], env)
-rhsArity (StgRhsClosure _ _ _ _ args _) = exactArity (length args)
-rhsArity (StgRhsCon _ _ _) = exactArity 0
+ freeVarsToLiveVars alts_fvs_wo_bndr `thenLne` \ alts_lv_info ->
+
+ -- We tell the scrutinee that everything
+ -- live in the alts is live in it, too.
+ setVarsLiveInCont alts_lv_info (
+ coreToStgExpr scrut `thenLne` \ (scrut2, scrut_fvs, scrut_escs) ->
+ freeVarsToLiveVars scrut_fvs `thenLne` \ scrut_lv_info ->
+ returnLne (scrut2, scrut_fvs, scrut_escs, scrut_lv_info)
+ )
+ `thenLne` \ (scrut2, scrut_fvs, scrut_escs, scrut_lv_info) ->
+
+ returnLne (
+ StgCase scrut2 (getLiveVars scrut_lv_info)
+ (getLiveVars alts_lv_info)
+ bndr'
+ (mkSRT alts_lv_info)
+ (mkStgAltType (idType bndr))
+ alts2,
+ scrut_fvs `unionFVInfo` alts_fvs_wo_bndr,
+ alts_escs_wo_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_alt (con, binders, rhs)
+ = let -- Remove type variables
+ binders' = filterStgBinders binders
+ in
+ extendVarEnvLne [(b, LambdaBound) | b <- binders'] $
+ coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
+ let
+ -- Records whether each param is used in the RHS
+ good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders' ]
+ in
+ returnLne ( (con, binders', good_use_mask, rhs2),
+ binders' `minusFVBinders` rhs_fvs,
+ rhs_escs `delVarSetList` binders' )
+ -- ToDo: remove the delVarSet;
+ -- since escs won't include any of these binders
\end{code}
+Lets not only take quite a bit of work, but this is where we convert
+then to let-no-escapes, if we wish.
-%************************************************************************
-%* *
-\subsection[coreToStg-rhss]{Converting right hand sides}
-%* *
-%************************************************************************
+(Meanwhile, we don't expect to see let-no-escapes...)
+\begin{code}
+coreToStgExpr (Let bind body)
+ = fixLne (\ ~(_, _, _, no_binder_escapes) ->
+ coreToStgLet no_binder_escapes bind body
+ ) `thenLne` \ (new_let, fvs, escs, _) ->
+
+ returnLne (new_let, fvs, escs)
+\end{code}
\begin{code}
-coreRhsToStg :: StgEnv -> CoreExpr -> UniqSM StgRhs
-
-coreRhsToStg env core_rhs
- = coreExprToStg env core_rhs `thenUs` \ stg_expr ->
-
- let stg_rhs = case stg_expr of
- StgLet (StgNonRec var1 rhs) (StgApp (StgVarArg var2) [] _)
- | var1 == var2 -> rhs
- -- This curious stuff is to unravel what a lambda turns into
- -- We have to do it this way, rather than spot a lambda in the
- -- incoming rhs. Why? Because trivial bindings might conceal
- -- what the rhs is actually like.
-
- StgCon con args _ -> StgRhsCon noCostCentre con args
-
- other -> StgRhsClosure noCostCentre -- No cost centre (ToDo?)
- stgArgOcc -- safe
- bOGUS_FVs
- Updatable -- Be pessimistic
- []
- stg_expr
- in
- returnUs stg_rhs
+mkStgAltType scrut_ty
+ = case splitTyConApp_maybe (repType scrut_ty) of
+ Just (tc,_) | isUnboxedTupleTyCon tc -> UbxTupAlt tc
+ | isPrimTyCon tc -> PrimAlt tc
+ | isHiBootTyCon tc -> PolyAlt -- Algebraic, but no constructors visible
+ | isAlgTyCon tc -> AlgAlt tc
+ | isFunTyCon tc -> PolyAlt
+ | otherwise -> pprPanic "mkStgAlts" (ppr tc)
+ Nothing -> PolyAlt
\end{code}
-%************************************************************************
-%* *
-\subsection[coreToStg-atoms{Converting atoms}
-%* *
-%************************************************************************
+-- ---------------------------------------------------------------------------
+-- Applications
+-- ---------------------------------------------------------------------------
\begin{code}
-coreArgsToStg :: StgEnv -> [CoreArg] -> ([Type], [StgArg])
-
-coreArgsToStg env [] = ([], [])
-coreArgsToStg env (a:as)
- = case a of
- TyArg t -> (t:trest, vrest)
- UsageArg u -> (trest, vrest)
- VarArg v -> (trest, stgLookup env v : vrest)
- LitArg l -> (trest, StgLitArg l : vrest)
- where
- (trest,vrest) = coreArgsToStg env as
-\end{code}
+coreToStgApp
+ :: Maybe UpdateFlag -- Just upd <=> this application is
+ -- the rhs of a thunk binding
+ -- x = [...] \upd [] -> the_app
+ -- with specified update flag
+ -> Id -- Function
+ -> [CoreArg] -- Arguments
+ -> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
+
+coreToStgApp maybe_thunk_body f args
+ = coreToStgArgs args `thenLne` \ (args', args_fvs) ->
+ lookupVarLne f `thenLne` \ how_bound ->
+ let
+ n_val_args = valArgCount args
+ not_letrec_bound = not (isLetBound how_bound)
+ fun_fvs
+ = let fvs = singletonFVInfo f how_bound fun_occ in
+ -- e.g. (f :: a -> int) (x :: a)
+ -- Here the free variables are "f", "x" AND the type variable "a"
+ -- coreToStgArgs will deal with the arguments recursively
+ if opt_RuntimeTypes then
+ fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType (idType f))
+ else fvs
+
+ -- 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.
+ -- NB: f_arity is only consulted for LetBound things
+ f_arity = stgArity f how_bound
+ saturated = f_arity <= n_val_args
+
+ fun_occ
+ | not_letrec_bound = noBinderInfo -- Uninteresting variable
+ | f_arity > 0 && saturated = 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_val_args = emptyVarSet -- A function *or thunk* with an exactly
+ -- saturated call doesn't escape
+ -- (let-no-escape applies to 'thunks' too)
+
+ | otherwise = unitVarSet f -- Inexact application; it does escape
+
+ -- At the moment of the call:
+
+ -- either the function is *not* let-no-escaped, in which case
+ -- nothing is live except live_in_cont
+ -- or the function *is* let-no-escaped in which case the
+ -- variables it uses are live, but still the function
+ -- itself is not. PS. In this case, the function's
+ -- live vars should already include those of the
+ -- continuation, but it does no harm to just union the
+ -- two regardless.
+
+ res_ty = exprType (mkApps (Var f) args)
+ app = case globalIdDetails f of
+ DataConWorkId dc | saturated -> StgConApp dc args'
+ PrimOpId op -> ASSERT( saturated )
+ StgOpApp (StgPrimOp op) args' res_ty
+ FCallId call -> ASSERT( saturated )
+ StgOpApp (StgFCallOp call (idUnique f)) args' res_ty
+ _other -> StgApp f args'
-%************************************************************************
-%* *
-\subsection[coreToStg-exprs]{Converting core expressions}
-%* *
-%************************************************************************
+ in
+ returnLne (
+ app,
+ fun_fvs `unionFVInfo` args_fvs,
+ fun_escs `unionVarSet` (getFVSet args_fvs)
+ -- All the free vars of the args are disqualified
+ -- from being let-no-escaped.
+ )
-\begin{code}
-coreExprToStg :: StgEnv -> CoreExpr -> UniqSM StgExpr
-coreExprToStg env (Lit lit)
- = returnUs (StgApp (StgLitArg lit) [] bOGUS_LVs)
-coreExprToStg env (Var var)
- = returnUs (mk_app (stgLookup env var) [])
+-- ---------------------------------------------------------------------------
+-- Argument lists
+-- This is the guy that turns applications into A-normal form
+-- ---------------------------------------------------------------------------
-coreExprToStg env (Con con args)
- = let
- (types, stg_atoms) = coreArgsToStg env args
- spec_con = mkSpecialisedCon con types
- in
- returnUs (StgCon spec_con stg_atoms bOGUS_LVs)
+coreToStgArgs :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo)
+coreToStgArgs []
+ = returnLne ([], emptyFVInfo)
-coreExprToStg env (Prim op args)
- = let
- (types, stg_atoms) = coreArgsToStg env args
+coreToStgArgs (Type ty : args) -- Type argument
+ = coreToStgArgs args `thenLne` \ (args', fvs) ->
+ if opt_RuntimeTypes then
+ returnLne (StgTypeArg ty : args', fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType ty))
+ else
+ returnLne (args', fvs)
+
+coreToStgArgs (arg : args) -- Non-type argument
+ = coreToStgArgs args `thenLne` \ (stg_args, args_fvs) ->
+ coreToStgExpr arg `thenLne` \ (arg', arg_fvs, escs) ->
+ let
+ fvs = args_fvs `unionFVInfo` arg_fvs
+ stg_arg = case arg' of
+ StgApp v [] -> StgVarArg v
+ StgConApp con [] -> StgVarArg (dataConWorkId con)
+ StgLit lit -> StgLitArg lit
+ _ -> pprPanic "coreToStgArgs" (ppr arg)
in
- returnUs (StgPrim op stg_atoms bOGUS_LVs)
-\end{code}
+ returnLne (stg_arg : stg_args, fvs)
-%************************************************************************
-%* *
-\subsubsection[coreToStg-lambdas]{Lambda abstractions}
-%* *
-%************************************************************************
-\begin{code}
-coreExprToStg env expr@(Lam _ _)
- = let
- (_,_, binders, body) = collectBinders expr
- in
- coreExprToStg env body `thenUs` \ stg_body ->
+-- ---------------------------------------------------------------------------
+-- The magic for lets:
+-- ---------------------------------------------------------------------------
- if null binders then -- it was all type/usage binders; tossed
- returnUs stg_body
- else
- newStgVar (coreExprType expr) `thenUs` \ var ->
- returnUs
- (StgLet (StgNonRec (var `addIdArity` exactArity (length binders))
- (StgRhsClosure noCostCentre
- stgArgOcc
- bOGUS_FVs
- ReEntrant -- binders is non-empty
- binders
- stg_body))
- (StgApp (StgVarArg var) [] bOGUS_LVs))
-\end{code}
+coreToStgLet
+ :: Bool -- True <=> yes, we are let-no-escaping this let
+ -> CoreBind -- bindings
+ -> CoreExpr -- 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
+ -- is among the escaping vars
-%************************************************************************
-%* *
-\subsubsection[coreToStg-applications]{Applications}
-%* *
-%************************************************************************
+coreToStgLet let_no_escape bind body
+ = fixLne (\ ~(_, _, _, _, _, rec_body_fvs, _, _) ->
-\begin{code}
-coreExprToStg env expr@(App _ _)
- = let
- (fun,args) = collect_args expr []
- (_, stg_args) = coreArgsToStg env args
+ -- 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 emptyLiveInfo)
+ (vars_bind rec_body_fvs bind)
+ `thenLne` \ ( bind2, bind_fvs, bind_escs, bind_lv_info, env_ext) ->
+
+ -- Do the body
+ extendVarEnvLne env_ext (
+ coreToStgExpr body `thenLne` \(body2, body_fvs, body_escs) ->
+ freeVarsToLiveVars body_fvs `thenLne` \ body_lv_info ->
+
+ returnLne (bind2, bind_fvs, bind_escs, getLiveVars bind_lv_info,
+ body2, body_fvs, body_escs, getLiveVars body_lv_info)
+ )
+
+ ) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs,
+ body2, body_fvs, body_escs, body_lvs) ->
+
+
+ -- Compute the new let-expression
+ let
+ new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
+ | otherwise = StgLet bind2 body2
+
+ free_in_whole_let
+ = binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs)
+
+ live_in_whole_let
+ = bind_lvs `unionVarSet` (body_lvs `delVarSetList` binders)
+
+ 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 `unionVarSet` body_escs) `delVarSetList` binders
+
+ all_escs = bind_escs `unionVarSet` body_escs -- Still includes binders of
+ -- 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
- -- Now deal with the function
- case (fun, args) of
- (Var fun_id, _) -> -- A function Id, so do an StgApp; it's ok if
- -- there are no arguments.
- returnUs (mk_app (stgLookup env fun_id) stg_args)
-
- (non_var_fun, []) -> -- No value args, so recurse into the function
- coreExprToStg env non_var_fun
-
- other -> -- A non-variable applied to things; better let-bind it.
- newStgVar (coreExprType fun) `thenUs` \ fun_id ->
- coreExprToStg env fun `thenUs` \ (stg_fun) ->
- let
- fun_rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
- stgArgOcc
- bOGUS_FVs
- SingleEntry -- Only entered once
- []
- stg_fun
- in
- returnUs (StgLet (StgNonRec fun_id fun_rhs)
- (StgApp (StgVarArg fun_id) stg_args bOGUS_LVs))
+ returnLne (
+ new_let,
+ free_in_whole_let,
+ let_escs,
+ checked_no_binder_escapes
+ ))
where
- -- Collect arguments, discarding type/usage applications
- collect_args (App e (TyArg _)) args = collect_args e args
- collect_args (App e (UsageArg _)) args = collect_args e args
- collect_args (App fun arg) args = collect_args fun (arg:args)
- collect_args fun args = (fun, args)
+ set_of_binders = mkVarSet binders
+ binders = bindersOf bind
+
+ mk_binding bind_lv_info binder rhs
+ = (binder, LetBound (NestedLet live_vars) (manifestArity rhs))
+ where
+ live_vars | let_no_escape = addLiveVar bind_lv_info binder
+ | otherwise = unitLiveVar binder
+ -- c.f. the invariant on NestedLet
+
+ vars_bind :: FreeVarsInfo -- Free var info for body of binding
+ -> CoreBind
+ -> LneM (StgBinding,
+ FreeVarsInfo,
+ EscVarsSet, -- free vars; escapee vars
+ LiveInfo, -- Vars and CAFs live in binding
+ [(Id, HowBound)]) -- extension to environment
+
+
+ vars_bind body_fvs (NonRec binder rhs)
+ = coreToStgRhs body_fvs [] (binder,rhs)
+ `thenLne` \ (rhs2, bind_fvs, bind_lv_info, escs) ->
+ let
+ env_ext_item = mk_binding bind_lv_info binder rhs
+ in
+ returnLne (StgNonRec binder rhs2,
+ bind_fvs, escs, bind_lv_info, [env_ext_item])
+
+
+ vars_bind body_fvs (Rec pairs)
+ = fixLne (\ ~(_, rec_rhs_fvs, _, bind_lv_info, _) ->
+ let
+ rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
+ binders = map fst pairs
+ env_ext = [ mk_binding bind_lv_info b rhs
+ | (b,rhs) <- pairs ]
+ in
+ extendVarEnvLne env_ext (
+ mapAndUnzip4Lne (coreToStgRhs rec_scope_fvs binders) pairs
+ `thenLne` \ (rhss2, fvss, lv_infos, escss) ->
+ let
+ bind_fvs = unionFVInfos fvss
+ bind_lv_info = foldr unionLiveInfo emptyLiveInfo lv_infos
+ escs = unionVarSets escss
+ in
+ returnLne (StgRec (binders `zip` rhss2),
+ bind_fvs, escs, bind_lv_info, 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}
-%************************************************************************
-%* *
-\subsubsection[coreToStg-cases]{Case expressions}
-%* *
-%************************************************************************
-
\begin{code}
-coreExprToStg env (Case discrim alts)
- = coreExprToStg env discrim `thenUs` \ stg_discrim ->
- alts_to_stg discrim alts `thenUs` \ stg_alts ->
- getUnique `thenUs` \ uniq ->
- returnUs (
- StgCase stg_discrim
- bOGUS_LVs
- bOGUS_LVs
- uniq
- stg_alts
- )
+coreToStgRhs :: FreeVarsInfo -- Free var info for the scope of the binding
+ -> [Id]
+ -> (Id,CoreExpr)
+ -> LneM (StgRhs, FreeVarsInfo, LiveInfo, EscVarsSet)
+
+coreToStgRhs scope_fv_info binders (bndr, rhs)
+ = coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, rhs_escs) ->
+ getEnvLne `thenLne` \ env ->
+ freeVarsToLiveVars (binders `minusFVBinders` rhs_fvs) `thenLne` \ lv_info ->
+ returnLne (mkStgRhs rhs_fvs (mkSRT lv_info) bndr_info new_rhs,
+ rhs_fvs, lv_info, rhs_escs)
+ where
+ bndr_info = lookupFVInfo scope_fv_info bndr
+
+mkStgRhs :: FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr -> StgRhs
+
+mkStgRhs rhs_fvs srt binder_info (StgConApp con args)
+ = StgRhsCon noCCS con args
+
+mkStgRhs rhs_fvs srt binder_info (StgLam _ bndrs body)
+ = StgRhsClosure noCCS binder_info
+ (getFVs rhs_fvs)
+ ReEntrant
+ srt bndrs body
+
+mkStgRhs rhs_fvs srt binder_info rhs
+ = StgRhsClosure noCCS binder_info
+ (getFVs rhs_fvs)
+ upd_flag srt [] rhs
where
- discrim_ty = coreExprType discrim
- (_, discrim_ty_args, _) = getAppDataTyConExpandingDicts discrim_ty
-
- alts_to_stg discrim (AlgAlts alts deflt)
- = default_to_stg discrim deflt `thenUs` \ stg_deflt ->
- mapUs boxed_alt_to_stg alts `thenUs` \ stg_alts ->
- returnUs (StgAlgAlts discrim_ty stg_alts stg_deflt)
- where
- boxed_alt_to_stg (con, bs, rhs)
- = coreExprToStg env rhs `thenUs` \ stg_rhs ->
- returnUs (spec_con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs)
- where
- spec_con = mkSpecialisedCon con discrim_ty_args
-
- alts_to_stg discrim (PrimAlts alts deflt)
- = default_to_stg discrim deflt `thenUs` \ stg_deflt ->
- mapUs unboxed_alt_to_stg alts `thenUs` \ stg_alts ->
- returnUs (StgPrimAlts discrim_ty stg_alts stg_deflt)
- where
- unboxed_alt_to_stg (lit, rhs)
- = coreExprToStg env rhs `thenUs` \ stg_rhs ->
- returnUs (lit, stg_rhs)
-
- default_to_stg discrim NoDefault
- = returnUs StgNoDefault
-
- default_to_stg discrim (BindDefault binder rhs)
- = coreExprToStg env rhs `thenUs` \ stg_rhs ->
- returnUs (StgBindDefault binder True{-used? no it is lying-} stg_rhs)
+ upd_flag = Updatable
+ {-
+ SDM: disabled. Eval/Apply can't handle functions with arity zero very
+ well; and making these into simple non-updatable thunks breaks other
+ assumptions (namely that they will be entered only once).
+
+ upd_flag | isPAP env rhs = ReEntrant
+ | otherwise = Updatable
+ -}
+
+{- ToDo:
+ upd = if isOnceDem dem
+ then (if isNotTop toplev
+ then SingleEntry -- HA! Paydirt for "dem"
+ else
+#ifdef DEBUG
+ trace "WARNING: SE CAFs unsupported, forcing UPD instead" $
+#endif
+ Updatable)
+ else Updatable
+ -- For now we forbid SingleEntry CAFs; they tickle the
+ -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
+ -- and I don't understand why. There's only one SE_CAF (well,
+ -- only one that tickled a great gaping bug in an earlier attempt
+ -- at ClosureInfo.getEntryConvention) in the whole of nofib,
+ -- specifically Main.lvl6 in spectral/cryptarithm2.
+ -- So no great loss. KSW 2000-07.
+-}
\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.
+
+isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args
+ where
+ arity = stgArity f (lookupBinding env f)
+isPAP env _ = False
+
+
%************************************************************************
%* *
-\subsubsection[coreToStg-let(rec)]{Let and letrec expressions}
+\subsection[LNE-monad]{A little monad for this let-no-escaping pass}
%* *
%************************************************************************
+There's a lot of stuff to pass around, so we use this @LneM@ monad to
+help. All the stuff here is only passed *down*.
+
\begin{code}
-coreExprToStg env (Let bind body)
- = coreBindToStg env bind `thenUs` \ (stg_binds, new_env) ->
- coreExprToStg new_env body `thenUs` \ stg_body ->
- returnUs (mkStgLets stg_binds stg_body)
+type LneM a = IdEnv HowBound
+ -> LiveInfo -- Vars and CAFs live in continuation
+ -> a
+
+type LiveInfo = (StgLiveVars, -- Dynamic live variables;
+ -- i.e. ones with a nested (non-top-level) binding
+ CafSet) -- Static live variables;
+ -- i.e. top-level variables that are CAFs or refer to them
+
+type EscVarsSet = IdSet
+type CafSet = IdSet
+
+data HowBound
+ = ImportBound -- Used only as a response to lookupBinding; never
+ -- exists in the range of the (IdEnv HowBound)
+
+ | LetBound -- A let(rec) in this module
+ LetInfo -- Whether top level or nested
+ Arity -- Its arity (local Ids don't have arity info at this point)
+
+ | LambdaBound -- Used for both lambda and case
+
+data LetInfo
+ = TopLet -- top level things
+ | NestedLet LiveInfo -- For nested things, what is live if this
+ -- thing is live? Invariant: the binder
+ -- itself is always a member of
+ -- the dynamic set of its own LiveInfo
+
+isLetBound (LetBound _ _) = True
+isLetBound other = False
+
+topLevelBound ImportBound = True
+topLevelBound (LetBound TopLet _) = True
+topLevelBound other = False
\end{code}
+For a let(rec)-bound variable, x, we record LiveInfo, the set of
+variables that are live if x is live. This LiveInfo comprises
+ (a) dynamic live variables (ones with a non-top-level binding)
+ (b) static live variabes (CAFs or things that refer to CAFs)
-%************************************************************************
-%* *
-\subsubsection[coreToStg-scc]{SCC expressions}
-%* *
-%************************************************************************
+For "normal" variables (a) 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 in the
+LetBound constructor; x itself *is* included.
+
+The set of dynamic live variables is guaranteed ot have no further let-no-escaped
+variables in it.
-Covert core @scc@ expression directly to STG @scc@ expression.
\begin{code}
-coreExprToStg env (SCC cc expr)
- = coreExprToStg env expr `thenUs` \ stg_expr ->
- returnUs (StgSCC (coreExprType expr) cc stg_expr)
+emptyLiveInfo :: LiveInfo
+emptyLiveInfo = (emptyVarSet,emptyVarSet)
+
+unitLiveVar :: Id -> LiveInfo
+unitLiveVar lv = (unitVarSet lv, emptyVarSet)
+
+unitLiveCaf :: Id -> LiveInfo
+unitLiveCaf caf = (emptyVarSet, unitVarSet caf)
+
+addLiveVar :: LiveInfo -> Id -> LiveInfo
+addLiveVar (lvs, cafs) id = (lvs `extendVarSet` id, cafs)
+
+unionLiveInfo :: LiveInfo -> LiveInfo -> LiveInfo
+unionLiveInfo (lv1,caf1) (lv2,caf2) = (lv1 `unionVarSet` lv2, caf1 `unionVarSet` caf2)
+
+mkSRT :: LiveInfo -> SRT
+mkSRT (_, cafs) = SRTEntries cafs
+
+getLiveVars :: LiveInfo -> StgLiveVars
+getLiveVars (lvs, _) = lvs
\end{code}
+
+The std monad functions:
\begin{code}
-coreExprToStg env (Coerce c ty expr) = coreExprToStg env expr
+initLne :: IdEnv HowBound -> LneM a -> a
+initLne env m = m env emptyLiveInfo
+
+
+
+{-# INLINE thenLne #-}
+{-# INLINE returnLne #-}
+
+returnLne :: a -> LneM a
+returnLne e env lvs_cont = e
+
+thenLne :: LneM a -> (a -> LneM b) -> LneM b
+thenLne m k env lvs_cont
+ = k (m env lvs_cont) env lvs_cont
+
+mapAndUnzipLne :: (a -> LneM (b,c)) -> [a] -> LneM ([b],[c])
+mapAndUnzipLne f [] = returnLne ([],[])
+mapAndUnzipLne f (x:xs)
+ = f x `thenLne` \ (r1, r2) ->
+ mapAndUnzipLne f xs `thenLne` \ (rs1, rs2) ->
+ returnLne (r1:rs1, r2:rs2)
+
+mapAndUnzip3Lne :: (a -> LneM (b,c,d)) -> [a] -> LneM ([b],[c],[d])
+mapAndUnzip3Lne f [] = returnLne ([],[],[])
+mapAndUnzip3Lne f (x:xs)
+ = f x `thenLne` \ (r1, r2, r3) ->
+ mapAndUnzip3Lne f xs `thenLne` \ (rs1, rs2, rs3) ->
+ returnLne (r1:rs1, r2:rs2, r3:rs3)
+
+mapAndUnzip4Lne :: (a -> LneM (b,c,d,e)) -> [a] -> LneM ([b],[c],[d],[e])
+mapAndUnzip4Lne f [] = returnLne ([],[],[],[])
+mapAndUnzip4Lne f (x:xs)
+ = f x `thenLne` \ (r1, r2, r3, r4) ->
+ mapAndUnzip4Lne f xs `thenLne` \ (rs1, rs2, rs3, rs4) ->
+ returnLne (r1:rs1, r2:rs2, r3:rs3, r4:rs4)
+
+fixLne :: (a -> LneM a) -> LneM a
+fixLne expr env lvs_cont
+ = result
+ where
+ result = expr result env lvs_cont
\end{code}
+Functions specific to this monad:
+
+\begin{code}
+getVarsLiveInCont :: LneM LiveInfo
+getVarsLiveInCont env lvs_cont = lvs_cont
+
+setVarsLiveInCont :: LiveInfo -> LneM a -> LneM a
+setVarsLiveInCont new_lvs_cont expr env lvs_cont
+ = expr env new_lvs_cont
+
+extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
+extendVarEnvLne ids_w_howbound expr env lvs_cont
+ = expr (extendVarEnvList env ids_w_howbound) lvs_cont
+
+lookupVarLne :: Id -> LneM HowBound
+lookupVarLne v env lvs_cont = returnLne (lookupBinding env v) env lvs_cont
+
+getEnvLne :: LneM (IdEnv HowBound)
+getEnvLne env lvs_cont = returnLne env env lvs_cont
+
+lookupBinding :: IdEnv HowBound -> Id -> HowBound
+lookupBinding env v = case lookupVarEnv env v of
+ Just xx -> xx
+ Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound
+
+
+-- 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.
+
+freeVarsToLiveVars :: FreeVarsInfo -> LneM LiveInfo
+freeVarsToLiveVars fvs env live_in_cont
+ = returnLne live_info env live_in_cont
+ where
+ live_info = foldr unionLiveInfo live_in_cont lvs_from_fvs
+ lvs_from_fvs = map do_one (allFreeIds fvs)
+
+ do_one (v, how_bound)
+ = case how_bound of
+ ImportBound -> unitLiveCaf v -- Only CAF imports are
+ -- recorded in fvs
+ LetBound TopLet _
+ | mayHaveCafRefs (idCafInfo v) -> unitLiveCaf v
+ | otherwise -> emptyLiveInfo
+
+ LetBound (NestedLet lvs) _ -> lvs -- lvs already contains v
+ -- (see the invariant on NestedLet)
+
+ _lambda_or_case_binding -> unitLiveVar v -- Bound by lambda or case
+\end{code}
%************************************************************************
%* *
-\subsection[coreToStg-misc]{Miscellaneous helping functions}
+\subsection[Free-var info]{Free variable information}
%* *
%************************************************************************
-There's not anything interesting we can ASSERT about \tr{var} if it
-isn't in the StgEnv. (WDP 94/06)
-
\begin{code}
-stgLookup :: StgEnv -> Id -> StgArg
-stgLookup env var = case (lookupIdEnv env var) of
- Nothing -> StgVarArg var
- Just atom -> atom
+type FreeVarsInfo = VarEnv (Var, HowBound, StgBinderInfo)
+ -- The Var is so we can gather up the free variables
+ -- as a set.
+ --
+ -- The HowBound info just saves repeated lookups;
+ -- we look up just once when we encounter the occurrence.
+ -- INVARIANT: Any ImportBound Ids are HaveCafRef Ids
+ -- Imported Ids without CAF refs are simply
+ -- not put in the FreeVarsInfo for an expression.
+ -- See singletonFVInfo and freeVarsToLiveVars
+ --
+ -- StgBinderInfo records how it occurs; notably, we
+ -- are interested in whether it only occurs in saturated
+ -- applications, because then we don't need to build a
+ -- curried version.
+ -- If f is mapped to noBinderInfo, that means
+ -- that f *is* mentioned (else it wouldn't be in the
+ -- IdEnv at all), but perhaps in an unsaturated applications.
+ --
+ -- All case/lambda-bound things are also mapped to
+ -- noBinderInfo, since we aren't interested in their
+ -- occurence info.
+ --
+ -- For ILX we track free var info for type variables too;
+ -- hence VarEnv not IdEnv
\end{code}
-Invent a fresh @Id@:
\begin{code}
-newStgVar :: Type -> UniqSM Id
-newStgVar ty
- = getUnique `thenUs` \ uniq ->
- returnUs (mkSysLocal SLIT("stg") uniq ty noSrcLoc)
+emptyFVInfo :: FreeVarsInfo
+emptyFVInfo = emptyVarEnv
+
+singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
+-- Don't record non-CAF imports at all, to keep free-var sets small
+singletonFVInfo id ImportBound info
+ | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, ImportBound, info)
+ | otherwise = emptyVarEnv
+singletonFVInfo id how_bound info = unitVarEnv id (id, how_bound, info)
+
+tyvarFVInfo :: TyVarSet -> FreeVarsInfo
+tyvarFVInfo tvs = foldVarSet add emptyFVInfo tvs
+ where
+ add tv fvs = extendVarEnv fvs tv (tv, LambdaBound, noBinderInfo)
+ -- Type variables must be lambda-bound
+
+unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
+unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
+
+unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
+unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
+
+minusFVBinders :: [Id] -> FreeVarsInfo -> FreeVarsInfo
+minusFVBinders vs fv = foldr minusFVBinder fv vs
+
+minusFVBinder :: Id -> FreeVarsInfo -> FreeVarsInfo
+minusFVBinder v fv | isId v && opt_RuntimeTypes
+ = (fv `delVarEnv` v) `unionFVInfo`
+ tyvarFVInfo (tyVarsOfType (idType v))
+ | otherwise = fv `delVarEnv` v
+ -- When removing a binder, remember to add its type variables
+ -- c.f. CoreFVs.delBinderFV
+
+elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
+elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id)
+
+lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo
+-- Find how the given Id is used.
+-- Externally visible things may be used any old how
+lookupFVInfo fvs id
+ | isExternalName (idName id) = noBinderInfo
+ | otherwise = case lookupVarEnv fvs id of
+ Nothing -> noBinderInfo
+ Just (_,_,info) -> info
+
+allFreeIds :: FreeVarsInfo -> [(Id,HowBound)] -- Both top level and non-top-level Ids
+allFreeIds fvs = [(id,how_bound) | (id,how_bound,_) <- rngVarEnv fvs, isId id]
+
+-- Non-top-level things only, both type variables and ids
+-- (type variables only if opt_RuntimeTypes)
+getFVs :: FreeVarsInfo -> [Var]
+getFVs fvs = [id | (id, how_bound, _) <- rngVarEnv fvs,
+ not (topLevelBound how_bound) ]
+
+getFVSet :: FreeVarsInfo -> VarSet
+getFVSet fvs = mkVarSet (getFVs fvs)
+
+plusFVInfo (id1,hb1,info1) (id2,hb2,info2)
+ = ASSERT (id1 == id2 && hb1 `check_eq_how_bound` hb2)
+ (id1, hb1, combineStgBinderInfo info1 info2)
+
+#ifdef DEBUG
+-- The HowBound info for a variable in the FVInfo should be consistent
+check_eq_how_bound ImportBound ImportBound = True
+check_eq_how_bound LambdaBound LambdaBound = True
+check_eq_how_bound (LetBound li1 ar1) (LetBound li2 ar2) = ar1 == ar2 && check_eq_li li1 li2
+check_eq_how_bound hb1 hb2 = False
+
+check_eq_li (NestedLet _) (NestedLet _) = True
+check_eq_li TopLet TopLet = True
+check_eq_li li1 li2 = False
+#endif
\end{code}
+Misc.
\begin{code}
-mkStgLets :: [StgBinding]
- -> StgExpr -- body of let
- -> StgExpr
+filterStgBinders :: [Var] -> [Var]
+filterStgBinders bndrs
+ | opt_RuntimeTypes = bndrs
+ | otherwise = filter isId bndrs
+\end{code}
+
-mkStgLets binds body = foldr StgLet body binds
+\begin{code}
+ -- Ignore all notes except SCC
+myCollectBinders expr
+ = go [] expr
+ where
+ go bs (Lam b e) = go (b:bs) e
+ go bs e@(Note (SCC _) _) = (reverse bs, e)
+ go bs (Note _ e) = go bs e
+ go bs e = (reverse bs, e)
+
+myCollectArgs :: CoreExpr -> (Id, [CoreArg])
+ -- We assume that we only have variables
+ -- in the function position by now
+myCollectArgs expr
+ = go expr []
+ where
+ go (Var v) as = (v, as)
+ go (App f a) as = go f (a:as)
+ go (Note (SCC _) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
+ go (Note n e) as = go e as
+ go _ as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
+\end{code}
--- mk_app spots an StgCon in a function position,
--- and turns it into an StgCon. See notes with
--- getArgAmode in CgBindery.
-mk_app (StgConArg con) args = StgCon con args bOGUS_LVs
-mk_app other_fun args = StgApp other_fun args bOGUS_LVs
+\begin{code}
+stgArity :: Id -> HowBound -> Arity
+stgArity f (LetBound _ arity) = arity
+stgArity f ImportBound = idArity f
+stgArity f LambdaBound = 0
\end{code}
projects / ghc-hetmet.git / blobdiff