X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FstgSyn%2FCoreToStg.lhs;h=e4752c5bf6f4276d367203a77dd4bb4af4348cde;hb=44637383d831bd3ca8f3aa3cf80e6a0c90986b41;hp=5e8bfa7342295d9743d98b26f42b8c576a894421;hpb=9d787ef5a8072b6c1f576f2de1b66edfa59813ed;p=ghc-hetmet.git diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 5e8bfa7..e4752c5 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -1,912 +1,928 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% (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 ( topCoreBindsToStg ) where +module CoreToStg ( coreToStg, coreExprToStg ) where #include "HsVersions.h" -import CoreSyn -- input -import StgSyn -- output - -import CoreUtils ( coreExprType ) -import SimplUtils ( findDefault ) +import CoreSyn +import CoreFVs +import CoreUtils +import SimplUtils +import StgSyn + +import Type +import TyCon ( isAlgTyCon ) +import Id +import Var ( Var ) +import IdInfo +import DataCon import CostCentre ( noCCS ) -import Id ( Id, mkSysLocal, idType, getIdStrictness, idUnique, isExportedId, mkVanillaId, - externallyVisibleId, setIdUnique, idName, getIdDemandInfo, setIdType - ) -import Var ( Var, varType, modifyIdInfo ) -import IdInfo ( setDemandInfo, StrictnessInfo(..), zapIdInfoForStg ) -import UsageSPUtils ( primOpUsgTys ) -import DataCon ( DataCon, dataConName, dataConId ) -import Demand ( Demand, isStrict, wwStrict, wwLazy ) -import Name ( Name, nameModule, isLocallyDefinedName, setNameUnique ) -import Module ( isDynamicModule ) -import Const ( Con(..), Literal(..), isLitLitLit, conStrictness, isWHNFCon ) +import VarSet import VarEnv -import PrimOp ( PrimOp(..), primOpUsg, primOpSig ) -import Type ( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe, - UsageAnn(..), tyUsg, applyTy, mkUsgTy, repType, seqType ) -import TysPrim ( intPrimTy ) -import UniqSupply -- all of it, really -import Util ( lengthExceeds ) -import BasicTypes ( TopLevelFlag(..), isNotTopLevel ) -import CmdLineOpts ( opt_D_verbose_stg2stg, opt_UsageSPOn ) -import UniqSet ( emptyUniqSet ) -import Maybes +import DataCon ( dataConWrapId ) +import IdInfo ( OccInfo(..) ) +import PrimOp ( PrimOp(..), ccallMayGC ) +import TysPrim ( foreignObjPrimTyCon ) +import Maybes ( maybeToBool, orElse ) +import Name ( getOccName, isExternallyVisibleName ) +import Module ( Module ) +import OccName ( occNameUserString ) +import BasicTypes ( TopLevelFlag(..), isNotTopLevel ) +import CmdLineOpts ( DynFlags, opt_KeepStgTypes ) import Outputable -\end{code} - - - ************************************************* - *************** OVERVIEW ********************* - ************************************************* - - -The business of this pass is to convert Core to Stg. On the way it -does some important transformations: - -1. We discard type lambdas and applications. In so doing we discard - "trivial" bindings such as - x = y t1 t2 - where t1, t2 are types - -2. We get the program into "A-normal form". In particular: - - f E ==> let x = E in f x - OR ==> case E of x -> f x - - where E is a non-trivial expression. - Which transformation is used depends on whether f is strict or not. - [Previously the transformation to case used to be done by the - simplifier, but it's better done here. It does mean that f needs - to have its strictness info correct!.] - - Similarly, convert any unboxed let's into cases. - [I'm experimenting with leaving 'ok-for-speculation' rhss in let-form - right up to this point.] - -3. We clone all local binders. The code generator uses the uniques to - name chunks of code for thunks, so it's important that the names used - are globally unique, not simply not-in-scope, which is all that - the simplifier ensures. - - -NOTE THAT: - -* 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. - -* 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. - -[Quite a bit of stuff that used to be here has moved - to tidyCorePgm (SimplCore.lhs) SLPJ Nov 96] +infixr 9 `thenLne` +\end{code} %************************************************************************ %* * -\subsection[coreToStg-programs]{Converting a core program and core bindings} +\subsection[live-vs-free-doc]{Documentation} %* * %************************************************************************ -March 98: We keep a small environment to give all locally bound -Names new unique ids, since the code generator assumes that binders -are unique across a module. (Simplifier doesn't maintain this -invariant any longer.) +(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. -A binder to be floated out becomes an @StgFloatBind@. +%************************************************************************ +%* * +\subsection[binds-StgVarInfo]{Setting variable info: top-level, binds, RHSs} +%* * +%************************************************************************ \begin{code} -type StgEnv = IdEnv Id - -data StgFloatBind = NoBindF - | RecF [(Id, StgRhs)] - | NonRecF - Id - StgExpr -- *Can* be a StgLam - RhsDemand - [StgFloatBind] - --- The interesting one is the NonRecF --- NonRecF x rhs demand binds --- means --- x = let binds in rhs --- (or possibly case etc if x demand is strict) --- The binds are kept separate so they can be floated futher --- if appropriate +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} -A @RhsDemand@ gives the demand on an RHS: strict (@isStrictDem@) and -thus case-bound, or if let-bound, at most once (@isOnceDem@) or -otherwise. - \begin{code} -data RhsDemand = RhsDemand { isStrictDem :: Bool, -- True => used at least once - isOnceDem :: Bool -- True => used at most once - } - -mkDem :: Demand -> Bool -> RhsDemand -mkDem strict once = RhsDemand (isStrict strict) once +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 -mkDemTy :: Demand -> Type -> RhsDemand -mkDemTy strict ty = RhsDemand (isStrict strict) (isOnceTy ty) +mkStgRhs :: TopLevelFlag -> FreeVarsInfo -> StgBinderInfo + -> StgExpr -> StgRhs -isOnceTy :: Type -> Bool -isOnceTy ty - = -#ifdef USMANY - opt_UsageSPOn && -- can't expect annotations if -fusagesp is off +mkStgRhs top rhs_fvs binder_info (StgLam _ bndrs body) + = StgRhsClosure noCCS binder_info noSRT + (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 noSRT + (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 - case tyUsg ty of - UsOnce -> True - UsMany -> False - UsVar uv -> pprPanic "CoreToStg: unexpected uvar annot:" (ppr uv) + 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} -bdrDem :: Id -> RhsDemand -bdrDem id = mkDem (getIdDemandInfo id) (isOnceTy (idType id)) +Detect thunks which will reduce immediately to PAPs, and make them +non-updatable. This has several advantages: -safeDem, onceDem :: RhsDemand -safeDem = RhsDemand False False -- always safe to use this -onceDem = RhsDemand False True -- used at most once -\end{code} + - the non-updatable thunk behaves exactly like the PAP, -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 thunk is more efficient to enter, because it is + specialised to the task. -When printing out the Stg we need non-bottom values in these -locations. + - we save one update frame, one stg_update_PAP, one update + and lots of PAP_enters. -\begin{code} -bOGUS_LVs :: StgLiveVars -bOGUS_LVs | opt_D_verbose_stg2stg = emptyUniqSet - | otherwise =panic "bOGUS_LVs" + - 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. -bOGUS_FVs :: [Id] -bOGUS_FVs | opt_D_verbose_stg2stg = [] - | otherwise = panic "bOGUS_FVs" -\end{code} +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} -topCoreBindsToStg :: UniqSupply -- name supply - -> [CoreBind] -- input - -> [StgBinding] -- output - -topCoreBindsToStg us core_binds - = initUs_ us (coreBindsToStg emptyVarEnv core_binds) - where - coreBindsToStg :: StgEnv -> [CoreBind] -> UniqSM [StgBinding] - - coreBindsToStg env [] = returnUs [] - coreBindsToStg env (b:bs) - = coreBindToStg TopLevel env b `thenUs` \ (bind_spec, new_env) -> - coreBindsToStg new_env bs `thenUs` \ new_bs -> - case bind_spec of - NonRecF bndr rhs dem floats - -> ASSERT2( not (isStrictDem dem) && - not (isUnLiftedType (idType bndr)), - ppr b ) -- No top-level cases! - - mkStgBinds floats rhs `thenUs` \ new_rhs -> - returnUs (StgNonRec bndr (exprToRhs dem TopLevel new_rhs) - : new_bs) - -- Keep all the floats inside... - -- Some might be cases etc - -- We might want to revisit this decision - - RecF prs -> returnUs (StgRec prs : new_bs) - NoBindF -> pprTrace "topCoreBindsToStg" (ppr b) $ - returnUs new_bs +isPAP (StgApp f args) = idArity f > length args +isPAP _ = False \end{code} -%************************************************************************ -%* * -\subsection[coreToStg-binds]{Converting bindings} -%* * -%************************************************************************ +-- --------------------------------------------------------------------------- +-- Expressions +-- --------------------------------------------------------------------------- \begin{code} -coreBindToStg :: TopLevelFlag -> StgEnv -> CoreBind -> UniqSM (StgFloatBind, StgEnv) - -coreBindToStg top_lev env (NonRec binder rhs) - = coreExprToStgFloat env rhs dem `thenUs` \ (floats, stg_rhs) -> - case (floats, stg_rhs) of - ([], StgApp var []) | not (isExportedId binder) - -> returnUs (NoBindF, extendVarEnv env binder var) - -- A trivial binding let x = y in ... - -- can arise if postSimplExpr floats a NoRep literal out - -- so it seems sensible to deal with it well. - -- But we don't want to discard exported things. They can - -- occur; e.g. an exported user binding f = g - - other -> newLocalId top_lev env binder `thenUs` \ (new_env, new_binder) -> - returnUs (NonRecF new_binder stg_rhs dem floats, new_env) - where - dem = bdrDem binder - -coreBindToStg top_lev env (Rec pairs) - = newLocalIds top_lev env binders `thenUs` \ (env', binders') -> - mapUs (do_rhs env') pairs `thenUs` \ stg_rhss -> - returnUs (RecF (binders' `zip` stg_rhss), env') - where - binders = map fst pairs - do_rhs env (bndr,rhs) = coreExprToStgFloat env rhs dem `thenUs` \ (floats, stg_expr) -> - mkStgBinds floats stg_expr `thenUs` \ stg_expr' -> - -- NB: stg_expr' might still be a StgLam (and we want that) - returnUs (exprToRhs dem top_lev stg_expr') - where - dem = bdrDem bndr +coreToStgExpr + :: CoreExpr + -> LneM (StgExpr, -- Decorated STG expr + FreeVarsInfo, -- Its free vars (NB free, not live) + EscVarsSet) -- Its escapees, a subset of its free vars; + -- also a subset of the domain of the envt + -- because we are only interested in the escapees + -- for vars which might be turned into + -- let-no-escaped ones. \end{code} - -%************************************************************************ -%* * -\subsection[coreToStg-rhss]{Converting right hand sides} -%* * -%************************************************************************ +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} -exprToRhs :: RhsDemand -> TopLevelFlag -> StgExpr -> StgRhs -exprToRhs dem _ (StgLam _ bndrs body) - = ASSERT( not (null bndrs) ) - StgRhsClosure noCCS - stgArgOcc - noSRT - bOGUS_FVs - ReEntrant -- binders is non-empty - bndrs - body - -{- - We reject the following candidates for 'static constructor'dom: - - - any dcon that takes a lit-lit as an arg. - - [Win32 DLLs only]: any dcon that is (or takes as arg) - that's living in a DLL. - - These constraints are necessary to ensure that the code - generated in the end for the static constructors, which - live in the data segment, remain valid - i.e., it has to - be constant. For obvious reasons, that's hard to guarantee - with lit-lits. The second case of a constructor referring - to static closures hiding out in some DLL is an artifact - of the way Win32 DLLs handle global DLL variables. A (data) - symbol exported from a DLL has to be accessed through a - level of indirection at the site of use, so whereas - - extern StgClosure y_closure; - extern StgClosure z_closure; - x = { ..., &y_closure, &z_closure }; - - is legal when the symbols are in scope at link-time, it is - not when y_closure is in a DLL. So, any potential static - closures that refers to stuff that's residing in a DLL - will be put in an (updateable) thunk instead. - - An alternative strategy is to support the generation of - constructors (ala C++ static class constructors) which will - then be run at load time to fix up static closures. --} -exprToRhs dem toplev (StgCon (DataCon con) args _) - | isNotTopLevel toplev || - (not is_dynamic && - all (not.is_lit_lit) args) = StgRhsCon noCCS con args - where - is_dynamic = isDynCon con || any (isDynArg) args - - is_lit_lit (StgVarArg _) = False - is_lit_lit (StgConArg x) = - case x of - Literal l -> isLitLitLit l - _ -> False - -exprToRhs dem _ expr - = upd `seq` - StgRhsClosure noCCS -- No cost centre (ToDo?) - stgArgOcc -- safe - noSRT -- figure out later - bOGUS_FVs - upd - [] - expr - where - upd = if isOnceDem dem then SingleEntry else Updatable - -- HA! Paydirt for "dem" - -isDynCon :: DataCon -> Bool -isDynCon con = isDynName (dataConName con) - -isDynArg :: StgArg -> Bool -isDynArg (StgVarArg v) = isDynName (idName v) -isDynArg (StgConArg con) = - case con of - DataCon dc -> isDynCon dc - Literal l -> isLitLitLit l - _ -> False - -isDynName :: Name -> Bool -isDynName nm = - not (isLocallyDefinedName nm) && - isDynamicModule (nameModule nm) -\end{code} +coreToStgExpr (Lit l) = returnLne (StgLit l, emptyFVInfo, emptyVarSet) +coreToStgExpr (Var v) = coreToStgApp Nothing v [] +coreToStgExpr expr@(App _ _) + = coreToStgApp Nothing f args + where + (f, args) = myCollectArgs expr -%************************************************************************ -%* * -\subsection[coreToStg-atoms{Converting atoms} -%* * -%************************************************************************ +coreToStgExpr expr@(Lam _ _) + = let (args, body) = myCollectBinders expr + args' = filterStgBinders 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) -\begin{code} -coreArgsToStg :: StgEnv -> [(CoreArg,RhsDemand)] -> UniqSM ([StgFloatBind], [StgArg]) --- Arguments are all value arguments (tyargs already removed), paired with their demand +coreToStgExpr (Note (SCC cc) expr) + = coreToStgExpr expr `thenLne` ( \ (expr2, fvs, escs) -> + returnLne (StgSCC cc expr2, fvs, escs) ) -coreArgsToStg env [] - = returnUs ([], []) +coreToStgExpr (Note other_note expr) + = coreToStgExpr expr -coreArgsToStg env (ad:ads) - = coreArgToStg env ad `thenUs` \ (bs1, a') -> - coreArgsToStg env ads `thenUs` \ (bs2, as') -> - returnUs (bs1 ++ bs2, a' : as') +-- Cases require a little more real work. -coreArgToStg :: StgEnv -> (CoreArg,RhsDemand) -> UniqSM ([StgFloatBind], StgArg) --- This is where we arrange that a non-trivial argument is let-bound +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 + -- determine whether the default binder is dead or not + bndr' = bndr `setIdOccInfo` occ_info + occ_info | bndr `elementOfFVInfo` alts_fvs = NoOccInfo + | otherwise = 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 _ _) | (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 + -- 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) -> -coreArgToStg env (arg,dem) - = coreExprToStgFloat env arg dem `thenUs` \ (floats, arg') -> - case arg' of - StgCon con [] _ -> returnUs (floats, StgConArg con) - StgApp v [] -> returnUs (floats, StgVarArg v) - other -> newStgVar arg_ty `thenUs` \ v -> - returnUs ([NonRecF v arg' dem floats], StgVarArg v) + lookupLiveVarsForSet scrut_fvs `thenLne` \ scrut_lvs -> + let + live_in_whole_case = live_in_alts `unionVarSet` scrut_lvs + in + returnLne ( + StgCase 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 - arg_ty = coreExprType arg + 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), + 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) \end{code} +Lets not only take quite a bit of work, but this is where we convert +then to let-no-escapes, if we wish. -%************************************************************************ -%* * -\subsection[coreToStg-exprs]{Converting core expressions} -%* * -%************************************************************************ - +(Meanwhile, we don't expect to see let-no-escapes...) \begin{code} -coreExprToStg :: StgEnv -> CoreExpr -> RhsDemand -> UniqSM StgExpr -coreExprToStg env expr dem - = coreExprToStgFloat env expr dem `thenUs` \ (binds,stg_expr) -> - mkStgBinds binds stg_expr `thenUs` \ stg_expr' -> - deStgLam stg_expr' +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} -%************************************************************************ -%* * -\subsubsection[coreToStg-let(rec)]{Let and letrec expressions} -%* * -%************************************************************************ +If we've got a case containing a _ccall_GC_ primop, we need to +ensure that the arguments are kept live for the duration of the +call. This only an issue \begin{code} -coreExprToStgFloat :: StgEnv -> CoreExpr - -> RhsDemand - -> UniqSM ([StgFloatBind], StgExpr) --- Transform an expression to STG. The demand on the expression is --- given by RhsDemand, and is solely used ot figure out the usage --- of constructor args: if the constructor is used once, then so are --- its arguments. The strictness info in RhsDemand isn't used. - --- The StgExpr returned *can* be an StgLam -\end{code} +isForeignObjArg :: Id -> Bool +isForeignObjArg x = isId x && isForeignObjPrimTy (idType x) -Simple cases first +isForeignObjPrimTy ty + = case splitTyConApp_maybe ty of + Just (tycon, _) -> tycon == foreignObjPrimTyCon + Nothing -> False +\end{code} \begin{code} -coreExprToStgFloat env (Var var) dem - = returnUs ([], mkStgApp (stgLookup env var) []) - -coreExprToStgFloat env (Let bind body) dem - = coreBindToStg NotTopLevel env bind `thenUs` \ (new_bind, new_env) -> - coreExprToStgFloat new_env body dem `thenUs` \ (floats, stg_body) -> - returnUs (new_bind:floats, stg_body) +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} -Convert core @scc@ expression directly to STG @scc@ expression. + +-- --------------------------------------------------------------------------- +-- Applications +-- --------------------------------------------------------------------------- \begin{code} -coreExprToStgFloat env (Note (SCC cc) expr) dem - = coreExprToStg env expr dem `thenUs` \ stg_expr -> - returnUs ([], StgSCC cc stg_expr) +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 -> + coreToStgArgs args `thenLne` \ (args', args_fvs) -> + lookupVarLne f `thenLne` \ how_bound -> -coreExprToStgFloat env (Note other_note expr) dem - = coreExprToStgFloat env expr dem -\end{code} + let + n_args = length args + not_letrec_bound = not (isLetrecBound how_bound) + fun_fvs = singletonFVInfo f how_bound fun_occ + + -- 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_info = idArityInfo f + f_arity = arityLowerBound f_arity_info -- Zero if no info + + fun_occ + | not_letrec_bound = noBinderInfo -- Uninteresting variable + | f_arity > 0 && f_arity <= n_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 + | hasArity f_arity_info && + f_arity == n_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. + + app = case idFlavour f of + DataConId dc -> StgConApp dc args' + PrimOpId op -> StgPrimApp op args' (exprType (mkApps (Var f) args)) + _other -> StgApp f args' -\begin{code} -coreExprToStgFloat env expr@(Type _) dem - = pprPanic "coreExprToStgFloat: tyarg unexpected:" $ ppr expr -\end{code} + 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. + ) -%************************************************************************ -%* * -\subsubsection[coreToStg-lambdas]{Lambda abstractions} -%* * -%************************************************************************ -\begin{code} -coreExprToStgFloat env expr@(Lam _ _) dem - = let - expr_ty = coreExprType expr - (binders, body) = collectBinders expr - id_binders = filter isId binders - body_dem = trace "coreExprToStg: approximating body_dem in Lam" - safeDem - in - if null id_binders then -- It was all type/usage binders; tossed - coreExprToStgFloat env body dem - else - -- At least some value binders - newLocalIds NotTopLevel env id_binders `thenUs` \ (env', binders') -> - coreExprToStgFloat env' body body_dem `thenUs` \ (floats, stg_body) -> - mkStgBinds floats stg_body `thenUs` \ stg_body' -> - - case stg_body' of - StgLam ty lam_bndrs lam_body -> - -- If the body reduced to a lambda too, join them up - returnUs ([], mkStgLam expr_ty (binders' ++ lam_bndrs) lam_body) - - other -> - -- Body didn't reduce to a lambda, so return one - returnUs ([], mkStgLam expr_ty binders' stg_body') -\end{code} +-- --------------------------------------------------------------------------- +-- Argument lists +-- This is the guy that turns applications into A-normal form +-- --------------------------------------------------------------------------- +coreToStgArgs :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo) +coreToStgArgs [] + = returnLne ([], emptyFVInfo) -%************************************************************************ -%* * -\subsubsection[coreToStg-applications]{Applications} -%* * -%************************************************************************ +coreToStgArgs (Type ty : args) -- Type argument + = coreToStgArgs args `thenLne` \ (args', fvs) -> + if opt_KeepStgTypes then + returnLne (StgTypeArg ty : args', fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType ty)) + else + returnLne (args', fvs) -\begin{code} -coreExprToStgFloat env expr@(App _ _) dem - = let - (fun,rads,_,ss) = collect_args expr - ads = reverse rads - final_ads | null ss = ads - | otherwise = zap ads -- Too few args to satisfy strictness info - -- so we have to ignore all the strictness info - -- e.g. + (error "urk") - -- Here, we can't evaluate the arg strictly, - -- because this partial application might be seq'd +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 - coreArgsToStg env final_ads `thenUs` \ (arg_floats, stg_args) -> + 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_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 - -- Now deal with the function - case (fun, stg_args) of - (Var fun_id, _) -> -- A function Id, so do an StgApp; it's ok if - -- there are no arguments. - returnUs (arg_floats, - mkStgApp (stgLookup env fun_id) stg_args) + -- bind_fvs and bind_escs still include the binders of the let(rec) + -- but bind_lvs does not - (non_var_fun, []) -> -- No value args, so recurse into the function - ASSERT( null arg_floats ) - coreExprToStgFloat env non_var_fun dem + -- Do the body + extendVarEnvLne env_ext ( + coreToStgExpr body `thenLne` \ (body2, body_fvs, body_escs) -> + lookupLiveVarsForSet body_fvs `thenLne` \ body_lvs -> - other -> -- A non-variable applied to things; better let-bind it. - newStgVar (coreExprType fun) `thenUs` \ fun_id -> - coreExprToStgFloat env fun onceDem `thenUs` \ (fun_floats, stg_fun) -> - returnUs (NonRecF fun_id stg_fun onceDem fun_floats : arg_floats, - mkStgApp fun_id stg_args) + returnLne (bind2, bind_fvs, bind_escs, bind_lvs, + body2, body_fvs, body_escs, body_lvs) - where - -- Collect arguments and demands (*in reverse order*) - -- collect_args e = (f, args_w_demands, ty, stricts) - -- => e = f tys args, (i.e. args are just the value args) - -- e :: ty - -- stricts is the leftover demands of e on its further args - -- If stricts runs out, we zap all the demands in args_w_demands - -- because partial applications are lazy - - collect_args :: CoreExpr -> (CoreExpr, [(CoreExpr,RhsDemand)], Type, [Demand]) - - collect_args (Note (Coerce ty _) e) = let (the_fun,ads,_,ss) = collect_args e - in (the_fun,ads,ty,ss) - collect_args (Note InlineCall e) = collect_args e - collect_args (Note (TermUsg _) e) = collect_args e - - collect_args (App fun (Type tyarg)) = let (the_fun,ads,fun_ty,ss) = collect_args fun - in (the_fun,ads,applyTy fun_ty tyarg,ss) - collect_args (App fun arg) - = (the_fun, (arg, mkDemTy ss1 arg_ty) : ads, res_ty, ss_rest) - where - (ss1, ss_rest) = case ss of - (ss1:ss_rest) -> (ss1, ss_rest) - [] -> (wwLazy, []) - (the_fun, ads, fun_ty, ss) = collect_args fun - (arg_ty, res_ty) = expectJust "coreExprToStgFloat:collect_args" $ - splitFunTy_maybe fun_ty - - collect_args (Var v) - = (Var v, [], idType v, stricts) - where - stricts = case getIdStrictness v of - StrictnessInfo demands _ -> demands - other -> repeat wwLazy + )) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs, + body2, body_fvs, body_escs, body_lvs) -> - collect_args fun = (fun, [], coreExprType fun, repeat wwLazy) - -- "zap" nukes the strictness info for a partial application - zap ads = [(arg, RhsDemand False once) | (arg, RhsDemand _ once) <- ads] -\end{code} + -- Compute the new let-expression + let + new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2 + | otherwise = StgLet bind2 body2 -%************************************************************************ -%* * -\subsubsection[coreToStg-con]{Constructors and primops} -%* * -%************************************************************************ + free_in_whole_let + = (bind_fvs `unionFVInfo` body_fvs) `minusFVBinders` binders -For data constructors, the demand on an argument is the demand on the -constructor as a whole (see module UsageSPInf). For primops, the -demand is derived from the type of the primop. + live_in_whole_let + = bind_lvs `unionVarSet` (body_lvs `minusVarSet` set_of_binders) -If usage inference is off, we simply make all bindings updatable for -speed. + real_bind_escs = if let_no_escape then + bind_escs + else + getFVSet bind_fvs + -- Everything escapes which is free in the bindings -\begin{code} -coreExprToStgFloat env expr@(Con con args) dem - = let - expr_ty = coreExprType expr - (stricts,_) = conStrictness con - onces = case con of - DEFAULT -> panic "coreExprToStgFloat: DEFAULT" - - Literal _ -> ASSERT( null args' {-'cpp-} ) [] - - DataCon c -> repeat (isOnceDem dem) - -- HA! This is the sole reason we propagate - -- dem all the way down - - PrimOp p -> let tyargs = map (\ (Type ty) -> ty) $ - takeWhile isTypeArg args - (arg_tys,_) = primOpUsgTys p tyargs - in ASSERT( length arg_tys == length args' {-'cpp-} ) - -- primops always fully applied, so == not >= - map isOnceTy arg_tys - - dems' = zipWith mkDem stricts onces - args' = filter isValArg args - in - coreArgsToStg env (zip args' dems') `thenUs` \ (arg_floats, stg_atoms) -> + let_escs = (real_bind_escs `unionVarSet` body_escs) `minusVarSet` set_of_binders - -- YUK YUK: must unique if present - (case con of - PrimOp (CCallOp (Right _) a b c) -> getUniqueUs `thenUs` \ u -> - returnUs (PrimOp (CCallOp (Right u) a b c)) - _ -> returnUs con - ) `thenUs` \ con' -> + all_escs = bind_escs `unionVarSet` body_escs -- Still includes binders of + -- this let(rec) - returnUs (arg_floats, mkStgCon con' stg_atoms expr_ty) -\end{code} + 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 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-cases]{Case expressions} +\subsection[LNE-monad]{A little monad for this let-no-escaping pass} %* * %************************************************************************ -First, two special cases. We mangle cases involving - par# and seq# -inthe scrutinee. +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}. -Up to this point, seq# will appear like this: +\begin{code} +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} - case seq# e of - 0# -> seqError# - _ -> +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 LetrecBound constructor; x itself +*is* included. -This code comes from an unfolding for 'seq' in Prelude.hs. -The 0# branch is purely to bamboozle the strictness analyser. -For example, if is strict in x, and there was no seqError# -branch, the strictness analyser would conclude that the whole expression -was strict in x, and perhaps evaluate x first -- but that would be a DISASTER. +The set of live variables is guaranteed ot have no further let-no-escaped +variables in it. -Now that the evaluation order is safe, we translate this into +The std monad functions: +\begin{code} +initLne :: LneM a -> a +initLne m = m emptyVarEnv emptyVarSet - case e of - _ -> ... +{-# INLINE thenLne #-} +{-# INLINE returnLne #-} -This used to be done in the post-simplification phase, but we need -unfoldings involving seq# to appear unmangled in the interface file, -hence we do this mangling here. +returnLne :: a -> LneM a +returnLne e env lvs_cont = e -Similarly, par# has an unfolding in PrelConc.lhs that makes it show -up like this: +thenLne :: LneM a -> (a -> LneM b) -> LneM b +thenLne m k env lvs_cont + = k (m env lvs_cont) env lvs_cont - case par# e of - 0# -> rhs - _ -> parError# +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]) - ==> - case par# e of - _ -> rhs +mapAndUnzipLne f [] = returnLne ([],[]) +mapAndUnzipLne f (x:xs) + = f x `thenLne` \ (r1, r2) -> + mapAndUnzipLne f xs `thenLne` \ (rs1, rs2) -> + returnLne (r1:rs1, r2:rs2) -fork# isn't handled like this - it's an explicit IO operation now. -The reason is that fork# returns a ThreadId#, which gets in the -way of the above scheme. And anyway, IO is the only guaranteed -way to enforce ordering --SDM. +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) -\begin{code} -coreExprToStgFloat env - (Case scrut@(Con (PrimOp SeqOp) [Type ty, e]) bndr alts) dem - = coreExprToStgFloat env (Case e new_bndr [(DEFAULT,[],default_rhs)]) dem - where - new_bndr = setIdType bndr ty - (other_alts, maybe_default) = findDefault alts - Just default_rhs = maybe_default - -coreExprToStgFloat env - (Case scrut@(Con (PrimOp ParOp) args) bndr alts) dem - | maybeToBool maybe_default - = coreExprToStgFloat env scrut (bdrDem bndr) `thenUs` \ (binds, scrut') -> - newEvaldLocalId env bndr `thenUs` \ (env', bndr') -> - coreExprToStg env' default_rhs dem `thenUs` \ default_rhs' -> - returnUs (binds, mkStgCase scrut' bndr' (StgPrimAlts (idType bndr') [] (StgBindDefault default_rhs'))) +fixLne :: (a -> LneM a) -> LneM a +fixLne expr env lvs_cont + = result where - (other_alts, maybe_default) = findDefault alts - Just default_rhs = maybe_default + result = expr result env lvs_cont \end{code} -Now for normal case expressions... +Functions specific to this monad: \begin{code} -coreExprToStgFloat env (Case scrut bndr alts) dem - = coreExprToStgFloat env scrut (bdrDem bndr) `thenUs` \ (binds, scrut') -> - newEvaldLocalId env bndr `thenUs` \ (env', bndr') -> - alts_to_stg env' (findDefault alts) `thenUs` \ alts' -> - returnUs (binds, mkStgCase scrut' bndr' 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 - scrut_ty = idType bndr - prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty) - - alts_to_stg env (alts, deflt) - | prim_case - = default_to_stg env deflt `thenUs` \ deflt' -> - mapUs (prim_alt_to_stg env) alts `thenUs` \ alts' -> - returnUs (mkStgPrimAlts scrut_ty alts' deflt') - - | otherwise - = default_to_stg env deflt `thenUs` \ deflt' -> - mapUs (alg_alt_to_stg env) alts `thenUs` \ alts' -> - returnUs (mkStgAlgAlts scrut_ty alts' deflt') - - alg_alt_to_stg env (DataCon con, bs, rhs) - = newLocalIds NotTopLevel env (filter isId bs) `thenUs` \ (env', stg_bs) -> - coreExprToStg env' rhs dem `thenUs` \ stg_rhs -> - returnUs (con, stg_bs, [ True | b <- stg_bs ]{-bogus use mask-}, stg_rhs) - -- NB the filter isId. Some of the binders may be - -- existential type variables, which STG doesn't care about - - prim_alt_to_stg env (Literal lit, args, rhs) - = ASSERT( null args ) - coreExprToStg env rhs dem `thenUs` \ stg_rhs -> - returnUs (lit, stg_rhs) - - default_to_stg env Nothing - = returnUs StgNoDefault - - default_to_stg env (Just rhs) - = coreExprToStg env rhs dem `thenUs` \ stg_rhs -> - returnUs (StgBindDefault stg_rhs) - -- The binder is used for prim cases and not otherwise - -- (hack for old code gen) + 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} %************************************************************************ %* * -\subsection[coreToStg-misc]{Miscellaneous helping functions} +\subsection[Free-var info]{Free variable information} %* * %************************************************************************ -There's not anything interesting we can ASSERT about \tr{var} if it -isn't in the StgEnv. (WDP 94/06) - \begin{code} -stgLookup :: StgEnv -> Id -> Id -stgLookup env var = case (lookupVarEnv env var) of - Nothing -> var - Just var -> var +type FreeVarsInfo = VarEnv (Var, Bool, StgBinderInfo) + -- If f is mapped to noBinderInfo, 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 + -- noBinderInfo, since we aren't interested in their + -- occurence info. + -- + -- The Bool is True <=> the Id is top level letrec bound + -- + -- For ILX we track free var info for type variables too; + -- hence VarEnv not IdEnv + +type EscVarsSet = IdSet \end{code} -Invent a fresh @Id@: \begin{code} -newStgVar :: Type -> UniqSM Id -newStgVar ty - = getUniqueUs `thenUs` \ uniq -> - seqType ty `seq` - returnUs (mkSysLocal SLIT("stg") uniq ty) -\end{code} +emptyFVInfo :: FreeVarsInfo +emptyFVInfo = emptyVarEnv -\begin{code} -{- Now redundant, I believe --- we overload the demandInfo field of an Id to indicate whether the Id is definitely --- evaluated or not (i.e. whether it is a case binder). This can be used to eliminate --- some redundant cases (c.f. dataToTag# above). +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) -newEvaldLocalId env id - = getUniqueUs `thenUs` \ uniq -> - let - id' = modifyIdInfo (`setDemandInfo` wwStrict) (setIdUnique id uniq) - new_env = extendVarEnv env id id' - in - returnUs (new_env, id') --} +tyvarFVInfo :: TyVarSet -> FreeVarsInfo +tyvarFVInfo tvs = foldVarSet add emptyFVInfo tvs + where + add tv fvs = extendVarEnv fvs tv (tv, False, noBinderInfo) -newEvaldLocalId env id = newLocalId NotTopLevel env id +unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo +unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2 -newLocalId TopLevel env id - -- Don't clone top-level binders. MkIface relies on their - -- uniques staying the same, so it can snaffle IdInfo off the - -- STG ids to put in interface files. - = let - name = idName id - ty = idType id - in - name `seq` - seqType ty `seq` - returnUs (env, mkVanillaId name ty) +unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo +unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs +minusFVBinders :: FreeVarsInfo -> [Id] -> FreeVarsInfo +minusFVBinders fv ids = fv `delVarEnvList` ids -newLocalId NotTopLevel env id - = -- Local binder, give it a new unique Id. - getUniqueUs `thenUs` \ uniq -> - let - name = idName id - ty = idType id - new_id = mkVanillaId (setNameUnique name uniq) ty - new_env = extendVarEnv env id new_id - in - name `seq` - seqType ty `seq` - returnUs (new_env, new_id) - -newLocalIds :: TopLevelFlag -> StgEnv -> [Id] -> UniqSM (StgEnv, [Id]) -newLocalIds top_lev env [] - = returnUs (env, []) -newLocalIds top_lev env (b:bs) - = newLocalId top_lev env b `thenUs` \ (env', b') -> - newLocalIds top_lev env' bs `thenUs` \ (env'', bs') -> - returnUs (env'', b':bs') -\end{code} +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 -%************************************************************************ -%* * -\subsection{Building STG syn} -%* * -%************************************************************************ +getFVs :: FreeVarsInfo -> [Id] -- Non-top-level things only +getFVs fvs = [id | (id,False,_) <- rngVarEnv fvs] -\begin{code} -mkStgAlgAlts ty alts deflt = seqType ty `seq` StgAlgAlts ty alts deflt -mkStgPrimAlts ty alts deflt = seqType ty `seq` StgPrimAlts ty alts deflt -mkStgCon con args ty = seqType ty `seq` StgCon con args ty -mkStgLam ty bndrs body = seqType ty `seq` StgLam ty bndrs body - -mkStgApp :: Id -> [StgArg] -> StgExpr -mkStgApp fn args = fn `seq` StgApp fn args - -- Force the lookup +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} +Misc. \begin{code} --- Stg doesn't have a lambda *expression*, -deStgLam (StgLam ty bndrs body) = mkStgLamExpr ty bndrs body -deStgLam expr = returnUs expr - -mkStgLamExpr ty bndrs body - = ASSERT( not (null bndrs) ) - newStgVar ty `thenUs` \ fn -> - returnUs (StgLet (StgNonRec fn lam_closure) (mkStgApp fn [])) - where - lam_closure = StgRhsClosure noCCS - stgArgOcc - noSRT - bOGUS_FVs - ReEntrant -- binders is non-empty - bndrs - body - -mkStgBinds :: [StgFloatBind] - -> StgExpr -- *Can* be a StgLam - -> UniqSM StgExpr -- *Can* be a StgLam - -mkStgBinds [] body = returnUs body -mkStgBinds (b:bs) body - = deStgLam body `thenUs` \ body' -> - go (b:bs) body' - where - go [] body = returnUs body - go (b:bs) body = go bs body `thenUs` \ body' -> - mkStgBind b body' - --- The 'body' arg of mkStgBind can't be a StgLam -mkStgBind NoBindF body = returnUs body -mkStgBind (RecF prs) body = returnUs (StgLet (StgRec prs) body) +filterStgBinders :: [Var] -> [Var] +filterStgBinders bndrs + | opt_KeepStgTypes = bndrs + | otherwise = filter isId bndrs +\end{code} -mkStgBind (NonRecF bndr rhs dem floats) body -#ifdef DEBUG - -- We shouldn't get let or case of the form v=w - = case rhs of - StgApp v [] -> pprTrace "mkStgLet" (ppr bndr <+> ppr v) - (mk_stg_let bndr rhs dem floats body) - other -> mk_stg_let bndr rhs dem floats body -mk_stg_let bndr rhs dem floats body -#endif - | isUnLiftedType bndr_rep_ty -- Use a case/PrimAlts - = ASSERT( not (isUnboxedTupleType bndr_rep_ty) ) - mkStgBinds floats $ - mkStgCase rhs bndr (StgPrimAlts bndr_rep_ty [] (StgBindDefault body)) - - | is_whnf - = if is_strict then - -- Strict let with WHNF rhs - mkStgBinds floats $ - StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel rhs)) body - else - -- Lazy let with WHNF rhs; float until we find a strict binding - let - (floats_out, floats_in) = splitFloats floats - in - mkStgBinds floats_in rhs `thenUs` \ new_rhs -> - mkStgBinds floats_out $ - StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel new_rhs)) body - - | otherwise -- Not WHNF - = if is_strict then - -- Strict let with non-WHNF rhs - mkStgBinds floats $ - mkStgCase rhs bndr (StgAlgAlts bndr_rep_ty [] (StgBindDefault body)) - else - -- Lazy let with non-WHNF rhs, so keep the floats in the RHS - mkStgBinds floats rhs `thenUs` \ new_rhs -> - returnUs (StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel new_rhs)) body) - +\begin{code} + -- Ignore all notes except SCC +myCollectBinders expr + = go [] expr where - bndr_rep_ty = repType (idType bndr) - is_strict = isStrictDem dem - is_whnf = case rhs of - StgCon _ _ _ -> True - StgLam _ _ _ -> True - other -> False - --- Split at the first strict binding -splitFloats fs@(NonRecF _ _ dem _ : _) - | isStrictDem dem = ([], fs) - -splitFloats (f : fs) = case splitFloats fs of - (fs_out, fs_in) -> (f : fs_out, fs_in) - -splitFloats [] = ([], []) - - -mkStgCase scrut bndr alts - = ASSERT( case scrut of { StgLam _ _ _ -> False; other -> True } ) - -- We should never find - -- case (\x->e) of { ... } - -- The simplifier eliminates such things - StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT alts + 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}