X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FstgSyn%2FCoreToStg.lhs;h=04da56d59be7b7bfe38257895493edb5c594b3ca;hb=916214e4f401d70462654013e83c4b8b08e85a18;hp=5afb086b0704fdba5aa118d13145d27a2f68206e;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 5afb086..04da56d 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -1,661 +1,1168 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 % -%************************************************************************ -%* * -\section[CoreToStg]{Converting core syntax to STG syntax} -%* * -%************************************************************************ - -Convert a @CoreSyntax@ program to a @StgSyntax@ program. +\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" -module CoreToStg ( - topCoreBindsToStg - - -- and to make the interface self-sufficient... - ) where - -import AnnCoreSyn -- intermediate form on which all work is done -import StgSyn -- output -import UniqSupply - -import PrelInfo ( unpackCStringId, unpackCString2Id, stringTy, - integerTy, rationalTy, ratioDataCon, - PrimOp(..), -- For Int2IntegerOp etc - integerZeroId, integerPlusOneId, - integerPlusTwoId, integerMinusOneId - IF_ATTACK_PRAGMAS(COMMA mkListTy COMMA charTy) - IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) - IF_ATTACK_PRAGMAS(COMMA pprPrimOp) - ) - -import Type ( isPrimType, isLeakFreeType, getAppDataTyCon ) -import Bag -- Bag operations -import Literal ( mkMachInt, Literal(..) ) -- ToDo: its use is ugly... -import CostCentre ( noCostCentre, CostCentre ) -import Id ( mkSysLocal, idType, isBottomingId - IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed) - ) -import Maybes ( Maybe(..), catMaybes ) -import Outputable ( isExported ) -import Pretty -- debugging only! -import SpecUtils ( mkSpecialisedCon ) -import SrcLoc ( SrcLoc, mkUnknownSrcLoc ) -import Util +import CoreSyn +import CoreUtils +import StgSyn + +import Type +import TyCon ( isAlgTyCon ) +import Literal +import Id +import Var ( Var, globalIdDetails, varType ) +import IdInfo +import DataCon +import CostCentre ( noCCS ) +import VarSet +import VarEnv +import DataCon ( dataConWrapId ) +import IdInfo ( OccInfo(..) ) +import Maybes ( maybeToBool ) +import Name ( getOccName, isExternallyVisibleName, isDllName ) +import OccName ( occNameUserString ) +import BasicTypes ( TopLevelFlag(..), isNotTopLevel, Arity ) +import CmdLineOpts ( DynFlags, opt_RuntimeTypes ) +import FastTypes hiding ( fastOr ) +import Outputable + +import List ( partition ) + +infixr 9 `thenLne` \end{code} +%************************************************************************ +%* * +\subsection[live-vs-free-doc]{Documentation} +%* * +%************************************************************************ - *************** OVERVIEW ********************* - +(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. -The business of this pass is to convert Core to Stg. On the way: +%************************************************************************ +%* * +\subsection[caf-info]{Collecting live CAF info} +%* * +%************************************************************************ -* We discard type lambdas and applications. In so doing we discard - "trivial" bindings such as - x = y t1 t2 - where t1, t2 are types +In this pass we also collect information on which CAFs are live for +constructing SRTs (see SRT.lhs). -* We make the representation of NoRep literals explicit, and - float their bindings to the top level +A top-level Id has CafInfo, which is -* 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. + - MayHaveCafRefs, if it may refer indirectly to + one or more CAFs, or + - NoCafRefs if it definitely doesn't -* We convert case x of {...; x' -> ...x'...} - to - case x of {...; _ -> ...x... } +we collect the CafInfo first by analysing the original Core expression, and +also place this information in the environment. - See notes in SimplCase.lhs, near simplDefault for the reasoning here. +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 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. %************************************************************************ %* * -\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) -\end{code} - -\begin{code} -topCoreBindsToStg :: UniqSupply -- name supply - -> [CoreBinding] -- input - -> [StgBinding] -- output +coreTopBindsToStg + :: IdEnv HowBound -- environment for the bindings + -> [CoreBind] + -> (IdEnv HowBound, FreeVarsInfo, [StgBinding]) -topCoreBindsToStg us core_binds - = case (initUs us (binds_to_stg nullIdEnv core_binds)) of - (_, stuff) -> stuff +coreTopBindsToStg env [] = (env, emptyFVInfo, []) +coreTopBindsToStg env (b:bs) + = (env2, fvs2, b':bs') where - binds_to_stg :: StgEnv -> [CoreBinding] -> UniqSM [StgBinding] - - binds_to_stg env [] = returnUs [] - binds_to_stg env (b:bs) - = do_top_bind env b `thenUs` \ (new_b, new_env, float_binds) -> - binds_to_stg new_env bs `thenUs` \ new_bs -> - returnUs (bagToList float_binds ++ -- Literals - new_b ++ - new_bs) - - do_top_bind env bind@(Rec pairs) - = coreBindToStg env bind - - do_top_bind env bind@(NonRec var rhs) - = coreBindToStg env bind `thenUs` \ (stg_binds, new_env, float_binds) -> -{- TESTING: - let - ppr_blah xs = ppInterleave ppComma (map pp_x xs) - pp_x (u,x) = ppBesides [pprUnique u, ppStr ": ", ppr PprDebug x] - in - pprTrace "do_top_bind:" (ppAbove (ppr PprDebug stg_binds) (ppr_blah (ufmToList new_env))) $ --} - case stg_binds of - [StgNonRec var (StgRhsClosure cc bi fvs u [] rhs_body)] -> - -- Mega-special case; there's still a binding there - -- no fvs (of course), *no args*, "let" rhs - let - (extra_float_binds, rhs_body') = seek_liftable [] rhs_body - in - returnUs (extra_float_binds ++ - [StgNonRec var (StgRhsClosure cc bi fvs u [] rhs_body')], - new_env, - float_binds) - - other -> returnUs (stg_binds, new_env, float_binds) - - -------------------- - -- HACK: look for very simple, obviously-liftable bindings - -- that can come up to the top level; those that couldn't - -- 'cause they were big-lambda constrained in the Core world. - - seek_liftable :: [StgBinding] -- accumulator... - -> StgExpr -- look for top-lev liftables - -> ([StgBinding], StgExpr) -- result - - seek_liftable acc expr@(StgLet inner_bind body) - | is_liftable inner_bind - = seek_liftable (inner_bind : acc) body - - seek_liftable acc other_expr = (reverse acc, other_expr) -- Finished - - -------------------- - is_liftable (StgNonRec binder (StgRhsClosure _ _ _ _ args body)) - = not (null args) -- it's manifestly a function... - || isLeakFreeType [] (idType binder) - || is_whnf body - -- ToDo: use a decent manifestlyWHNF function for STG? - where - is_whnf (StgCon _ _ _) = True - is_whnf (StgApp (StgVarArg v) _ _) = isBottomingId v - is_whnf other = False + -- 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 + caf_info = hasCafRefs env rhs + + env' = extendVarEnv env id (LetBound how_bound emptyLVS (predictArity rhs)) + + how_bound | mayHaveCafRefs caf_info = TopLevelHasCafs + | otherwise = TopLevelNoCafs + + (stg_rhs, fvs', cafs) = + initLne env ( + coreToStgRhs body_fvs TopLevel (id,rhs) + `thenLne` \ (stg_rhs, fvs', _) -> + freeVarsToLiveVars fvs' `thenLne` \ (_, cafs) -> + returnLne (stg_rhs, fvs', cafs) + ) + + bind = StgNonRec (SRTEntries cafs) id stg_rhs + in + ASSERT2(predictArity rhs == stgRhsArity stg_rhs, ppr id) + ASSERT2(consistent caf_info bind, ppr id) +-- WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info) + (env', fvs' `unionFVInfo` body_fvs, bind) - is_liftable (StgRec [(_, StgRhsClosure _ _ _ _ args body)]) - = not (null args) -- it's manifestly a (recursive) function... +coreTopBindToStg env body_fvs (Rec pairs) + = let + (binders, rhss) = unzip pairs - is_liftable anything_else = False -\end{code} + -- to calculate caf_info, we initially map all the binders to + -- TopLevelNoCafs. + env1 = extendVarEnvList env + [ (b, LetBound TopLevelNoCafs emptyLVS (error "no arity")) + | b <- binders ] -%************************************************************************ -%* * -\subsection[coreToStg-binds]{Converting bindings} -%* * -%************************************************************************ + caf_info = hasCafRefss env1{-NB: not env'-} rhss -\begin{code} -coreBindToStg :: StgEnv - -> CoreBinding - -> UniqSM ([StgBinding], -- Empty or singleton - StgEnv, -- New envt - Bag StgBinding) -- Floats + env' = extendVarEnvList env + [ (b, LetBound how_bound emptyLVS (predictArity rhs)) + | (b,rhs) <- pairs ] -coreBindToStg env (NonRec binder rhs) - = coreRhsToStg env rhs `thenUs` \ (stg_rhs, rhs_binds) -> + how_bound | mayHaveCafRefs caf_info = TopLevelHasCafs + | otherwise = TopLevelNoCafs - let - -- Binds to return if RHS is trivial - triv_binds = if isExported binder then - [StgNonRec binder stg_rhs] -- Retain it - else - [] -- Discard it - 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, rhs_binds) - 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, rhs_binds) - where - new_env = addOneToIdEnv env binder (StgVarArg con_id) - - other -> -- Non-trivial RHS, so don't augment envt - returnUs ([StgNonRec binder stg_rhs], env, rhs_binds) - -coreBindToStg env (Rec pairs) - = -- NB: *** WE DO NOT CHECK FOR TRIV_BINDS in REC BIND **** - -- (possibly ToDo) - let - (binders, rhss) = unzip pairs + (stg_rhss, fvs', cafs) + = initLne env' ( + mapAndUnzip3Lne (coreToStgRhs body_fvs TopLevel) pairs + `thenLne` \ (stg_rhss, fvss', _) -> + let fvs' = unionFVInfos fvss' in + freeVarsToLiveVars fvs' `thenLne` \ (_, cafs) -> + returnLne (stg_rhss, fvs', cafs) + ) + + bind = StgRec (SRTEntries cafs) (zip binders stg_rhss) in - mapAndUnzipUs (coreRhsToStg env) rhss `thenUs` \ (stg_rhss, rhs_binds) -> - returnUs ([StgRec (binders `zip` stg_rhss)], env, unionManyBags rhs_binds) + ASSERT2(and [predictArity rhs == stgRhsArity stg_rhs | (rhs,stg_rhs) <- rhss `zip` stg_rhss], ppr binders) + ASSERT2(consistent caf_info bind, ppr binders) +-- WARN(not (consistent caf_info bind), ppr binders <+> ppr cafs <+> ppCafInfo caf_info) + (env', fvs' `unionFVInfo` body_fvs, bind) + +-- assertion helper +consistent caf_info bind = mayHaveCafRefs caf_info == stgBindHasCafRefs bind \end{code} +\begin{code} +coreToStgRhs + :: FreeVarsInfo -- Free var info for the scope of the binding + -> TopLevelFlag + -> (Id,CoreExpr) + -> LneM (StgRhs, FreeVarsInfo, EscVarsSet) + +coreToStgRhs scope_fv_info top (binder, rhs) + = coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, rhs_escs) -> + returnLne (mkStgRhs top rhs_fvs binder_info new_rhs, + rhs_fvs, rhs_escs) + where + binder_info = lookupFVInfo scope_fv_info binder + +mkStgRhs :: TopLevelFlag -> FreeVarsInfo -> StgBinderInfo + -> StgExpr -> StgRhs + +mkStgRhs top rhs_fvs binder_info (StgLam _ bndrs body) + = StgRhsClosure noCCS binder_info + (getFVs rhs_fvs) + ReEntrant + bndrs body + +mkStgRhs top rhs_fvs binder_info (StgConApp con args) + | isNotTopLevel top || not (isDllConApp con args) + = StgRhsCon noCCS con args + +mkStgRhs top rhs_fvs binder_info rhs + = StgRhsClosure noCCS binder_info + (getFVs rhs_fvs) + (updatable [] rhs) + [] rhs + where + updatable args body | null args && isPAP body = 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} -%************************************************************************ -%* * -\subsection[coreToStg-rhss]{Converting right hand sides} -%* * -%************************************************************************ +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} -coreRhsToStg :: StgEnv -> CoreExpr -> UniqSM (StgRhs, Bag StgBinding) - -coreRhsToStg env core_rhs - = coreExprToStg env core_rhs `thenUs` \ (stg_expr, stg_binds) -> - - 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 - - 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, stg_binds) +isPAP (StgApp f args) = idArity f > length args +isPAP _ = False \end{code} -%************************************************************************ -%* * -\subsection[coreToStg-lits]{Converting literals} -%* * -%************************************************************************ +-- --------------------------------------------------------------------------- +-- Expressions +-- --------------------------------------------------------------------------- -Literals: the NoRep kind need to be de-no-rep'd. -We always replace them with a simple variable, and float a suitable -binding out to the top level. +\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} -If an Integer is small enough (Haskell implementations must support -Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@; -otherwise, wrap with @litString2Integer@. +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} -tARGET_MIN_INT, tARGET_MAX_INT :: Integer -tARGET_MIN_INT = -536870912 -tARGET_MAX_INT = 536870912 +coreToStgExpr (Lit l) = returnLne (StgLit l, emptyFVInfo, emptyVarSet) +coreToStgExpr (Var v) = coreToStgApp Nothing v [] -litToStgArg :: Literal -> UniqSM (StgArg, Bag StgBinding) +coreToStgExpr expr@(App _ _) + = coreToStgApp Nothing f args + where + (f, args) = myCollectArgs expr -litToStgArg (NoRepStr s) - = newStgVar stringTy `thenUs` \ var -> - let - rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?) - stgArgOcc -- safe - bOGUS_FVs - Updatable -- WAS: ReEntrant (see note below) - [] -- No arguments - val - --- We used not to update strings, so that they wouldn't clog up the heap, --- but instead be unpacked each time. But on some programs that costs a lot --- [eg hpg], so now we update them. - - val = if (any is_NUL (_UNPK_ s)) then -- must cater for NULs in literal string - StgApp (StgVarArg unpackCString2Id) - [StgLitArg (MachStr s), - StgLitArg (mkMachInt (toInteger (_LENGTH_ s)))] - bOGUS_LVs - else - StgApp (StgVarArg unpackCStringId) - [StgLitArg (MachStr s)] - bOGUS_LVs +coreToStgExpr expr@(Lam _ _) + = let (args, body) = myCollectBinders expr + args' = filterStgBinders args in - returnUs (StgVarArg var, unitBag (StgNonRec var rhs)) - where - is_NUL c = c == '\0' - -litToStgArg (NoRepInteger i) - -- extremely convenient to look out for a few very common - -- Integer literals! - | i == 0 = returnUs (StgVarArg integerZeroId, emptyBag) - | i == 1 = returnUs (StgVarArg integerPlusOneId, emptyBag) - | i == 2 = returnUs (StgVarArg integerPlusTwoId, emptyBag) - | i == (-1) = returnUs (StgVarArg integerMinusOneId, emptyBag) - - | otherwise - = newStgVar integerTy `thenUs` \ var -> + extendVarEnvLne [ (a, LambdaBound) | a <- args' ] $ + coreToStgExpr body `thenLne` \ (body, body_fvs, body_escs) -> let - rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?) - stgArgOcc -- safe - bOGUS_FVs - Updatable -- Update an integer - [] -- No arguments - val - - val - | i > tARGET_MIN_INT && i < tARGET_MAX_INT - = -- Start from an Int - StgPrim Int2IntegerOp [StgLitArg (mkMachInt i)] bOGUS_LVs - - | otherwise - = -- Start from a string - StgPrim Addr2IntegerOp [StgLitArg (MachStr (_PK_ (show i)))] bOGUS_LVs + set_of_args = mkVarSet args' + fvs = args' `minusFVBinders` body_fvs + escs = body_escs `minusVarSet` set_of_args + result_expr | null args' = body + | otherwise = StgLam (exprType expr) args' body in - returnUs (StgVarArg var, unitBag (StgNonRec var rhs)) - -litToStgArg (NoRepRational r) - = litToStgArg (NoRepInteger (numerator r)) `thenUs` \ (num_atom, binds1) -> - litToStgArg (NoRepInteger (denominator r)) `thenUs` \ (denom_atom, binds2) -> - newStgVar rationalTy `thenUs` \ var -> - let - rhs = StgRhsCon noCostCentre -- No cost centre (ToDo?) - ratioDataCon -- Constructor - [num_atom, denom_atom] - in - returnUs (StgVarArg var, binds1 `unionBags` - binds2 `unionBags` - unitBag (StgNonRec var rhs)) - -litToStgArg other_lit = returnUs (StgLitArg other_lit, emptyBag) -\end{code} + returnLne (result_expr, fvs, escs) +coreToStgExpr (Note (SCC cc) expr) + = coreToStgExpr expr `thenLne` ( \ (expr2, fvs, escs) -> + returnLne (StgSCC cc expr2, fvs, escs) ) -%************************************************************************ -%* * -\subsection[coreToStg-atoms{Converting atoms} -%* * -%************************************************************************ +coreToStgExpr (Note other_note expr) + = coreToStgExpr expr -\begin{code} -coreAtomToStg :: StgEnv -> CoreArg -> UniqSM (StgArg, Bag StgBinding) -coreAtomToStg env (VarArg var) = returnUs (stgLookup env var, emptyBag) -coreAtomToStg env (LitArg lit) = litToStgArg lit +-- Cases require a little more real work. + +coreToStgExpr (Case scrut bndr alts) + = extendVarEnvLne [(bndr, CaseBound)] $ + vars_alts (findDefault alts) `thenLne` \ (alts2, alts_fvs, alts_escs) -> + freeVarsToLiveVars alts_fvs `thenLne` \ (alts_lvs, alts_caf_refs) -> + 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'= if (bndr `elementOfFVInfo` alts_fvs) + then bndr + else 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. + live_in_alts = (alts_lvs `minusVarSet` unitVarSet bndr) + in + -- we tell the scrutinee that everything live in the alts + -- is live in it, too. + setVarsLiveInCont (live_in_alts,alts_caf_refs) ( + coreToStgExpr scrut `thenLne` \ (scrut2, scrut_fvs, scrut_escs) -> + freeVarsToLiveVars scrut_fvs `thenLne` \ (scrut_lvs, _) -> + returnLne (scrut2, scrut_fvs, scrut_escs, scrut_lvs) + ) + `thenLne` \ (scrut2, scrut_fvs, scrut_escs, scrut_lvs) -> + + let srt = SRTEntries alts_caf_refs + in + returnLne ( + StgCase scrut2 scrut_lvs live_in_alts bndr' srt alts2, + bndr `minusFVBinder` (scrut_fvs `unionFVInfo` alts_fvs), + (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 + scrut_ty = idType bndr + prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty) + + vars_alts (alts,deflt) + | prim_case + = mapAndUnzip3Lne vars_prim_alt alts + `thenLne` \ (alts2, alts_fvs_list, alts_escs_list) -> + let + alts_fvs = unionFVInfos alts_fvs_list + alts_escs = unionVarSets alts_escs_list + in + vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) -> + returnLne ( + mkStgPrimAlts scrut_ty alts2 deflt2, + alts_fvs `unionFVInfo` deflt_fvs, + alts_escs `unionVarSet` deflt_escs + ) + + | otherwise + = mapAndUnzip3Lne vars_alg_alt alts + `thenLne` \ (alts2, alts_fvs_list, alts_escs_list) -> + let + alts_fvs = unionFVInfos alts_fvs_list + alts_escs = unionVarSets alts_escs_list + in + vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) -> + returnLne ( + mkStgAlgAlts scrut_ty alts2 deflt2, + alts_fvs `unionFVInfo` deflt_fvs, + alts_escs `unionVarSet` deflt_escs + ) + + where + vars_prim_alt (LitAlt lit, _, rhs) + = coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) -> + returnLne ((lit, rhs2), rhs_fvs, rhs_escs) + + vars_alg_alt (DataAlt con, binders, rhs) + = let + -- remove type variables + binders' = filterStgBinders binders + in + extendVarEnvLne [(b, CaseBound) | b <- binders'] $ + coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) -> + let + good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders' ] + -- records whether each param is used in the RHS + in + returnLne ( + (con, binders', good_use_mask, rhs2), + binders' `minusFVBinders` rhs_fvs, + rhs_escs `minusVarSet` mkVarSet binders' + -- ToDo: remove the minusVarSet; + -- since escs won't include any of these binders + ) + vars_alg_alt other = pprPanic "vars_alg_alt" (ppr other) + + vars_deflt Nothing + = returnLne (StgNoDefault, emptyFVInfo, emptyVarSet) + + vars_deflt (Just rhs) + = coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) -> + returnLne (StgBindDefault rhs2, rhs_fvs, rhs_escs) \end{code} -There's not anything interesting we can ASSERT about \tr{var} if it -isn't in the StgEnv. (WDP 94/06) +Lets not only take quite a bit of work, but this is where we convert +then to let-no-escapes, if we wish. + +(Meanwhile, we don't expect to see let-no-escapes...) \begin{code} -stgLookup :: StgEnv -> Id -> StgArg +coreToStgExpr (Let bind body) + = fixLne (\ ~(_, _, _, no_binder_escapes) -> + coreToStgLet no_binder_escapes bind body + ) `thenLne` \ (new_let, fvs, escs, _) -> -stgLookup env var = case (lookupIdEnv env var) of - Nothing -> StgVarArg var - Just atom -> atom + returnLne (new_let, fvs, escs) \end{code} -%************************************************************************ -%* * -\subsection[coreToStg-exprs]{Converting core expressions} -%* * -%************************************************************************ - \begin{code} -coreExprToStg :: StgEnv - -> CoreExpr - -> UniqSM (StgExpr, -- Result - Bag StgBinding) -- Float these to top level +mkStgAlgAlts ty alts deflt + = case alts of + -- Get the tycon from the data con + (dc, _, _, _) : _rest + -> StgAlgAlts (Just (dataConTyCon dc)) alts deflt + + -- Otherwise just do your best + [] -> case splitTyConApp_maybe (repType ty) of + Just (tc,_) | isAlgTyCon tc + -> StgAlgAlts (Just tc) alts deflt + other + -> StgAlgAlts Nothing alts deflt + +mkStgPrimAlts ty alts deflt + = StgPrimAlts (tyConAppTyCon ty) alts deflt \end{code} + +-- --------------------------------------------------------------------------- +-- Applications +-- --------------------------------------------------------------------------- + \begin{code} -coreExprToStg env (Lit lit) - = litToStgArg lit `thenUs` \ (atom, binds) -> - returnUs (StgApp atom [] bOGUS_LVs, binds) +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 (varType 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. + f_arity = case how_bound of + LetBound _ _ arity -> arity + _ -> 0 + + fun_occ + | not_letrec_bound = noBinderInfo -- Uninteresting variable + | f_arity > 0 && f_arity <= n_val_args = 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 + DataConId dc -> StgConApp dc args' + PrimOpId op -> StgOpApp (StgPrimOp op) args' res_ty + FCallId call -> StgOpApp (StgFCallOp call (idUnique f)) args' res_ty + _other -> StgApp f args' + + 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. + ) -coreExprToStg env (Var var) - = returnUs (StgApp (stgLookup env var) [] bOGUS_LVs, emptyBag) -coreExprToStg env (Con con types args) - = mapAndUnzipUs (coreAtomToStg env) args `thenUs` \ (stg_atoms, stg_binds) -> - returnUs (StgCon spec_con stg_atoms bOGUS_LVs, unionManyBags stg_binds) - where - spec_con = mkSpecialisedCon con types -coreExprToStg env (Prim op tys args) - = mapAndUnzipUs (coreAtomToStg env) args `thenUs` \ (stg_atoms, stg_binds) -> - returnUs (StgPrim op stg_atoms bOGUS_LVs, unionManyBags stg_binds) +-- --------------------------------------------------------------------------- +-- Argument lists +-- This is the guy that turns applications into A-normal form +-- --------------------------------------------------------------------------- + +coreToStgArgs :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo) +coreToStgArgs [] + = returnLne ([], emptyFVInfo) + +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 (dataConWrapId con) + StgLit lit -> StgLitArg lit + _ -> pprPanic "coreToStgArgs" (ppr arg) + in + returnLne (stg_arg : stg_args, fvs) + + +-- --------------------------------------------------------------------------- +-- The magic for lets: +-- --------------------------------------------------------------------------- + +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 + +coreToStgLet let_no_escape bind body + = fixLne (\ ~(_, _, _, _, _, _, rec_body_fvs, _, _) -> + + -- 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 emptyLVS) + (vars_bind rec_body_fvs bind) + `thenLne` \ ( bind2, bind_fvs, bind_escs + , bind_lvs, bind_cafs, env_ext) -> + + -- Do the body + extendVarEnvLne env_ext ( + coreToStgExpr body `thenLne` \(body2, body_fvs, body_escs) -> + freeVarsToLiveVars body_fvs `thenLne` \(body_lvs, _) -> + + returnLne (bind2, bind_fvs, bind_escs, bind_lvs, bind_cafs, + body2, body_fvs, body_escs, body_lvs) + ) + + ) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs, bind_cafs, + 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 `minusVarSet` set_of_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) `minusVarSet` set_of_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 + returnLne ( + new_let, + free_in_whole_let, + let_escs, + checked_no_binder_escapes + )) + where + set_of_binders = mkVarSet binders + binders = case bind of + NonRec binder rhs -> [binder] + Rec pairs -> map fst pairs + + mk_binding bind_lvs bind_cafs binder rhs + = (binder, LetBound NotTopLevelBound -- Not top level + live_vars (predictArity rhs) + ) + where + live_vars = if let_no_escape then + (extendVarSet bind_lvs binder, bind_cafs) + else + (unitVarSet binder, emptyVarSet) + + vars_bind :: FreeVarsInfo -- Free var info for body of binding + -> CoreBind + -> LneM (StgBinding, + FreeVarsInfo, + EscVarsSet, -- free vars; escapee vars + StgLiveVars, -- vars live in binding + IdSet, -- CAFs live in binding + [(Id, HowBound)]) -- extension to environment + + + vars_bind body_fvs (NonRec binder rhs) + = coreToStgRhs body_fvs NotTopLevel (binder,rhs) + `thenLne` \ (rhs2, bind_fvs, escs) -> + + freeVarsToLiveVars bind_fvs `thenLne` \ (bind_lvs, bind_cafs) -> + let + env_ext_item = mk_binding bind_lvs bind_cafs binder rhs + in + returnLne (StgNonRec (SRTEntries bind_cafs) binder rhs2, + bind_fvs, escs, bind_lvs, bind_cafs, [env_ext_item]) + + + vars_bind body_fvs (Rec pairs) + = fixLne (\ ~(_, rec_rhs_fvs, _, bind_lvs, bind_cafs, _) -> + let + rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs + binders = map fst pairs + env_ext = [ mk_binding bind_lvs bind_cafs b rhs + | (b,rhs) <- pairs ] + in + extendVarEnvLne env_ext ( + mapAndUnzip3Lne (coreToStgRhs rec_scope_fvs NotTopLevel) pairs + `thenLne` \ (rhss2, fvss, escss) -> + let + bind_fvs = unionFVInfos fvss + escs = unionVarSets escss + in + freeVarsToLiveVars (binders `minusFVBinders` bind_fvs) + `thenLne` \ (bind_lvs, bind_cafs) -> + + returnLne (StgRec (SRTEntries bind_cafs) (binders `zip` rhss2), + bind_fvs, escs, bind_lvs, bind_cafs, 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-type-stuff]{Type application and abstraction} +\subsection{Arity prediction} %* * %************************************************************************ -This type information dies in this Core-to-STG translation. +To avoid yet another knot, we predict the arity of each function from +its Core form, based on the number of visible top-level lambdas. +It should be the same as the arity of the STG RHS! \begin{code} -coreExprToStg env (CoTyLam tyvar expr) = coreExprToStg env expr -coreExprToStg env (CoTyApp expr ty) = coreExprToStg env expr +predictArity :: CoreExpr -> Int +predictArity (Lam x e) + | isTyVar x = predictArity e + | otherwise = 1 + predictArity e +predictArity (Note _ e) + -- Ignore coercions. Top level sccs are removed by the final + -- profiling pass, so we ignore those too. + = predictArity e +predictArity _ = 0 \end{code} + %************************************************************************ %* * -\subsubsection[coreToStg-lambdas]{Lambda abstractions} +\subsection[LNE-monad]{A little monad for this let-no-escaping pass} %* * %************************************************************************ -\begin{code} -coreExprToStg env expr@(Lam _ _) - = coreExprToStg env body `thenUs` \ (stg_body, binds) -> - newStgVar (coreExprType expr) `thenUs` \ var -> - returnUs - (StgLet (StgNonRec var (StgRhsClosure noCostCentre - stgArgOcc - bOGUS_FVs - ReEntrant -- binders is non-empty - binders - stg_body)) - (StgApp (StgVarArg var) [] bOGUS_LVs), - binds) - where - (binders,body) = collect expr +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*. - -- Collect lambda-bindings, discarding type abstractions and applications - collect (Lam x e) = (x:binders, body) where (binders,body) = collect e - collect (CoTyLam _ e) = collect e - collect (CoTyApp e _) = collect e - collect body = ([], body) +\begin{code} +type LneM a = IdEnv HowBound + -> (StgLiveVars, -- vars live in continuation + IdSet) -- cafs live in continuation + -> a + +data HowBound + = ImportBound + | CaseBound + | LambdaBound + | LetBound + TopLevelCafInfo + (StgLiveVars, IdSet) -- (Live vars, Live CAFs)... see notes below + Arity -- its arity (local Ids don't have arity info at this point) + +isLetBound (LetBound _ _ _) = True +isLetBound other = False \end{code} -%************************************************************************ -%* * -\subsubsection[coreToStg-applications]{Applications} -%* * -%************************************************************************ +For a let(rec)-bound variable, x, we record StgLiveVars, the set of +variables that 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 in the LetBound constructor; x itself +*is* included. + +The set of live variables is guaranteed ot have no further let-no-escaped +variables in it. +The std monad functions: \begin{code} -coreExprToStg env expr@(App _ _) - = -- Deal with the arguments - mapAndUnzipUs (coreAtomToStg env) args `thenUs` \ (stg_args, arg_binds) -> - - -- Now deal with the function - case fun of - Var fun_id -> returnUs (StgApp (stgLookup env fun_id) stg_args bOGUS_LVs, - unionManyBags arg_binds) - - other -> -- A non-variable applied to things; better let-bind it. - newStgVar (coreExprType fun) `thenUs` \ fun_id -> - coreExprToStg env fun `thenUs` \ (stg_fun, fun_binds) -> - 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), - unionManyBags arg_binds `unionBags` - fun_binds) - where - (fun,args) = collect_args expr [] +initLne :: IdEnv HowBound -> LneM a -> a +initLne env m = m env emptyLVS - -- Collect arguments, discarding type abstractions and applications - collect_args (App fun arg) args = collect_args fun (arg:args) - collect_args (CoTyLam _ e) args = collect_args e args - collect_args (CoTyApp e _) args = collect_args e args - collect_args fun args = (fun, args) -\end{code} +emptyLVS = (emptyVarSet,emptyVarSet) -%************************************************************************ -%* * -\subsubsection[coreToStg-cases]{Case expressions} -%* * -%************************************************************************ +{-# INLINE thenLne #-} +{-# INLINE returnLne #-} -At this point, we *mangle* cases involving fork# and par# in the -discriminant. The original templates for these primops (see -@PrelVals.lhs@) constructed case expressions with boolean results -solely to fool the strictness analyzer, the simplifier, and anyone -else who might want to fool with the evaluation order. Now, we -believe that once the translation to STG code is performed, our -evaluation order is safe. Therefore, we convert expressions of the -form: +returnLne :: a -> LneM a +returnLne e env lvs_cont = e - case par# e of - True -> rhs - False -> parError# +thenLne :: LneM a -> (a -> LneM b) -> LneM b +thenLne m k env lvs_cont + = k (m env lvs_cont) env lvs_cont -to +mapLne :: (a -> LneM b) -> [a] -> LneM [b] +mapLne f [] = returnLne [] +mapLne f (x:xs) + = f x `thenLne` \ r -> + mapLne f xs `thenLne` \ rs -> + returnLne (r:rs) - case par# e of - _ -> rhs +mapAndUnzipLne :: (a -> LneM (b,c)) -> [a] -> LneM ([b],[c]) -\begin{code} +mapAndUnzipLne f [] = returnLne ([],[]) +mapAndUnzipLne f (x:xs) + = f x `thenLne` \ (r1, r2) -> + mapAndUnzipLne f xs `thenLne` \ (rs1, rs2) -> + returnLne (r1:rs1, r2:rs2) -coreExprToStg env (Case discrim@(Prim op tys args) alts) - | funnyParallelOp op = - getUnique `thenUs` \ uniq -> - coreExprToStg env discrim `thenUs` \ (stg_discrim, discrim_binds) -> - alts_to_stg alts `thenUs` \ (stg_alts, alts_binds) -> - returnUs ( - StgCase stg_discrim - bOGUS_LVs - bOGUS_LVs - uniq - stg_alts, - discrim_binds `unionBags` alts_binds - ) - where - funnyParallelOp SeqOp = True - funnyParallelOp ParOp = True - funnyParallelOp ForkOp = True - funnyParallelOp _ = False +mapAndUnzip3Lne :: (a -> LneM (b,c,d)) -> [a] -> LneM ([b],[c],[d]) - discrim_ty = coreExprType discrim +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) - alts_to_stg (PrimAlts _ (BindDefault binder rhs)) - = coreExprToStg env rhs `thenUs` \ (stg_rhs, rhs_binds) -> - let - stg_deflt = StgBindDefault binder False stg_rhs - in - returnUs (StgPrimAlts discrim_ty [] stg_deflt, rhs_binds) - --- OK, back to real life... - -coreExprToStg env (Case discrim alts) - = coreExprToStg env discrim `thenUs` \ (stg_discrim, discrim_binds) -> - alts_to_stg discrim alts `thenUs` \ (stg_alts, alts_binds) -> - getUnique `thenUs` \ uniq -> - returnUs ( - StgCase stg_discrim - bOGUS_LVs - bOGUS_LVs - uniq - stg_alts, - discrim_binds `unionBags` alts_binds - ) +fixLne :: (a -> LneM a) -> LneM a +fixLne expr env lvs_cont + = result where - discrim_ty = coreExprType discrim - (_, discrim_ty_args, _) = getAppDataTyCon discrim_ty - - alts_to_stg discrim (AlgAlts alts deflt) - = default_to_stg discrim deflt `thenUs` \ (stg_deflt, deflt_binds) -> - mapAndUnzipUs boxed_alt_to_stg alts `thenUs` \ (stg_alts, alts_binds) -> - returnUs (StgAlgAlts discrim_ty stg_alts stg_deflt, - deflt_binds `unionBags` unionManyBags alts_binds) - where - boxed_alt_to_stg (con, bs, rhs) - = coreExprToStg env rhs `thenUs` \ (stg_rhs, rhs_binds) -> - returnUs ((spec_con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs), - rhs_binds) - where - spec_con = mkSpecialisedCon con discrim_ty_args - - alts_to_stg discrim (PrimAlts alts deflt) - = default_to_stg discrim deflt `thenUs` \ (stg_deflt,deflt_binds) -> - mapAndUnzipUs unboxed_alt_to_stg alts `thenUs` \ (stg_alts, alts_binds) -> - returnUs (StgPrimAlts discrim_ty stg_alts stg_deflt, - deflt_binds `unionBags` unionManyBags alts_binds) - where - unboxed_alt_to_stg (lit, rhs) - = coreExprToStg env rhs `thenUs` \ (stg_rhs, rhs_binds) -> - returnUs ((lit, stg_rhs), rhs_binds) + result = expr result env lvs_cont +\end{code} - default_to_stg discrim NoDefault - = returnUs (StgNoDefault, emptyBag) +Functions specific to this monad: - default_to_stg discrim (BindDefault binder rhs) - = coreExprToStg new_env rhs `thenUs` \ (stg_rhs, rhs_binds) -> - returnUs (StgBindDefault binder True{-used? no it is lying-} stg_rhs, - rhs_binds) - where - -- - -- We convert case x of {...; x' -> ...x'...} - -- to - -- case x of {...; _ -> ...x... } - -- - -- See notes in SimplCase.lhs, near simplDefault for the reasoning. - -- It's quite easily done: simply extend the environment to bind the - -- default binder to the scrutinee. - -- - new_env = case discrim of - Var v -> addOneToIdEnv env binder (stgLookup env v) - other -> env +\begin{code} +getVarsLiveInCont :: LneM (StgLiveVars, IdSet) +getVarsLiveInCont env lvs_cont = lvs_cont + +setVarsLiveInCont :: (StgLiveVars,IdSet) -> 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 ( + case (lookupVarEnv env v) of + Just xx -> xx + Nothing -> ImportBound + ) 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. + +freeVarsToLiveVars :: FreeVarsInfo -> LneM (StgLiveVars, IdSet) +freeVarsToLiveVars fvs env live_in_cont + = returnLne (lvs, cafs) env live_in_cont + where + (lvs_cont, cafs_cont) = live_in_cont -- not a strict pattern match! + (local, global) = partition isLocalId (allFreeIds fvs) + + (lvs_from_fvs, caf_extras) = unzip (map do_one local) + + lvs = unionVarSets lvs_from_fvs + `unionVarSet` lvs_cont + + cafs = mkVarSet (filter is_caf_one global) + `unionVarSet` (unionVarSets caf_extras) + `unionVarSet` cafs_cont + + do_one v + = case (lookupVarEnv env v) of + Just (LetBound _ (lvs,cafs) _) -> (extendVarSet lvs v, cafs) + Just _ -> (unitVarSet v, emptyVarSet) + Nothing -> pprPanic "lookupLiveVarsForSet/do_one:" (ppr v) + + is_caf_one v + = case lookupVarEnv env v of + Just (LetBound TopLevelHasCafs (lvs,_) _) -> + ASSERT( isEmptyVarSet lvs ) True + Just (LetBound _ _ _) -> False + _otherwise -> mayHaveCafRefs (idCafInfo v) \end{code} %************************************************************************ %* * -\subsubsection[coreToStg-let(rec)]{Let and letrec expressions} +\subsection[Free-var info]{Free variable information} %* * %************************************************************************ \begin{code} -coreExprToStg env (Let bind body) - = coreBindToStg env bind `thenUs` \ (stg_binds, new_env, float_binds1) -> - coreExprToStg new_env body `thenUs` \ (stg_body, float_binds2) -> - returnUs (mkStgLets stg_binds stg_body, float_binds1 `unionBags` float_binds2) -\end{code} +type FreeVarsInfo = VarEnv (Var, TopLevelCafInfo, StgBinderInfo) + -- 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 +data TopLevelCafInfo + = NotTopLevelBound + | TopLevelNoCafs + | TopLevelHasCafs + deriving Eq -%************************************************************************ -%* * -\subsubsection[coreToStg-scc]{SCC expressions} -%* * -%************************************************************************ +type EscVarsSet = IdSet +\end{code} -Covert core @scc@ expression directly to STG @scc@ expression. \begin{code} -coreExprToStg env (SCC cc expr) - = coreExprToStg env expr `thenUs` \ (stg_expr, binds) -> - returnUs (StgSCC (coreExprType expr) cc stg_expr, binds) +emptyFVInfo :: FreeVarsInfo +emptyFVInfo = emptyVarEnv + +singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo +singletonFVInfo id ImportBound info + | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, TopLevelHasCafs, info) + | otherwise = emptyVarEnv +singletonFVInfo id (LetBound top_level _ _) info + = unitVarEnv id (id, top_level, info) +singletonFVInfo id other info + = unitVarEnv id (id, NotTopLevelBound, info) + +tyvarFVInfo :: TyVarSet -> FreeVarsInfo +tyvarFVInfo tvs = foldVarSet add emptyFVInfo tvs + where + add tv fvs = extendVarEnv fvs tv (tv, NotTopLevelBound, noBinderInfo) + +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 + | isExternallyVisibleName (idName id) = noBinderInfo + | otherwise = case lookupVarEnv fvs id of + Nothing -> noBinderInfo + Just (_,_,info) -> info + +allFreeIds :: FreeVarsInfo -> [Id] -- Non-top-level things only +allFreeIds fvs = [id | (id,_,_) <- 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,NotTopLevelBound,_) <- rngVarEnv fvs] + +getFVSet :: FreeVarsInfo -> VarSet +getFVSet fvs = mkVarSet (getFVs fvs) + +plusFVInfo (id1,top1,info1) (id2,top2,info2) + = ASSERT (id1 == id2 && top1 == top2) + (id1, top1, combineStgBinderInfo info1 info2) \end{code} +Misc. +\begin{code} +filterStgBinders :: [Var] -> [Var] +filterStgBinders bndrs + | opt_RuntimeTypes = bndrs + | otherwise = filter isId bndrs +\end{code} + + +\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} %************************************************************************ %* * -\subsection[coreToStg-misc]{Miscellaneous helping functions} +\subsection{Figuring out CafInfo for an expression} %* * %************************************************************************ -Utilities. +hasCafRefs decides whether a top-level closure can point into the dynamic heap. +We mark such things as `MayHaveCafRefs' because this information is +used to decide whether a particular closure needs to be referenced +in an SRT or not. -Invent a fresh @Id@: -\begin{code} -newStgVar :: Type -> UniqSM Id -newStgVar ty - = getUnique `thenUs` \ uniq -> - returnUs (mkSysLocal SLIT("stg") uniq ty mkUnknownSrcLoc) -\end{code} +There are two reasons for setting MayHaveCafRefs: + a) The RHS is a CAF: a top-level updatable thunk. + b) The RHS refers to something that MayHaveCafRefs -\begin{code} -mkStgLets :: [StgBinding] - -> StgExpr -- body of let - -> StgExpr +Possible improvement: In an effort to keep the number of CAFs (and +hence the size of the SRTs) down, we could also look at the expression and +decide whether it requires a small bounded amount of heap, so we can ignore +it as a CAF. In these cases however, we would need to use an additional +CAF list to keep track of non-collectable CAFs. -mkStgLets binds body = foldr StgLet body binds +\begin{code} +hasCafRefs :: IdEnv HowBound -> CoreExpr -> CafInfo +-- Only called for the RHS of top-level lets +hasCafRefss :: IdEnv HowBound -> [CoreExpr] -> CafInfo + -- predicate returns True for a given Id if we look at this Id when + -- calculating the result. Used to *avoid* looking at the CafInfo + -- field for an Id that is part of the current recursive group. + +hasCafRefs p expr + | isCAF expr || isFastTrue (cafRefs p expr) = MayHaveCafRefs + | otherwise = NoCafRefs + + -- used for recursive groups. The whole group is set to + -- "MayHaveCafRefs" if at least one of the group is a CAF or + -- refers to any CAFs. +hasCafRefss p exprs + | any isCAF exprs || isFastTrue (cafRefss p exprs) = MayHaveCafRefs + | otherwise = NoCafRefs + +-- cafRefs compiles to beautiful code :) + +cafRefs p (Var id) + | isLocalId id = fastBool False + | otherwise = + case lookupVarEnv p id of + Just (LetBound TopLevelHasCafs _ _) -> fastBool True + Just (LetBound _ _ _) -> fastBool False + Nothing -> fastBool (cgMayHaveCafRefs (idCgInfo id)) -- imported Ids + +cafRefs p (Lit l) = fastBool False +cafRefs p (App f a) = fastOr (cafRefs p f) (cafRefs p) a +cafRefs p (Lam x e) = cafRefs p e +cafRefs p (Let b e) = fastOr (cafRefss p (rhssOfBind b)) (cafRefs p) e +cafRefs p (Case e bndr alts) = fastOr (cafRefs p e) + (cafRefss p) (rhssOfAlts alts) +cafRefs p (Note n e) = cafRefs p e +cafRefs p (Type t) = fastBool False + +cafRefss p [] = fastBool False +cafRefss p (e:es) = fastOr (cafRefs p e) (cafRefss p) es + +-- hack for lazy-or over FastBool. +fastOr a f x = fastBool (isFastTrue a || isFastTrue (f x)) + +isCAF :: CoreExpr -> Bool +-- Only called for the RHS of top-level lets +isCAF e = not (rhsIsNonUpd e) + {- ToDo: check type for onceness, i.e. non-updatable thunks? -} + + +rhsIsNonUpd :: CoreExpr -> Bool + -- True => Value-lambda, constructor, PAP + -- This is a bit like CoreUtils.exprIsValue, with the following differences: + -- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC) + -- + -- b) (C x xs), where C is a contructors is updatable if the application is + -- dynamic: see isDynConApp + -- + -- c) don't look through unfolding of f in (f x). I'm suspicious of this one + +-- This function has to line up with what the update flag +-- for the StgRhs gets set to in mkStgRhs (above) +-- +-- When opt_RuntimeTypes is on, we keep type lambdas and treat +-- them as making the RHS re-entrant (non-updatable). +rhsIsNonUpd (Lam b e) = isRuntimeVar b || rhsIsNonUpd e +rhsIsNonUpd (Note (SCC _) e) = False +rhsIsNonUpd (Note _ e) = rhsIsNonUpd e +rhsIsNonUpd other_expr + = go other_expr 0 [] + where + go (Var f) n_args args = idAppIsNonUpd f n_args args + + go (App f a) n_args args + | isTypeArg a = go f n_args args + | otherwise = go f (n_args + 1) (a:args) + + go (Note (SCC _) f) n_args args = False + go (Note _ f) n_args args = go f n_args args + + go other n_args args = False + +idAppIsNonUpd :: Id -> Int -> [CoreExpr] -> Bool +idAppIsNonUpd id n_val_args args + | Just con <- isDataConId_maybe id = not (isCrossDllConApp con args) + | otherwise = n_val_args < idArity id + +isCrossDllConApp :: DataCon -> [CoreExpr] -> Bool +isCrossDllConApp con args = isDllName (dataConName con) || any isCrossDllArg args +-- Top-level constructor applications can usually be allocated +-- statically, but they can't if +-- a) the constructor, or any of the arguments, come from another DLL +-- b) any of the arguments are LitLits +-- (because we can't refer to static labels in other DLLs). +-- If this happens we simply make the RHS into an updatable thunk, +-- and 'exectute' it rather than allocating it statically. +-- All this should match the decision in (see CoreToStg.coreToStgRhs) + + +isCrossDllArg :: CoreExpr -> Bool +-- True if somewhere in the expression there's a cross-DLL reference +isCrossDllArg (Type _) = False +isCrossDllArg (Var v) = isDllName (idName v) +isCrossDllArg (Note _ e) = isCrossDllArg e +isCrossDllArg (Lit lit) = isLitLitLit lit +isCrossDllArg (App e1 e2) = isCrossDllArg e1 || isCrossDllArg e2 -- must be a type app +isCrossDllArg (Lam v e) = isCrossDllArg e -- must be a type lam \end{code}