X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FstgSyn%2FCoreToStg.lhs;h=15e9fc3cd65015eda357ce509949fe69b17a60ae;hb=1cfc9faaa059b9b090971399e4eb8ae9d364335c;hp=f97ea1b6aa36465a5a24dfba9e42149b7102f3a5;hpb=699e9f229be993270e49ff7fcdd155508502c6ea;p=ghc-hetmet.git diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index f97ea1b..15e9fc3 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -1,584 +1,1111 @@ % -% (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 CoreUtils ( rhsIsStatic, manifestArity, exprType ) +import StgSyn + +import Type +import TyCon ( isAlgTyCon ) +import Literal +import Id +import Var ( Var, globalIdDetails, varType ) +#ifdef ILX +import MkId ( unsafeCoerceId ) +#endif +import IdInfo +import DataCon import CostCentre ( noCCS ) -import Id ( Id, mkSysLocal, idType, - externallyVisibleId, setIdUnique, idName - ) -import DataCon ( DataCon, dataConName, dataConId ) -import Name ( Name, nameModule, isLocallyDefinedName ) -import Module ( isDynamicModule ) -import Const ( Con(..), Literal, isLitLitLit ) +import VarSet import VarEnv -import Const ( Con(..), isWHNFCon, Literal(..) ) -import PrimOp ( PrimOp(..) ) -import Type ( isUnLiftedType, isUnboxedTupleType, Type ) -import TysPrim ( intPrimTy ) -import Unique ( Unique, Uniquable(..) ) -import UniqSupply -- all of it, really +import Maybes ( maybeToBool ) +import Name ( getOccName, isExternalName, nameOccName ) +import OccName ( occNameUserString, occNameFS ) +import BasicTypes ( Arity ) +import CmdLineOpts ( DynFlags, opt_RuntimeTypes ) import Outputable + +infixr 9 `thenLne` \end{code} +%************************************************************************ +%* * +\subsection[live-vs-free-doc]{Documentation} +%* * +%************************************************************************ + +(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. - *************** OVERVIEW ********************* +%************************************************************************ +%* * +\subsection[caf-info]{Collecting live CAF info} +%* * +%************************************************************************ + +In this pass we also collect information on which CAFs are live for +constructing SRTs (see SRT.lhs). + +A top-level Id has CafInfo, which is + - MayHaveCafRefs, if it may refer indirectly to + one or more CAFs, or + - NoCafRefs if it definitely doesn't -The business of this pass is to convert Core to Stg. On the way: +The CafInfo has already been calculated during the CoreTidy pass. -* We discard type lambdas and applications. In so doing we discard - "trivial" bindings such as - x = y t1 t2 - where t1, t2 are types +During CoreToStg, we then pin onto each binding and case expression, a +list of Ids which represents the "live" CAFs at that point. The meaning +of "live" here is the same as for live variables, see above (which is +why it's convenient to collect CAF information here rather than elsewhere). -* 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. +The later SRT pass takes these lists of Ids and uses them to construct +the actual nested SRTs, and replaces the lists of Ids with (offset,length) +pairs. -* We 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] +Interaction of let-no-escape with SRTs [Sept 01] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + let-no-escape x = ...caf1...caf2... + in + ...x...x...x... + +where caf1,caf2 are CAFs. Since x doesn't have a closure, we +build SRTs just as if x's defn was inlined at each call site, and +that means that x's CAF refs get duplicated in the overall SRT. + +This is unlike ordinary lets, in which the CAF refs are not duplicated. + +We could fix this loss of (static) sharing by making a sort of pseudo-closure +for x, solely to put in the SRTs lower down. %************************************************************************ %* * -\subsection[coreToStg-programs]{Converting a core program and core bindings} +\subsection[binds-StgVarInfo]{Setting variable info: top-level, binds, RHSs} %* * %************************************************************************ -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.) - \begin{code} -type StgEnv = IdEnv Id +coreToStg :: DynFlags -> [CoreBind] -> IO [StgBinding] +coreToStg dflags pgm + = return pgm' + where (_, _, pgm') = coreTopBindsToStg emptyVarEnv pgm -data StgFloatBind - = LetBind Id StgExpr - | CaseBind Id StgExpr -\end{code} +coreExprToStg :: CoreExpr -> StgExpr +coreExprToStg expr + = new_expr where (new_expr,_,_) = initLne emptyVarEnv (coreToStgExpr expr) -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. -\begin{code} -bOGUS_LVs :: StgLiveVars -bOGUS_LVs = panic "bOGUS_LVs" -- emptyUniqSet (used when pprTracing) +coreTopBindsToStg + :: IdEnv HowBound -- environment for the bindings + -> [CoreBind] + -> (IdEnv HowBound, FreeVarsInfo, [StgBinding]) -bOGUS_FVs :: [Id] -bOGUS_FVs = panic "bOGUS_FVs" -- [] (ditto) +coreTopBindsToStg env [] = (env, emptyFVInfo, []) +coreTopBindsToStg env (b:bs) + = (env2, fvs2, b':bs') + where + -- env accumulates down the list of binds, fvs accumulates upwards + (env1, fvs2, b' ) = coreTopBindToStg env fvs1 b + (env2, fvs1, bs') = coreTopBindsToStg env1 bs + + +coreTopBindToStg + :: IdEnv HowBound + -> FreeVarsInfo -- Info about the body + -> CoreBind + -> (IdEnv HowBound, FreeVarsInfo, StgBinding) + +coreTopBindToStg env body_fvs (NonRec id rhs) + = let + env' = extendVarEnv env id how_bound + how_bound = LetBound TopLet (manifestArity rhs) + + (stg_rhs, fvs') = + initLne env ( + coreToTopStgRhs body_fvs (id,rhs) `thenLne` \ (stg_rhs, fvs') -> + returnLne (stg_rhs, fvs') + ) + + bind = StgNonRec id stg_rhs + in + ASSERT2(manifestArity rhs == stgRhsArity stg_rhs, ppr id) + ASSERT2(consistentCafInfo id bind, ppr id) +-- WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info) + (env', fvs' `unionFVInfo` body_fvs, bind) + +coreTopBindToStg env body_fvs (Rec pairs) + = let + (binders, rhss) = unzip pairs + + extra_env' = [ (b, LetBound TopLet (manifestArity rhs)) + | (b, rhs) <- pairs ] + env' = extendVarEnvList env extra_env' + + (stg_rhss, fvs') + = initLne env' ( + mapAndUnzipLne (coreToTopStgRhs body_fvs) pairs + `thenLne` \ (stg_rhss, fvss') -> + let fvs' = unionFVInfos fvss' in + returnLne (stg_rhss, fvs') + ) + + bind = StgRec (zip binders stg_rhss) + in + ASSERT2(and [manifestArity rhs == stgRhsArity stg_rhs | (rhs,stg_rhs) <- rhss `zip` stg_rhss], ppr binders) + ASSERT2(consistentCafInfo (head binders) bind, ppr binders) + (env', fvs' `unionFVInfo` body_fvs, bind) + +#ifdef DEBUG +-- Assertion helper: this checks that the CafInfo on the Id matches +-- what CoreToStg has figured out about the binding's SRT. The +-- CafInfo will be exact in all cases except when CorePrep has +-- floated out a binding, in which case it will be approximate. +consistentCafInfo id bind + | occNameFS (nameOccName (idName id)) == FSLIT("sat") + = safe + | otherwise + = WARN (not exact, ppr id) safe + where + safe = id_marked_caffy || not binding_is_caffy + exact = id_marked_caffy == binding_is_caffy + id_marked_caffy = mayHaveCafRefs (idCafInfo id) + binding_is_caffy = stgBindHasCafRefs bind +#endif \end{code} \begin{code} -topCoreBindsToStg :: UniqSupply -- name supply - -> [CoreBind] -- input - -> [StgBinding] -- output - -topCoreBindsToStg us core_binds - = initUs us (coreBindsToStg emptyVarEnv core_binds) +coreToTopStgRhs + :: FreeVarsInfo -- Free var info for the scope of the binding + -> (Id,CoreExpr) + -> LneM (StgRhs, FreeVarsInfo) + +coreToTopStgRhs scope_fv_info (bndr, rhs) + = coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, _) -> + freeVarsToLiveVars rhs_fvs `thenLne` \ lv_info -> + returnLne (mkTopStgRhs is_static rhs_fvs (mkSRT lv_info) bndr_info new_rhs, rhs_fvs) where - coreBindsToStg :: StgEnv -> [CoreBind] -> UniqSM [StgBinding] + bndr_info = lookupFVInfo scope_fv_info bndr + is_static = rhsIsStatic rhs + +mkTopStgRhs :: Bool -> FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr + -> StgRhs + +mkTopStgRhs is_static rhs_fvs srt binder_info (StgLam _ bndrs body) + = ASSERT( is_static ) + StgRhsClosure noCCS binder_info + (getFVs rhs_fvs) + ReEntrant + srt + bndrs body + +mkTopStgRhs is_static rhs_fvs srt binder_info (StgConApp con args) + | is_static -- StgConApps can be updatable (see isCrossDllConApp) + = StgRhsCon noCCS con args + +mkTopStgRhs is_static rhs_fvs srt binder_info rhs + = ASSERT( not is_static ) + StgRhsClosure noCCS binder_info + (getFVs rhs_fvs) + Updatable + srt + [] rhs +\end{code} + + +-- --------------------------------------------------------------------------- +-- Expressions +-- --------------------------------------------------------------------------- - coreBindsToStg env [] = returnUs [] - coreBindsToStg env (b:bs) - = coreBindToStg env b `thenUs` \ (new_b, new_env) -> - coreBindsToStg new_env bs `thenUs` \ new_bs -> - returnUs (new_b ++ new_bs) +\begin{code} +coreToStgExpr + :: CoreExpr + -> LneM (StgExpr, -- Decorated STG expr + FreeVarsInfo, -- Its free vars (NB free, not live) + EscVarsSet) -- Its escapees, a subset of its free vars; + -- also a subset of the domain of the envt + -- because we are only interested in the escapees + -- for vars which might be turned into + -- let-no-escaped ones. \end{code} -%************************************************************************ -%* * -\subsection[coreToStg-binds]{Converting bindings} -%* * -%************************************************************************ +The second and third components can be derived in a simple bottom up pass, not +dependent on any decisions about which variables will be let-no-escaped or +not. The first component, that is, the decorated expression, may then depend +on these components, but it in turn is not scrutinised as the basis for any +decisions. Hence no black holes. \begin{code} -coreBindToStg :: StgEnv - -> CoreBind - -> UniqSM ([StgBinding], -- Empty or singleton - StgEnv) -- Floats - -coreBindToStg env (NonRec binder rhs) - = coreRhsToStg env rhs `thenUs` \ stg_rhs -> - newLocalId env binder `thenUs` \ (new_env, new_binder) -> - returnUs ([StgNonRec new_binder stg_rhs], new_env) - -coreBindToStg env (Rec pairs) - = newLocalIds env binders `thenUs` \ (env', binders') -> - mapUs (coreRhsToStg env') rhss `thenUs` \ stg_rhss -> - returnUs ([StgRec (binders' `zip` stg_rhss)], env') +coreToStgExpr (Lit l) = returnLne (StgLit l, emptyFVInfo, emptyVarSet) +coreToStgExpr (Var v) = coreToStgApp Nothing v [] + +coreToStgExpr expr@(App _ _) + = coreToStgApp Nothing f args where - (binders, rhss) = unzip pairs + (f, args) = myCollectArgs expr + +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 + fvs = args' `minusFVBinders` body_fvs + escs = body_escs `delVarSetList` args' + result_expr | null args' = body + | otherwise = StgLam (exprType expr) args' body + in + returnLne (result_expr, fvs, escs) + +coreToStgExpr (Note (SCC cc) expr) + = coreToStgExpr expr `thenLne` ( \ (expr2, fvs, escs) -> + returnLne (StgSCC cc expr2, fvs, escs) ) + +#ifdef ILX +-- For ILX, convert (__coerce__ to_ty from_ty e) +-- into (coerce to_ty from_ty e) +-- where coerce is real function +coreToStgExpr (Note (Coerce to_ty from_ty) expr) + = coreToStgExpr (mkApps (Var unsafeCoerceId) + [Type from_ty, Type to_ty, expr]) +#endif + +coreToStgExpr (Note other_note expr) + = coreToStgExpr expr + +-- Cases require a little more real work. + +coreToStgExpr (Case scrut bndr alts) + = extendVarEnvLne [(bndr, LambdaBound)] ( + mapAndUnzip3Lne vars_alt alts `thenLne` \ (alts2, fvs_s, escs_s) -> + returnLne ( mkStgAlts (idType bndr) alts2, + unionFVInfos fvs_s, + unionVarSets escs_s ) + ) `thenLne` \ (alts2, alts_fvs, alts_escs) -> + let + -- Determine whether the default binder is dead or not + -- This helps the code generator to avoid generating an assignment + -- for the case binder (is extremely rare cases) ToDo: remove. + bndr' | bndr `elementOfFVInfo` alts_fvs = bndr + | otherwise = bndr `setIdOccInfo` IAmDead + + -- Don't consider the default binder as being 'live in alts', + -- since this is from the point of view of the case expr, where + -- the default binder is not free. + alts_fvs_wo_bndr = bndr `minusFVBinder` alts_fvs + alts_escs_wo_bndr = alts_escs `delVarSet` bndr + in + + freeVarsToLiveVars alts_fvs_wo_bndr `thenLne` \ alts_lv_info -> + + -- We tell the scrutinee that everything + -- live in the alts is live in it, too. + setVarsLiveInCont alts_lv_info ( + coreToStgExpr scrut `thenLne` \ (scrut2, scrut_fvs, scrut_escs) -> + freeVarsToLiveVars scrut_fvs `thenLne` \ scrut_lv_info -> + returnLne (scrut2, scrut_fvs, scrut_escs, scrut_lv_info) + ) + `thenLne` \ (scrut2, scrut_fvs, scrut_escs, scrut_lv_info) -> + + returnLne ( + StgCase scrut2 (getLiveVars scrut_lv_info) + (getLiveVars alts_lv_info) + bndr' + (mkSRT alts_lv_info) + alts2, + scrut_fvs `unionFVInfo` alts_fvs_wo_bndr, + alts_escs_wo_bndr `unionVarSet` getFVSet scrut_fvs + -- You might think we should have scrut_escs, not + -- (getFVSet scrut_fvs), but actually we can't call, and + -- then return from, a let-no-escape thing. + ) + where + vars_alt (con, binders, rhs) + = let -- Remove type variables + binders' = filterStgBinders binders + in + extendVarEnvLne [(b, LambdaBound) | b <- binders'] $ + coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) -> + let + -- Records whether each param is used in the RHS + good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders' ] + in + returnLne ( (con, binders', good_use_mask, rhs2), + binders' `minusFVBinders` rhs_fvs, + rhs_escs `delVarSetList` binders' ) + -- ToDo: remove the delVarSet; + -- since escs won't include any of these binders \end{code} +Lets not only take quite a bit of work, but this is where we convert +then to let-no-escapes, if we wish. -%************************************************************************ -%* * -\subsection[coreToStg-rhss]{Converting right hand sides} -%* * -%************************************************************************ +(Meanwhile, we don't expect to see let-no-escapes...) +\begin{code} +coreToStgExpr (Let bind body) + = fixLne (\ ~(_, _, _, no_binder_escapes) -> + coreToStgLet no_binder_escapes bind body + ) `thenLne` \ (new_let, fvs, escs, _) -> + + returnLne (new_let, fvs, escs) +\end{code} \begin{code} -coreRhsToStg :: StgEnv -> CoreExpr -> UniqSM StgRhs - -coreRhsToStg env core_rhs - = coreExprToStg env core_rhs `thenUs` \ stg_expr -> - returnUs (exprToRhs stg_expr) - -exprToRhs (StgLet (StgNonRec var1 rhs) (StgApp 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. - -{- - 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 (StgCon (DataCon con) args _) - | 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 expr - = StgRhsClosure noCCS -- No cost centre (ToDo?) - stgArgOcc -- safe - noSRT -- figure out later - bOGUS_FVs - - Updatable -- Be pessimistic - [] - expr - -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) +mkStgAlts scrut_ty orig_alts + | is_prim_case = StgPrimAlts (tyConAppTyCon scrut_ty) prim_alts deflt + | otherwise = StgAlgAlts maybe_tycon alg_alts deflt + where + is_prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty) + prim_alts = [(lit, rhs) | (LitAlt lit, _, _, rhs) <- other_alts] + alg_alts = [(con, bndrs, use, rhs) | (DataAlt con, bndrs, use, rhs) <- other_alts] + (other_alts, deflt) + = case orig_alts of -- DEFAULT is always first if it's there at all + (DEFAULT, _, _, rhs) : other_alts -> (other_alts, StgBindDefault rhs) + other -> (orig_alts, StgNoDefault) + + maybe_tycon = case alg_alts of + -- Get the tycon from the data con + (dc, _, _, _) : _rest -> Just (dataConTyCon dc) + + -- Otherwise just do your best + [] -> case splitTyConApp_maybe (repType scrut_ty) of + Just (tc,_) | isAlgTyCon tc -> Just tc + _other -> Nothing \end{code} -%************************************************************************ -%* * -\subsection[coreToStg-atoms{Converting atoms} -%* * -%************************************************************************ +-- --------------------------------------------------------------------------- +-- Applications +-- --------------------------------------------------------------------------- \begin{code} -coreArgsToStg :: StgEnv -> [CoreArg] -> UniqSM ([StgFloatBind], [StgArg]) +coreToStgApp + :: Maybe UpdateFlag -- Just upd <=> this application is + -- the rhs of a thunk binding + -- x = [...] \upd [] -> the_app + -- with specified update flag + -> Id -- Function + -> [CoreArg] -- Arguments + -> LneM (StgExpr, FreeVarsInfo, EscVarsSet) + +coreToStgApp maybe_thunk_body f args + = coreToStgArgs args `thenLne` \ (args', args_fvs) -> + lookupVarLne f `thenLne` \ how_bound -> -coreArgsToStg env [] - = returnUs ([], []) + let + n_val_args = valArgCount args + not_letrec_bound = not (isLetBound how_bound) + fun_fvs + = let fvs = singletonFVInfo f how_bound fun_occ in + -- e.g. (f :: a -> int) (x :: a) + -- Here the free variables are "f", "x" AND the type variable "a" + -- coreToStgArgs will deal with the arguments recursively + if opt_RuntimeTypes then + fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType (varType f)) + else fvs + + -- Mostly, the arity info of a function is in the fn's IdInfo + -- But new bindings introduced by CoreSat may not have no + -- arity info; it would do us no good anyway. For example: + -- let f = \ab -> e in f + -- No point in having correct arity info for f! + -- Hence the hasArity stuff below. + -- NB: f_arity is only consulted for LetBound things + f_arity = stgArity f how_bound + saturated = f_arity <= n_val_args + + fun_occ + | not_letrec_bound = noBinderInfo -- Uninteresting variable + | f_arity > 0 && saturated = stgSatOcc -- Saturated or over-saturated function call + | otherwise = stgUnsatOcc -- Unsaturated function or thunk + + fun_escs + | not_letrec_bound = emptyVarSet -- Only letrec-bound escapees are interesting + | f_arity == n_val_args = emptyVarSet -- A function *or thunk* with an exactly + -- saturated call doesn't escape + -- (let-no-escape applies to 'thunks' too) + + | otherwise = unitVarSet f -- Inexact application; it does escape + + -- At the moment of the call: + + -- either the function is *not* let-no-escaped, in which case + -- nothing is live except live_in_cont + -- or the function *is* let-no-escaped in which case the + -- variables it uses are live, but still the function + -- itself is not. PS. In this case, the function's + -- live vars should already include those of the + -- continuation, but it does no harm to just union the + -- two regardless. + + res_ty = exprType (mkApps (Var f) args) + app = case globalIdDetails f of + DataConWorkId dc | saturated -> StgConApp dc args' + PrimOpId op -> ASSERT( saturated ) + StgOpApp (StgPrimOp op) args' res_ty + FCallId call -> ASSERT( saturated ) + StgOpApp (StgFCallOp call (idUnique f)) args' res_ty + _other -> StgApp f args' -coreArgsToStg env (Type ty : as) -- Discard type arguments - = coreArgsToStg env as + 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. + ) -coreArgsToStg env (a:as) - = coreArgToStg env a `thenUs` \ (bs1, a') -> - coreArgsToStg env as `thenUs` \ (bs2, as') -> - returnUs (bs1 ++ bs2, a' : as') --- This is where we arrange that a non-trivial argument is let-bound -coreArgToStg :: StgEnv -> CoreArg -> UniqSM ([StgFloatBind], StgArg) +-- --------------------------------------------------------------------------- +-- Argument lists +-- This is the guy that turns applications into A-normal form +-- --------------------------------------------------------------------------- -coreArgToStg env arg - = coreExprToStgFloat env arg `thenUs` \ (binds, arg') -> - case (binds, arg') of - ([], StgCon con [] _) | isWHNFCon con -> returnUs ([], StgConArg con) - ([], StgApp v []) -> returnUs ([], StgVarArg v) +coreToStgArgs :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo) +coreToStgArgs [] + = returnLne ([], emptyFVInfo) - -- A non-trivial argument: we must let (or case-bind) - -- We don't do the case part here... we leave that to mkStgBinds +coreToStgArgs (Type ty : args) -- Type argument + = coreToStgArgs args `thenLne` \ (args', fvs) -> + if opt_RuntimeTypes then + returnLne (StgTypeArg ty : args', fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType ty)) + else + returnLne (args', fvs) - -- Further complication: if we're converting this binding into - -- a case, then try to avoid generating any case-of-case - -- expressions by pulling out the floats. - (_, other) -> - newStgVar ty `thenUs` \ v -> - if isUnLiftedType ty - then returnUs (binds ++ [CaseBind v arg'], StgVarArg v) - else returnUs ([LetBind v (mkStgBinds binds arg')], StgVarArg v) - where - ty = coreExprType arg +coreToStgArgs (arg : args) -- Non-type argument + = coreToStgArgs args `thenLne` \ (stg_args, args_fvs) -> + coreToStgExpr arg `thenLne` \ (arg', arg_fvs, escs) -> + let + fvs = args_fvs `unionFVInfo` arg_fvs + stg_arg = case arg' of + StgApp v [] -> StgVarArg v + StgConApp con [] -> StgVarArg (dataConWorkId con) + StgLit lit -> StgLitArg lit + _ -> pprPanic "coreToStgArgs" (ppr arg) + in + returnLne (stg_arg : stg_args, fvs) -\end{code} +-- --------------------------------------------------------------------------- +-- The magic for lets: +-- --------------------------------------------------------------------------- -%************************************************************************ -%* * -\subsection[coreToStg-exprs]{Converting core expressions} -%* * -%************************************************************************ +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 -\begin{code} -coreExprToStg :: StgEnv -> CoreExpr -> UniqSM StgExpr +coreToStgLet let_no_escape bind body + = fixLne (\ ~(_, _, _, _, _, rec_body_fvs, _, _) -> -coreExprToStg env (Var var) - = returnUs (StgApp (stgLookup env var) []) + -- Do the bindings, setting live_in_cont to empty if + -- we ain't in a let-no-escape world + getVarsLiveInCont `thenLne` \ live_in_cont -> + setVarsLiveInCont (if let_no_escape + then live_in_cont + else emptyLiveInfo) + (vars_bind rec_body_fvs bind) + `thenLne` \ ( bind2, bind_fvs, bind_escs, bind_lv_info, env_ext) -> -\end{code} + -- Do the body + extendVarEnvLne env_ext ( + coreToStgExpr body `thenLne` \(body2, body_fvs, body_escs) -> + freeVarsToLiveVars body_fvs `thenLne` \ body_lv_info -> -%************************************************************************ -%* * -\subsubsection[coreToStg-lambdas]{Lambda abstractions} -%* * -%************************************************************************ + returnLne (bind2, bind_fvs, bind_escs, getLiveVars bind_lv_info, + body2, body_fvs, body_escs, getLiveVars body_lv_info) + ) -\begin{code} -coreExprToStg env expr@(Lam _ _) - = let - (binders, body) = collectBinders expr - id_binders = filter isId binders + ) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs, + body2, body_fvs, body_escs, body_lvs) -> + + + -- Compute the new let-expression + let + new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2 + | otherwise = StgLet bind2 body2 + + free_in_whole_let + = binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs) + + live_in_whole_let + = bind_lvs `unionVarSet` (body_lvs `delVarSetList` binders) + + real_bind_escs = if let_no_escape then + bind_escs + else + getFVSet bind_fvs + -- Everything escapes which is free in the bindings + + let_escs = (real_bind_escs `unionVarSet` body_escs) `delVarSetList` binders + + all_escs = bind_escs `unionVarSet` body_escs -- Still includes binders of + -- this let(rec) + + no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs) + +#ifdef DEBUG + -- Debugging code as requested by Andrew Kennedy + checked_no_binder_escapes + | not no_binder_escapes && any is_join_var binders + = pprTrace "Interesting! A join var that isn't let-no-escaped" (ppr binders) + False + | otherwise = no_binder_escapes +#else + checked_no_binder_escapes = no_binder_escapes +#endif + + -- Mustn't depend on the passed-in let_no_escape flag, since + -- no_binder_escapes is used by the caller to derive the flag! in - newLocalIds env id_binders `thenUs` \ (env', binders') -> - coreExprToStg env' body `thenUs` \ stg_body -> + returnLne ( + new_let, + free_in_whole_let, + let_escs, + checked_no_binder_escapes + )) + where + set_of_binders = mkVarSet binders + binders = bindersOf bind - if null id_binders then -- it was all type/usage binders; tossed - returnUs stg_body - else - case stg_body of - - -- if the body reduced to a lambda too... - (StgLet (StgNonRec var (StgRhsClosure cc bi srt fvs uf args body)) - (StgApp var' [])) - | var == var' -> - returnUs (StgLet (StgNonRec var - (StgRhsClosure noCCS - stgArgOcc - noSRT - bOGUS_FVs - ReEntrant - (binders' ++ args) - body)) - (StgApp var [])) - - other -> - - -- We must let-bind the lambda - newStgVar (coreExprType expr) `thenUs` \ var -> - returnUs - (StgLet (StgNonRec var (StgRhsClosure noCCS - stgArgOcc - noSRT - bOGUS_FVs - ReEntrant -- binders is non-empty - binders' - stg_body)) - (StgApp var [])) -\end{code} + mk_binding bind_lv_info binder rhs + = (binder, LetBound (NestedLet live_vars) (manifestArity rhs)) + where + live_vars | let_no_escape = addLiveVar bind_lv_info binder + | otherwise = unitLiveVar binder + -- c.f. the invariant on NestedLet -%************************************************************************ -%* * -\subsubsection[coreToStg-let(rec)]{Let and letrec expressions} -%* * -%************************************************************************ + vars_bind :: FreeVarsInfo -- Free var info for body of binding + -> CoreBind + -> LneM (StgBinding, + FreeVarsInfo, + EscVarsSet, -- free vars; escapee vars + LiveInfo, -- Vars and CAFs live in binding + [(Id, HowBound)]) -- extension to environment + + + vars_bind body_fvs (NonRec binder rhs) + = coreToStgRhs body_fvs [] (binder,rhs) + `thenLne` \ (rhs2, bind_fvs, bind_lv_info, escs) -> + let + env_ext_item = mk_binding bind_lv_info binder rhs + in + returnLne (StgNonRec binder rhs2, + bind_fvs, escs, bind_lv_info, [env_ext_item]) + + + vars_bind body_fvs (Rec pairs) + = fixLne (\ ~(_, rec_rhs_fvs, _, bind_lv_info, _) -> + let + rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs + binders = map fst pairs + env_ext = [ mk_binding bind_lv_info b rhs + | (b,rhs) <- pairs ] + in + extendVarEnvLne env_ext ( + mapAndUnzip4Lne (coreToStgRhs rec_scope_fvs binders) pairs + `thenLne` \ (rhss2, fvss, lv_infos, escss) -> + let + bind_fvs = unionFVInfos fvss + bind_lv_info = foldr unionLiveInfo emptyLiveInfo lv_infos + escs = unionVarSets escss + in + returnLne (StgRec (binders `zip` rhss2), + bind_fvs, escs, bind_lv_info, env_ext) + ) + ) + +is_join_var :: Id -> Bool +-- A hack (used only for compiler debuggging) to tell if +-- a variable started life as a join point ($j) +is_join_var j = occNameUserString (getOccName j) == "$j" +\end{code} \begin{code} -coreExprToStg env (Let bind body) - = coreBindToStg env bind `thenUs` \ (stg_binds, new_env) -> - coreExprToStg new_env body `thenUs` \ stg_body -> - returnUs (foldr StgLet stg_body stg_binds) +coreToStgRhs :: FreeVarsInfo -- Free var info for the scope of the binding + -> [Id] + -> (Id,CoreExpr) + -> LneM (StgRhs, FreeVarsInfo, LiveInfo, EscVarsSet) + +coreToStgRhs scope_fv_info binders (bndr, rhs) + = coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, rhs_escs) -> + getEnvLne `thenLne` \ env -> + freeVarsToLiveVars (binders `minusFVBinders` rhs_fvs) `thenLne` \ lv_info -> + returnLne (mkStgRhs rhs_fvs (mkSRT lv_info) bndr_info new_rhs, + rhs_fvs, lv_info, rhs_escs) + where + bndr_info = lookupFVInfo scope_fv_info bndr + +mkStgRhs :: FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr -> StgRhs + +mkStgRhs rhs_fvs srt binder_info (StgConApp con args) + = StgRhsCon noCCS con args + +mkStgRhs rhs_fvs srt binder_info (StgLam _ bndrs body) + = StgRhsClosure noCCS binder_info + (getFVs rhs_fvs) + ReEntrant + srt bndrs body + +mkStgRhs rhs_fvs srt binder_info rhs + = StgRhsClosure noCCS binder_info + (getFVs rhs_fvs) + upd_flag srt [] rhs + where + upd_flag = Updatable + {- + SDM: disabled. Eval/Apply can't handle functions with arity zero very + well; and making these into simple non-updatable thunks breaks other + assumptions (namely that they will be entered only once). + + upd_flag | isPAP env rhs = ReEntrant + | otherwise = Updatable + -} + +{- ToDo: + upd = if isOnceDem dem + then (if isNotTop toplev + then SingleEntry -- HA! Paydirt for "dem" + else +#ifdef DEBUG + trace "WARNING: SE CAFs unsupported, forcing UPD instead" $ +#endif + Updatable) + else Updatable + -- For now we forbid SingleEntry CAFs; they tickle the + -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link, + -- and I don't understand why. There's only one SE_CAF (well, + -- only one that tickled a great gaping bug in an earlier attempt + -- at ClosureInfo.getEntryConvention) in the whole of nofib, + -- specifically Main.lvl6 in spectral/cryptarithm2. + -- So no great loss. KSW 2000-07. +-} \end{code} +Detect thunks which will reduce immediately to PAPs, and make them +non-updatable. This has several advantages: + + - the non-updatable thunk behaves exactly like the PAP, + + - the thunk is more efficient to enter, because it is + specialised to the task. + + - we save one update frame, one stg_update_PAP, one update + and lots of PAP_enters. + + - in the case where the thunk is top-level, we save building + a black hole and futhermore the thunk isn't considered to + be a CAF any more, so it doesn't appear in any SRTs. + +We do it here, because the arity information is accurate, and we need +to do it before the SRT pass to save the SRT entries associated with +any top-level PAPs. + +isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args + where + arity = stgArity f (lookupBinding env f) +isPAP env _ = False + %************************************************************************ %* * -\subsubsection[coreToStg-scc]{SCC expressions} +\subsection[LNE-monad]{A little monad for this let-no-escaping pass} %* * %************************************************************************ -Covert core @scc@ expression directly to STG @scc@ expression. -\begin{code} -coreExprToStg env (Note (SCC cc) expr) - = coreExprToStg env expr `thenUs` \ stg_expr -> - returnUs (StgSCC cc stg_expr) -\end{code} +There's a lot of stuff to pass around, so we use this @LneM@ monad to +help. All the stuff here is only passed *down*. \begin{code} -coreExprToStg env (Note other_note expr) = coreExprToStg env expr +type LneM a = IdEnv HowBound + -> LiveInfo -- Vars and CAFs live in continuation + -> a + +type LiveInfo = (StgLiveVars, -- Dynamic live variables; + -- i.e. ones with a nested (non-top-level) binding + CafSet) -- Static live variables; + -- i.e. top-level variables that are CAFs or refer to them + +type EscVarsSet = IdSet +type CafSet = IdSet + +data HowBound + = ImportBound -- Used only as a response to lookupBinding; never + -- exists in the range of the (IdEnv HowBound) + + | LetBound -- A let(rec) in this module + LetInfo -- Whether top level or nested + Arity -- Its arity (local Ids don't have arity info at this point) + + | LambdaBound -- Used for both lambda and case + +data LetInfo + = TopLet -- top level things + | NestedLet LiveInfo -- For nested things, what is live if this + -- thing is live? Invariant: the binder + -- itself is always a member of + -- the dynamic set of its own LiveInfo + +isLetBound (LetBound _ _) = True +isLetBound other = False + +topLevelBound ImportBound = True +topLevelBound (LetBound TopLet _) = True +topLevelBound other = False \end{code} -The rest are handled by coreExprStgFloat. +For a let(rec)-bound variable, x, we record LiveInfo, the set of +variables that are live if x is live. This LiveInfo comprises + (a) dynamic live variables (ones with a non-top-level binding) + (b) static live variabes (CAFs or things that refer to CAFs) + +For "normal" variables (a) is just x alone. If x is a let-no-escaped +variable then x is represented by a code pointer and a stack pointer +(well, one for each stack). So all of the variables needed in the +execution of x are live if x is, and are therefore recorded in the +LetBound constructor; x itself *is* included. + +The set of dynamic live variables is guaranteed ot have no further let-no-escaped +variables in it. \begin{code} -coreExprToStg env expr - = coreExprToStgFloat env expr `thenUs` \ (binds,stg_expr) -> - returnUs (mkStgBinds binds stg_expr) +emptyLiveInfo :: LiveInfo +emptyLiveInfo = (emptyVarSet,emptyVarSet) + +unitLiveVar :: Id -> LiveInfo +unitLiveVar lv = (unitVarSet lv, emptyVarSet) + +unitLiveCaf :: Id -> LiveInfo +unitLiveCaf caf = (emptyVarSet, unitVarSet caf) + +addLiveVar :: LiveInfo -> Id -> LiveInfo +addLiveVar (lvs, cafs) id = (lvs `extendVarSet` id, cafs) + +unionLiveInfo :: LiveInfo -> LiveInfo -> LiveInfo +unionLiveInfo (lv1,caf1) (lv2,caf2) = (lv1 `unionVarSet` lv2, caf1 `unionVarSet` caf2) + +mkSRT :: LiveInfo -> SRT +mkSRT (_, cafs) = SRTEntries cafs + +getLiveVars :: LiveInfo -> StgLiveVars +getLiveVars (lvs, _) = lvs \end{code} -%************************************************************************ -%* * -\subsubsection[coreToStg-applications]{Applications} -%* * -%************************************************************************ +The std monad functions: \begin{code} -coreExprToStgFloat env expr@(App _ _) - = let - (fun,args) = collect_args expr [] - in - coreArgsToStg env args `thenUs` \ (binds, stg_args) -> - - -- 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 (binds, - StgApp (stgLookup env fun_id) stg_args) - - (non_var_fun, []) -> -- No value args, so recurse into the function - ASSERT( null binds ) - coreExprToStg env non_var_fun `thenUs` \e -> - returnUs ([], e) - - other -> -- A non-variable applied to things; better let-bind it. - newStgVar (coreExprType fun) `thenUs` \ fun_id -> - coreExprToStg env fun `thenUs` \ (stg_fun) -> - let - fun_rhs = StgRhsClosure noCCS -- No cost centre (ToDo?) - stgArgOcc - noSRT - bOGUS_FVs - SingleEntry -- Only entered once - [] - stg_fun - in - returnUs (binds, - StgLet (StgNonRec fun_id fun_rhs) $ - StgApp fun_id stg_args) +initLne :: IdEnv HowBound -> LneM a -> a +initLne env m = m env emptyLiveInfo + + + +{-# INLINE thenLne #-} +{-# INLINE returnLne #-} + +returnLne :: a -> LneM a +returnLne e env lvs_cont = e + +thenLne :: LneM a -> (a -> LneM b) -> LneM b +thenLne m k env lvs_cont + = k (m env lvs_cont) env lvs_cont + +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) + +mapAndUnzip4Lne :: (a -> LneM (b,c,d,e)) -> [a] -> LneM ([b],[c],[d],[e]) + +mapAndUnzip4Lne f [] = returnLne ([],[],[],[]) +mapAndUnzip4Lne f (x:xs) + = f x `thenLne` \ (r1, r2, r3, r4) -> + mapAndUnzip4Lne f xs `thenLne` \ (rs1, rs2, rs3, rs4) -> + returnLne (r1:rs1, r2:rs2, r3:rs3, r4:rs4) + +fixLne :: (a -> LneM a) -> LneM a +fixLne expr env lvs_cont + = result where - -- Collect arguments - collect_args (App fun arg) args = collect_args fun (arg:args) - collect_args (Note (Coerce _ _) expr) args = collect_args expr args - collect_args (Note InlineCall expr) args = collect_args expr args - collect_args fun args = (fun, args) + result = expr result env lvs_cont \end{code} -%************************************************************************ -%* * -\subsubsection[coreToStg-con]{Constructors} -%* * -%************************************************************************ +Functions specific to this monad: \begin{code} -coreExprToStgFloat env expr@(Con (PrimOp (CCallOp (Right _) a b c)) args) - = getUniqueUs `thenUs` \ u -> - coreArgsToStg env args `thenUs` \ (binds, stg_atoms) -> - let con' = PrimOp (CCallOp (Right u) a b c) in - returnUs (binds, StgCon con' stg_atoms (coreExprType expr)) - --- for dataToTag#, we need to make sure the argument is evaluated first. -coreExprToStgFloat env expr@(Con op@(PrimOp DataToTagOp) [Type ty, a]) - = newStgVar ty `thenUs` \ v -> - coreArgToStg env a `thenUs` \ (binds, arg) -> - let e = case arg of - StgVarArg v -> StgApp v [] - StgConArg c -> StgCon c [] (coreExprType a) - in - returnUs (binds ++ [CaseBind v e], StgCon op [StgVarArg v] (coreExprType expr)) +getVarsLiveInCont :: LneM LiveInfo +getVarsLiveInCont env lvs_cont = lvs_cont -coreExprToStgFloat env expr@(Con con args) - = coreArgsToStg env args `thenUs` \ (binds, stg_atoms) -> - returnUs (binds, StgCon con stg_atoms (coreExprType expr)) -\end{code} +setVarsLiveInCont :: LiveInfo -> LneM a -> LneM a +setVarsLiveInCont new_lvs_cont expr env lvs_cont + = expr env new_lvs_cont -%************************************************************************ -%* * -\subsubsection[coreToStg-cases]{Case expressions} -%* * -%************************************************************************ +extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a +extendVarEnvLne ids_w_howbound expr env lvs_cont + = expr (extendVarEnvList env ids_w_howbound) lvs_cont -\begin{code} -coreExprToStgFloat env expr@(Case scrut bndr alts) - = coreExprToStgFloat env scrut `thenUs` \ (binds, scrut') -> - newLocalId env bndr `thenUs` \ (env', bndr') -> - alts_to_stg env' (findDefault alts) `thenUs` \ alts' -> - returnUs (binds, mkStgCase scrut' bndr' alts') +lookupVarLne :: Id -> LneM HowBound +lookupVarLne v env lvs_cont = returnLne (lookupBinding env v) env lvs_cont + +getEnvLne :: LneM (IdEnv HowBound) +getEnvLne env lvs_cont = returnLne env env lvs_cont + +lookupBinding :: IdEnv HowBound -> Id -> HowBound +lookupBinding env v = case lookupVarEnv env v of + Just xx -> xx + Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound + + +-- The result of lookupLiveVarsForSet, a set of live variables, is +-- only ever tacked onto a decorated expression. It is never used as +-- the basis of a control decision, which might give a black hole. + +freeVarsToLiveVars :: FreeVarsInfo -> LneM LiveInfo +freeVarsToLiveVars fvs env live_in_cont + = returnLne live_info env live_in_cont where - 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 (StgPrimAlts scrut_ty alts' deflt') - - | otherwise - = default_to_stg env deflt `thenUs` \ deflt' -> - mapUs (alg_alt_to_stg env) alts `thenUs` \ alts' -> - returnUs (StgAlgAlts scrut_ty alts' deflt') - - alg_alt_to_stg env (DataCon con, bs, rhs) - = coreExprToStg env rhs `thenUs` \ stg_rhs -> - returnUs (con, filter isId bs, [ True | b <- 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 `thenUs` \ stg_rhs -> - returnUs (lit, stg_rhs) - - default_to_stg env Nothing - = returnUs StgNoDefault - - default_to_stg env (Just rhs) - = coreExprToStg env rhs `thenUs` \ stg_rhs -> - returnUs (StgBindDefault stg_rhs) - -- The binder is used for prim cases and not otherwise - -- (hack for old code gen) -\end{code} + live_info = foldr unionLiveInfo live_in_cont lvs_from_fvs + lvs_from_fvs = map do_one (allFreeIds fvs) -\begin{code} -coreExprToStgFloat env expr - = coreExprToStg env expr `thenUs` \stg_expr -> - returnUs ([], stg_expr) + do_one (v, how_bound) + = case how_bound of + ImportBound -> unitLiveCaf v -- Only CAF imports are + -- recorded in fvs + LetBound TopLet _ + | mayHaveCafRefs (idCafInfo v) -> unitLiveCaf v + | otherwise -> emptyLiveInfo + + LetBound (NestedLet lvs) _ -> lvs -- lvs already contains v + -- (see the invariant on NestedLet) + + _lambda_or_case_binding -> unitLiveVar v -- Bound by lambda or case \end{code} %************************************************************************ %* * -\subsection[coreToStg-misc]{Miscellaneous helping functions} +\subsection[Free-var info]{Free variable information} %* * %************************************************************************ -There's not anything interesting we can ASSERT about \tr{var} if it -isn't in the StgEnv. (WDP 94/06) - \begin{code} -stgLookup :: StgEnv -> Id -> Id -stgLookup env var = case (lookupVarEnv env var) of - Nothing -> var - Just var -> var +type FreeVarsInfo = VarEnv (Var, HowBound, StgBinderInfo) + -- The Var is so we can gather up the free variables + -- as a set. + -- + -- The HowBound info just saves repeated lookups; + -- we look up just once when we encounter the occurrence. + -- INVARIANT: Any ImportBound Ids are HaveCafRef Ids + -- Imported Ids without CAF refs are simply + -- not put in the FreeVarsInfo for an expression. + -- See singletonFVInfo and freeVarsToLiveVars + -- + -- StgBinderInfo records how it occurs; notably, we + -- are interested in whether it only occurs in saturated + -- applications, because then we don't need to build a + -- curried version. + -- If f is mapped to noBinderInfo, that means + -- that f *is* mentioned (else it wouldn't be in the + -- IdEnv at all), but perhaps in an unsaturated applications. + -- + -- All case/lambda-bound things are also mapped to + -- noBinderInfo, since we aren't interested in their + -- occurence info. + -- + -- For ILX we track free var info for type variables too; + -- hence VarEnv not IdEnv \end{code} -Invent a fresh @Id@: \begin{code} -newStgVar :: Type -> UniqSM Id -newStgVar ty - = getUniqueUs `thenUs` \ uniq -> - returnUs (mkSysLocal SLIT("stg") uniq ty) +emptyFVInfo :: FreeVarsInfo +emptyFVInfo = emptyVarEnv + +singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo +-- Don't record non-CAF imports at all, to keep free-var sets small +singletonFVInfo id ImportBound info + | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, ImportBound, info) + | otherwise = emptyVarEnv +singletonFVInfo id how_bound info = unitVarEnv id (id, how_bound, info) + +tyvarFVInfo :: TyVarSet -> FreeVarsInfo +tyvarFVInfo tvs = foldVarSet add emptyFVInfo tvs + where + add tv fvs = extendVarEnv fvs tv (tv, LambdaBound, noBinderInfo) + -- Type variables must be lambda-bound + +unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo +unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2 + +unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo +unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs + +minusFVBinders :: [Id] -> FreeVarsInfo -> FreeVarsInfo +minusFVBinders vs fv = foldr minusFVBinder fv vs + +minusFVBinder :: Id -> FreeVarsInfo -> FreeVarsInfo +minusFVBinder v fv | isId v && opt_RuntimeTypes + = (fv `delVarEnv` v) `unionFVInfo` + tyvarFVInfo (tyVarsOfType (idType v)) + | otherwise = fv `delVarEnv` v + -- When removing a binder, remember to add its type variables + -- c.f. CoreFVs.delBinderFV + +elementOfFVInfo :: Id -> FreeVarsInfo -> Bool +elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id) + +lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo +-- Find how the given Id is used. +-- Externally visible things may be used any old how +lookupFVInfo fvs id + | isExternalName (idName id) = noBinderInfo + | otherwise = case lookupVarEnv fvs id of + Nothing -> noBinderInfo + Just (_,_,info) -> info + +allFreeIds :: FreeVarsInfo -> [(Id,HowBound)] -- Both top level and non-top-level Ids +allFreeIds fvs = [(id,how_bound) | (id,how_bound,_) <- rngVarEnv fvs, isId id] + +-- Non-top-level things only, both type variables and ids +-- (type variables only if opt_RuntimeTypes) +getFVs :: FreeVarsInfo -> [Var] +getFVs fvs = [id | (id, how_bound, _) <- rngVarEnv fvs, + not (topLevelBound how_bound) ] + +getFVSet :: FreeVarsInfo -> VarSet +getFVSet fvs = mkVarSet (getFVs fvs) + +plusFVInfo (id1,hb1,info1) (id2,hb2,info2) + = ASSERT (id1 == id2 && hb1 `check_eq_how_bound` hb2) + (id1, hb1, combineStgBinderInfo info1 info2) + +#ifdef DEBUG +-- The HowBound info for a variable in the FVInfo should be consistent +check_eq_how_bound ImportBound ImportBound = True +check_eq_how_bound LambdaBound LambdaBound = True +check_eq_how_bound (LetBound li1 ar1) (LetBound li2 ar2) = ar1 == ar2 && check_eq_li li1 li2 +check_eq_how_bound hb1 hb2 = False + +check_eq_li (NestedLet _) (NestedLet _) = True +check_eq_li TopLet TopLet = True +check_eq_li li1 li2 = False +#endif \end{code} +Misc. \begin{code} -newLocalId env id - | externallyVisibleId id - = returnUs (env, id) - - | otherwise - = -- Local binder, give it a new unique Id. - getUniqueUs `thenUs` \ uniq -> - let - id' = setIdUnique id uniq - new_env = extendVarEnv env id id' - in - returnUs (new_env, id') - -newLocalIds :: StgEnv -> [Id] -> UniqSM (StgEnv, [Id]) -newLocalIds env [] - = returnUs (env, []) -newLocalIds env (b:bs) - = newLocalId env b `thenUs` \ (env', b') -> - newLocalIds env' bs `thenUs` \ (env'', bs') -> - returnUs (env'', b':bs') +filterStgBinders :: [Var] -> [Var] +filterStgBinders bndrs + | opt_RuntimeTypes = bndrs + | otherwise = filter isId bndrs \end{code} \begin{code} -mkStgBinds :: [StgFloatBind] -> StgExpr -> StgExpr -mkStgBinds binds body = foldr mkStgBind body binds - -mkStgBind (CaseBind bndr rhs) body - | isUnLiftedType bndr_ty - = mkStgCase rhs bndr (StgPrimAlts bndr_ty [] (StgBindDefault body)) - | otherwise - = mkStgCase rhs bndr (StgAlgAlts bndr_ty [] (StgBindDefault body)) + -- Ignore all notes except SCC +myCollectBinders expr + = go [] expr where - bndr_ty = idType bndr - -mkStgBind (LetBind bndr rhs) body - | isUnboxedTupleType bndr_ty - = panic "mkStgBinds: unboxed tuple" - | isUnLiftedType bndr_ty - = mkStgCase rhs bndr (StgPrimAlts bndr_ty [] (StgBindDefault body)) - - | otherwise - = StgLet (StgNonRec bndr (exprToRhs rhs)) body + 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 - bndr_ty = idType bndr + 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} -mkStgCase (StgLet bind expr) bndr alts - = StgLet bind (mkStgCase expr bndr alts) -mkStgCase scrut bndr alts - = StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT alts +\begin{code} +stgArity :: Id -> HowBound -> Arity +stgArity f (LetBound _ arity) = arity +stgArity f ImportBound = idArity f +stgArity f LambdaBound = 0 \end{code}