X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FstgSyn%2FCoreToStg.lhs;h=da7f0cba75ed5b1ead7d517a88f39775178496f9;hb=f05dbea1695542772dc917f33d24525c05a8e09d;hp=4fda0268f628836c6f8bbf7d7f3530356cf7ed93;hpb=08553288a587bbef94f690f90f84818e116759da;p=ghc-hetmet.git diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 4fda026..da7f0cb 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -1,436 +1,956 @@ % -% (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} -%* * -%************************************************************************ +\section[CoreToStg]{Converts Core to STG Syntax} -Convert a @CoreSyntax@ program to a @StgSyntax@ program. +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 ) 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, - externallyVisibleId, - - nullIdEnv, addOneToIdEnv, lookupIdEnv, growIdEnvList, - SYN_IE(IdEnv), GenId{-instance NamedThing-}, SYN_IE(Id) - ) -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 ( getAppDataTyConExpandingDicts, SYN_IE(Type) ) -import TysWiredIn ( stringTy ) -import Unique ( integerTyConKey, ratioTyConKey, Unique{-instance Eq-} ) -import UniqSupply -- all of it, really -import Util ( zipLazy, panic, assertPanic{-, pprTrace ToDo:rm-} ) - -isLeakFreeType x y = False -- safe option; ToDo +import CoreSyn +import CoreFVs +import CoreUtils +import SimplUtils +import StgSyn + +import Type +import TyCon ( isAlgTyCon ) +import Id +import IdInfo +import DataCon +import CostCentre ( noCCS ) +import VarSet +import VarEnv +import DataCon ( dataConWrapId ) +import IdInfo ( OccInfo(..) ) +import PrimOp ( PrimOp(..), ccallMayGC ) +import TysPrim ( foreignObjPrimTyCon ) +import Maybes ( maybeToBool, orElse ) +import Name ( getOccName ) +import Module ( Module ) +import OccName ( occNameUserString ) +import BasicTypes ( TopLevelFlag(..), isNotTopLevel ) +import CmdLineOpts ( DynFlags ) +import Outputable + +infixr 9 `thenLne`, `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. +%************************************************************************ +%* * +\subsection[binds-StgVarInfo]{Setting variable info: top-level, binds, RHSs} +%* * +%************************************************************************ -The business of this pass is to convert Core to Stg. On the way: +\begin{code} +coreToStg :: DynFlags -> Module -> [CoreBind] -> IO [StgBinding] +coreToStg dflags this_mod pgm + = return (fst (initLne (coreTopBindsToStg pgm))) + +coreExprToStg :: CoreExpr -> StgExpr +coreExprToStg expr + = new_expr where (new_expr,_,_) = initLne (coreToStgExpr expr) + +-- For top-level guys, we basically aren't worried about this +-- live-variable stuff; we do need to keep adding to the environment +-- as we step through the bindings (using @extendVarEnv@). + +coreTopBindsToStg :: [CoreBind] -> LneM ([StgBinding], FreeVarsInfo) + +coreTopBindsToStg [] = returnLne ([], emptyFVInfo) +coreTopBindsToStg (bind:binds) + = let + binders = bindersOf bind + env_extension = binders `zip` repeat how_bound + how_bound = LetrecBound True {- top level -} + emptyVarSet + in + + extendVarEnvLne env_extension ( + coreTopBindsToStg binds `thenLne` \ (binds', fv_binds) -> + coreTopBindToStg binders fv_binds bind `thenLne` \ (bind', fv_bind) -> + returnLne ( + (bind' : binds'), + (fv_binds `unionFVInfo` fv_bind) `minusFVBinders` binders + ) + ) + + +coreTopBindToStg + :: [Id] -- New binders (with correct arity) + -> FreeVarsInfo -- Info about the body + -> CoreBind + -> LneM (StgBinding, FreeVarsInfo) + +coreTopBindToStg [binder] body_fvs (NonRec _ rhs) + = coreToStgRhs body_fvs TopLevel (binder,rhs) `thenLne` \ (rhs2, fvs, _) -> + returnLne (StgNonRec binder rhs2, fvs) + +coreTopBindToStg binders body_fvs (Rec pairs) + = fixLne (\ ~(_, rec_rhs_fvs) -> + let scope_fvs = unionFVInfo body_fvs rec_rhs_fvs + in + mapAndUnzip3Lne (coreToStgRhs scope_fvs TopLevel) pairs + `thenLne` \ (rhss2, fvss, _) -> + let fvs = unionFVInfos fvss + in + returnLne (StgRec (binders `zip` rhss2), fvs) + ) +\end{code} -* We discard type lambdas and applications. In so doing we discard - "trivial" bindings such as - x = y t1 t2 - where t1, t2 are types +\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) -> + case new_rhs of + + StgLam _ bndrs body + -> let binder_info = lookupFVInfo scope_fv_info binder + in returnLne (StgRhsClosure noCCS + binder_info + noSRT + (getFVs rhs_fvs) + ReEntrant + bndrs + body, + rhs_fvs, rhs_escs) + + StgConApp con args + | isNotTopLevel top || not (isDllConApp con args) + -> returnLne (StgRhsCon noCCS con args, rhs_fvs, rhs_escs) + + _other_expr + -> let binder_info = lookupFVInfo scope_fv_info binder + in returnLne (StgRhsClosure noCCS + binder_info + noSRT + (getFVs rhs_fvs) + (updatable [] new_rhs) + [] + new_rhs, + rhs_fvs, rhs_escs + ) + +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} -* We don't pin on correct arities any more, because they can be mucked up - by the lambda lifter. In particular, the lambda lifter can take a local - letrec-bound variable and make it a lambda argument, which shouldn't have - an arity. So SetStgVarInfo sets arities now. +Detect thunks which will reduce immediately to PAPs, and make them +non-updatable. This has several advantages: -* 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. + - the non-updatable thunk behaves exactly like the PAP, -[Quite a bit of stuff that used to be here has moved - to tidyCorePgm (SimplCore.lhs) SLPJ Nov 96] + - 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. -%************************************************************************ -%* * -\subsection[coreToStg-programs]{Converting a core program and core bindings} -%* * -%************************************************************************ + - 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. -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}. +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} -type StgEnv = IdEnv StgArg +isPAP (StgApp f args) = idArity f > length args +isPAP _ = False + +-- --------------------------------------------------------------------------- +-- Atoms +-- --------------------------------------------------------------------------- + +coreToStgAtoms :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo) +coreToStgAtoms atoms + = let val_atoms = filter isValArg atoms in + mapAndUnzipLne coreToStgAtom val_atoms `thenLne` \ (args', fvs_lists) -> + returnLne (args', unionFVInfos fvs_lists) + where + coreToStgAtom e + = coreToStgExpr e `thenLne` \ (expr, fvs, escs) -> + case expr of + StgApp v [] -> returnLne (StgVarArg v, fvs) + StgConApp con [] -> returnLne (StgVarArg (dataConWrapId con), fvs) + StgLit lit -> returnLne (StgLitArg lit, fvs) + _ -> pprPanic "coreToStgAtom" (ppr expr) + +-- --------------------------------------------------------------------------- +-- Expressions +-- --------------------------------------------------------------------------- + +{- +@varsExpr@ carries in a monad-ised environment, which binds each +let(rec) variable (ie non top level, not imported, not lambda bound, +not case-alternative bound) to: + - its STG arity, and + - its set of live vars. +For normal variables the set of live vars is just the variable +itself. For let-no-escaped variables, the set of live vars is the set +live at the moment the variable is entered. The set is guaranteed to +have no further let-no-escaped vars in it. +-} + +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} -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. +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} -bOGUS_LVs :: StgLiveVars -bOGUS_LVs = panic "bOGUS_LVs" -- emptyUniqSet (used when pprTracing) +coreToStgExpr (Lit l) = returnLne (StgLit l, emptyFVInfo, emptyVarSet) -bOGUS_FVs :: [Id] -bOGUS_FVs = panic "bOGUS_FVs" -- [] (ditto) -\end{code} +coreToStgExpr (Var v) + = coreToStgApp Nothing v [] -\begin{code} -topCoreBindsToStg :: UniqSupply -- name supply - -> [CoreBinding] -- input - -> [StgBinding] -- output +coreToStgExpr expr@(App _ _) + = let (f, args) = myCollectArgs expr + in + coreToStgApp Nothing (shouldBeVar f) args -topCoreBindsToStg us core_binds - = initUs us (coreBindsToStg nullIdEnv core_binds) - where - coreBindsToStg :: StgEnv -> [CoreBinding] -> UniqSM [StgBinding] +coreToStgExpr expr@(Lam _ _) + = let (args, body) = myCollectBinders expr + args' = filter isId args + in + extendVarEnvLne [ (a, LambdaBound) | a <- args' ] $ + coreToStgExpr body `thenLne` \ (body, body_fvs, body_escs) -> + let + set_of_args = mkVarSet args' + fvs = body_fvs `minusFVBinders` args' + escs = body_escs `minusVarSet` set_of_args + in + if null args' + then returnLne (body, fvs, escs) + else returnLne (StgLam (exprType expr) args' body, fvs, escs) - 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) -\end{code} +coreToStgExpr (Note (SCC cc) expr) + = coreToStgExpr expr `thenLne` ( \ (expr2, fvs, escs) -> + returnLne (StgSCC cc expr2, fvs, escs) ) -%************************************************************************ -%* * -\subsection[coreToStg-binds]{Converting bindings} -%* * -%************************************************************************ +coreToStgExpr (Note other_note expr) + = coreToStgExpr expr -\begin{code} -coreBindToStg :: StgEnv - -> CoreBinding - -> UniqSM ([StgBinding], -- Empty or singleton - StgEnv) -- Floats -coreBindToStg env (NonRec binder rhs) - = coreRhsToStg env rhs `thenUs` \ stg_rhs -> +-- Cases require a little more real work. + +coreToStgExpr (Case scrut bndr alts) + = getVarsLiveInCont `thenLne` \ live_in_cont -> + extendVarEnvLne [(bndr, CaseBound)] $ + vars_alts (findDefault alts) `thenLne` \ (alts2, alts_fvs, alts_escs) -> + lookupLiveVarsForSet alts_fvs `thenLne` \ alts_lvs -> let - -- Binds to return if RHS is trivial - triv_binds | externallyVisibleId binder = [StgNonRec binder stg_rhs] -- Retain it - | otherwise = [] -- Discard it + -- determine whether the default binder is dead or not + bndr'= if (bndr `elementOfFVInfo` alts_fvs) + then bndr `setIdOccInfo` NoOccInfo + else bndr `setIdOccInfo` IAmDead + + -- for a _ccall_GC_, some of the *arguments* need to live across the + -- call (see findLiveArgs comments.), so we annotate them as being live + -- in the alts to achieve the desired effect. + mb_live_across_case = + case scrut of + -- ToDo: Notes? + e@(App _ _) | (Var v, args) <- myCollectArgs e, + PrimOpId (CCallOp ccall) <- idFlavour v, + ccallMayGC ccall + -> Just (filterVarSet isForeignObjArg (exprFreeVars e)) + _ -> Nothing + + -- Don't consider the default binder as being 'live in alts', + -- since this is from the point of view of the case expr, where + -- the default binder is not free. + live_in_alts = orElse (FMAP unionVarSet mb_live_across_case) id $ + live_in_cont `unionVarSet` + (alts_lvs `minusVarSet` unitVarSet bndr) 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 stg_rhs], env) - -coreBindToStg env (Rec pairs) - = -- NB: *** WE DO NOT CHECK FOR TRIV_BINDS in REC BIND **** - -- (possibly ToDo) + -- we tell the scrutinee that everything live in the alts + -- is live in it, too. + setVarsLiveInCont live_in_alts ( + coreToStgExpr scrut + ) `thenLne` \ (scrut2, scrut_fvs, scrut_escs) -> + + lookupLiveVarsForSet scrut_fvs `thenLne` \ scrut_lvs -> let - (binders, rhss) = unzip pairs + live_in_whole_case = live_in_alts `unionVarSet` scrut_lvs in - mapUs (coreRhsToStg env) rhss `thenUs` \ stg_rhss -> - returnUs ([StgRec (binders `zip` stg_rhss)], env) -\end{code} + returnLne ( + mkStgCase scrut2 live_in_whole_case live_in_alts bndr' noSRT alts2, + (scrut_fvs `unionFVInfo` alts_fvs) `minusFVBinders` [bndr], + (alts_escs `minusVarSet` unitVarSet bndr) `unionVarSet` getFVSet scrut_fvs + -- You might think we should have scrut_escs, not (getFVSet scrut_fvs), + -- but actually we can't call, and then return from, a let-no-escape thing. + ) + where + 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' = filter isId 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), + rhs_fvs `minusFVBinders` binders', + rhs_escs `minusVarSet` mkVarSet binders' + -- ToDo: remove the minusVarSet; + -- since escs won't include any of these binders + ) + + 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) -%************************************************************************ -%* * -\subsection[coreToStg-rhss]{Converting right hand sides} -%* * -%************************************************************************ +\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. + +(Meanwhile, we don't expect to see let-no-escapes...) \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 +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} +If we've got a case containing a _ccall_GC_ primop, we need to +ensure that the arguments are kept live for the duration of the +call. This only an issue -%************************************************************************ -%* * -\subsection[coreToStg-atoms{Converting atoms} -%* * -%************************************************************************ +\begin{code} +isForeignObjArg :: Id -> Bool +isForeignObjArg x = isId x && isForeignObjPrimTy (idType x) + +isForeignObjPrimTy ty + = case splitTyConApp_maybe ty of + Just (tycon, _) -> tycon == foreignObjPrimTyCon + Nothing -> False +\end{code} \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) +mkStgCase scrut@(StgPrimApp ParOp _ _) lvs1 lvs2 bndr srt + (StgPrimAlts tycon _ deflt@(StgBindDefault _)) + = StgCase scrut lvs1 lvs2 bndr srt (StgPrimAlts tycon [] deflt) + +mkStgCase (StgPrimApp SeqOp [scrut] _) lvs1 lvs2 bndr srt + (StgPrimAlts _ _ deflt@(StgBindDefault rhs)) + = StgCase scrut_expr lvs1 lvs2 new_bndr srt new_alts where - (trest,vrest) = coreArgsToStg env as + new_alts + | isUnLiftedType scrut_ty = WARN( True, text "mkStgCase" ) + mkStgPrimAlts scrut_ty [] deflt + | otherwise = mkStgAlgAlts scrut_ty [] deflt + + scrut_ty = stgArgType scrut + new_bndr = setIdType bndr scrut_ty + -- NB: SeqOp :: forall a. a -> Int# + -- So bndr has type Int# + -- But now we are going to scrutinise the SeqOp's argument directly, + -- so we must change the type of the case binder to match that + -- of the argument expression e. + + scrut_expr = case scrut of + StgVarArg v -> StgApp v [] + -- Others should not happen because + -- seq of a value should have disappeared + StgLitArg l -> WARN( True, text "seq on" <+> ppr l ) StgLit l + +mkStgCase scrut lvs1 lvs2 bndr srt alts + = StgCase scrut lvs1 lvs2 bndr srt alts + + +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} -%************************************************************************ -%* * -\subsection[coreToStg-exprs]{Converting core expressions} -%* * -%************************************************************************ - +Applications: \begin{code} -coreExprToStg :: StgEnv -> CoreExpr -> UniqSM StgExpr +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 + = getVarsLiveInCont `thenLne` \ live_in_cont -> + coreToStgAtoms args `thenLne` \ (args', args_fvs) -> + lookupVarLne f `thenLne` \ how_bound -> -coreExprToStg env (Lit lit) - = returnUs (StgApp (StgLitArg lit) [] bOGUS_LVs) - -coreExprToStg env (Var var) - = returnUs (mk_app (stgLookup env var) []) + let + n_args = length args + not_letrec_bound = not (isLetrecBound how_bound) + f_arity = idArity f + fun_fvs = singletonFVInfo f how_bound fun_occ + + fun_occ + | not_letrec_bound = NoStgBinderInfo -- Uninteresting variable + + -- Otherwise it is letrec bound; must have its arity + | n_args == 0 = stgFakeFunAppOcc -- Function Application + -- with no arguments. + -- used by the lambda lifter. + | f_arity > n_args = stgUnsatOcc -- Unsaturated + + | f_arity == n_args && + maybeToBool maybe_thunk_body -- Exactly saturated, + -- and rhs of thunk + = case maybe_thunk_body of + Just Updatable -> stgStdHeapOcc + Just SingleEntry -> stgNoUpdHeapOcc + other -> panic "coreToStgApp" + + | otherwise = stgNormalOcc + -- Record only that it occurs free + + myself = unitVarSet f + + fun_escs | not_letrec_bound = emptyVarSet + -- Only letrec-bound escapees are interesting + | f_arity == n_args = emptyVarSet + -- Function doesn't escape + | otherwise = myself + -- Inexact application; it does escape + + -- At the moment of the call: + + -- 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. + + -- XXX not needed? + -- live_at_call + -- = live_in_cont `unionVarSet` case how_bound of + -- LetrecBound _ lvs -> lvs `minusVarSet` myself + -- other -> emptyVarSet + + app = case idFlavour f of + DataConId dc -> StgConApp dc args' + PrimOpId op -> StgPrimApp op args' (exprType (mkApps (Var f) args)) + _other -> StgApp f args' -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) + 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 (Prim op args) - = let - (types, stg_atoms) = coreArgsToStg env args +-- --------------------------------------------------------------------------- +-- 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_bind_lvs, _, 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 emptyVarSet) + (vars_bind rec_bind_lvs rec_body_fvs bind) + `thenLne` \ (bind2, bind_fvs, bind_escs, env_ext) -> + + -- The live variables of this binding are the ones which are live + -- by virtue of being accessible via the free vars of the binding (lvs_from_fvs) + -- together with the live_in_cont ones + lookupLiveVarsForSet (bind_fvs `minusFVBinders` binders) + `thenLne` \ lvs_from_fvs -> + let + bind_lvs = lvs_from_fvs `unionVarSet` live_in_cont + in + + -- bind_fvs and bind_escs still include the binders of the let(rec) + -- but bind_lvs does not + + -- Do the body + extendVarEnvLne env_ext ( + coreToStgExpr body `thenLne` \ (body2, body_fvs, body_escs) -> + lookupLiveVarsForSet body_fvs `thenLne` \ body_lvs -> + + returnLne (bind2, bind_fvs, bind_escs, bind_lvs, + body2, body_fvs, body_escs, body_lvs) + + )) `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 + = (bind_fvs `unionFVInfo` body_fvs) `minusFVBinders` binders + + 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 - returnUs (StgPrim op stg_atoms bOGUS_LVs) + 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 binder + = (binder, LetrecBound False -- Not top level + live_vars + ) + where + live_vars = if let_no_escape then + extendVarSet bind_lvs binder + else + unitVarSet binder + + vars_bind :: StgLiveVars + -> FreeVarsInfo -- Free var info for body of binding + -> CoreBind + -> LneM (StgBinding, + FreeVarsInfo, EscVarsSet, -- free vars; escapee vars + [(Id, HowBound)]) + -- extension to environment + + vars_bind rec_bind_lvs rec_body_fvs (NonRec binder rhs) + = coreToStgRhs rec_body_fvs NotTopLevel (binder,rhs) + `thenLne` \ (rhs2, fvs, escs) -> + let + env_ext_item@(binder', _) = mk_binding rec_bind_lvs binder + in + returnLne (StgNonRec binder' rhs2, fvs, escs, [env_ext_item]) + + vars_bind rec_bind_lvs rec_body_fvs (Rec pairs) + = let + binders = map fst pairs + env_ext = map (mk_binding rec_bind_lvs) binders + in + extendVarEnvLne env_ext ( + fixLne (\ ~(_, rec_rhs_fvs, _, _) -> + let + rec_scope_fvs = unionFVInfo rec_body_fvs rec_rhs_fvs + in + mapAndUnzip3Lne (coreToStgRhs rec_scope_fvs NotTopLevel) pairs + `thenLne` \ (rhss2, fvss, escss) -> + let + fvs = unionFVInfos fvss + escs = unionVarSets escss + in + returnLne (StgRec (binders `zip` rhss2), fvs, escs, env_ext) + )) + +is_join_var :: Id -> Bool +-- A hack (used only for compiler debuggging) to tell if +-- a variable started life as a join point ($j) +is_join_var j = occNameUserString (getOccName j) == "$j" \end{code} %************************************************************************ %* * -\subsubsection[coreToStg-lambdas]{Lambda abstractions} +\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 {\em down}. + \begin{code} -coreExprToStg env expr@(Lam _ _) - = let - (_,_, binders, body) = collectBinders expr - in - coreExprToStg env body `thenUs` \ stg_body -> - - if null binders then -- it was all type/usage binders; tossed - returnUs stg_body - else - 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)) +type LneM a = IdEnv HowBound + -> StgLiveVars -- vars live in continuation + -> a + +data HowBound + = ImportBound + | CaseBound + | LambdaBound + | LetrecBound + Bool -- True <=> bound at top level + StgLiveVars -- Live vars... see notes below + +isLetrecBound (LetrecBound _ _) = True +isLetrecBound other = False \end{code} -%************************************************************************ -%* * -\subsubsection[coreToStg-applications]{Applications} -%* * -%************************************************************************ +For a let(rec)-bound variable, x, we record what varibles 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 LetrecBound constructor; x itself *is* included. +The std monad functions: \begin{code} -coreExprToStg env expr@(App _ _) - = let - (fun,args) = collect_args expr [] - (_, stg_args) = coreArgsToStg env args - 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. --- pprTrace "coreExprToStg" (ppr PprDebug expr) $ - 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)) +initLne :: LneM a -> a +initLne m = m emptyVarEnv emptyVarSet + +{-# INLINE thenLne #-} +{-# 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 + = case (m env lvs_cont) of + m_result -> k m_result env lvs_cont + +thenLne_ :: LneM a -> LneM b -> LneM b +thenLne_ m k env lvs_cont + = case (m env lvs_cont) of + _ -> k env lvs_cont + +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) + +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) + +fixLne :: (a -> LneM a) -> LneM a +fixLne expr env lvs_cont = result 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 (Coerce _ _ expr) args = collect_args expr args - collect_args fun args = (fun, args) + result = expr result env lvs_cont +-- ^^^^^^ ------ ^^^^^^ \end{code} -%************************************************************************ -%* * -\subsubsection[coreToStg-cases]{Case expressions} -%* * -%************************************************************************ - +Functions specific to this monad: \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 - ) +getVarsLiveInCont :: LneM StgLiveVars +getVarsLiveInCont env lvs_cont = lvs_cont + +setVarsLiveInCont :: StgLiveVars -> 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. + +lookupLiveVarsForSet :: FreeVarsInfo -> LneM StgLiveVars + +lookupLiveVarsForSet fvs env lvs_cont + = returnLne (unionVarSets (map do_one (getFVs fvs))) + env lvs_cont 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) + do_one v + = if isLocalId v then + case (lookupVarEnv env v) of + Just (LetrecBound _ lvs) -> extendVarSet lvs v + Just _ -> unitVarSet v + Nothing -> pprPanic "lookupVarEnv/do_one:" (ppr v) + else + emptyVarSet \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) -> - coreExprToStg new_env body `thenUs` \ stg_body -> - returnUs (mkStgLets stg_binds stg_body) +type FreeVarsInfo = IdEnv (Id, Bool, StgBinderInfo) + -- If f is mapped to NoStgBinderInfo, that means + -- that f *is* mentioned (else it wouldn't be in the + -- IdEnv at all), but only in a saturated applications. + -- + -- All case/lambda-bound things are also mapped to + -- NoStgBinderInfo, since we aren't interested in their + -- occurence info. + -- + -- The Bool is True <=> the Id is top level letrec bound + +type EscVarsSet = IdSet \end{code} +\begin{code} +emptyFVInfo :: FreeVarsInfo +emptyFVInfo = emptyVarEnv -%************************************************************************ -%* * -\subsubsection[coreToStg-scc]{SCC expressions} -%* * -%************************************************************************ +singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo +singletonFVInfo id ImportBound info = emptyVarEnv +singletonFVInfo id (LetrecBound top_level _) info = unitVarEnv id (id, top_level, info) +singletonFVInfo id other info = unitVarEnv id (id, False, info) -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) -\end{code} +unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo +unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2 -\begin{code} -coreExprToStg env (Coerce c ty expr) = coreExprToStg env expr -\end{code} +unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo +unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs +minusFVBinders :: FreeVarsInfo -> [Id] -> FreeVarsInfo +minusFVBinders fv ids = fv `delVarEnvList` ids -%************************************************************************ -%* * -\subsection[coreToStg-misc]{Miscellaneous helping functions} -%* * -%************************************************************************ +elementOfFVInfo :: Id -> FreeVarsInfo -> Bool +elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id) -There's not anything interesting we can ASSERT about \tr{var} if it -isn't in the StgEnv. (WDP 94/06) +lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo +lookupFVInfo fvs id = case lookupVarEnv fvs id of + Nothing -> NoStgBinderInfo + Just (_,_,info) -> info -\begin{code} -stgLookup :: StgEnv -> Id -> StgArg -stgLookup env var = case (lookupIdEnv env var) of - Nothing -> StgVarArg var - Just atom -> atom -\end{code} +getFVs :: FreeVarsInfo -> [Id] -- Non-top-level things only +getFVs fvs = [id | (id,False,_) <- rngVarEnv fvs] -Invent a fresh @Id@: -\begin{code} -newStgVar :: Type -> UniqSM Id -newStgVar ty - = getUnique `thenUs` \ uniq -> - returnUs (mkSysLocal SLIT("stg") uniq ty noSrcLoc) +getFVSet :: FreeVarsInfo -> IdSet +getFVSet fvs = mkVarSet (getFVs fvs) + +plusFVInfo (id1,top1,info1) (id2,top2,info2) + = ASSERT (id1 == id2 && top1 == top2) + (id1, top1, combineStgBinderInfo info1 info2) \end{code} -\begin{code} -mkStgLets :: [StgBinding] - -> StgExpr -- body of let - -> StgExpr +Misc. -mkStgLets binds body = foldr StgLet body binds +\begin{code} +shouldBeVar (Note _ e) = shouldBeVar e +shouldBeVar (Var v) = v +shouldBeVar e = pprPanic "shouldBeVar" (ppr e) --- 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 +-- 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 :: Expr b -> (Expr b, [Arg b]) +myCollectArgs expr + = go expr [] + where + go (App f a) as = go f (a:as) + go (Note (SCC _) e) as = panic "CoreToStg.myCollectArgs" + go (Note n e) as = go e as + go e as = (e, as) \end{code}