X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FstgSyn%2FCoreToStg.lhs;h=824cabaacbd51c1468cf5ea6d56c8143c3a5edfc;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=5615a2c616515d7cd1469231804e4f67ebc5061b;hpb=4d64d1b1604078abef9b4d5dd31e4dfcd5f35649;p=ghc-hetmet.git diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 5615a2c..824caba 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -12,33 +12,31 @@ module CoreToStg ( coreToStg, coreExprToStg ) where #include "HsVersions.h" import CoreSyn -import CoreFVs -import CoreUtils -import SimplUtils +import CoreUtils ( rhsIsStatic, manifestArity, exprType, findDefault ) import StgSyn import Type import TyCon ( isAlgTyCon ) import Id +import Var ( Var, globalIdDetails, idType ) +import TyCon ( isUnboxedTupleTyCon, isPrimTyCon, isFunTyCon, isHiBootTyCon ) +#ifdef ILX +import MkId ( unsafeCoerceId ) +#endif import IdInfo import DataCon import CostCentre ( noCCS ) import VarSet import VarEnv -import DataCon ( dataConWrapId ) -import IdInfo ( OccInfo(..) ) -import PrimOp ( PrimOp(..), ccallMayGC ) -import TysPrim ( foreignObjPrimTyCon ) -import Maybes ( maybeToBool, orElse ) -import Name ( getOccName ) -import Module ( Module ) -import OccName ( occNameUserString ) -import BasicTypes ( TopLevelFlag(..), isNotTopLevel ) -import CmdLineOpts ( DynFlags ) +import Maybes ( maybeToBool ) +import Name ( getOccName, isExternalName, nameOccName ) +import OccName ( occNameString, occNameFS ) +import BasicTypes ( Arity ) +import Packages ( HomeModules ) +import StaticFlags ( opt_RuntimeTypes ) import Outputable -import PprCore -infixr 9 `thenLne`, `thenLne_` +infixr 9 `thenLne` \end{code} %************************************************************************ @@ -92,183 +90,191 @@ if @v@ is. %************************************************************************ %* * -\subsection[binds-StgVarInfo]{Setting variable info: top-level, binds, RHSs} +\subsection[caf-info]{Collecting live CAF info} %* * %************************************************************************ -\begin{code} -coreToStg :: DynFlags -> Module -> [CoreBind] -> IO [StgBinding] -coreToStg dflags this_mod pgm - = return (fst (initLne (coreTopBindsToStg pgm))) +In this pass we also collect information on which CAFs are live for +constructing SRTs (see SRT.lhs). -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 - ) - ) +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 -coreTopBindToStg - :: [Id] -- New binders (with correct arity) - -> FreeVarsInfo -- Info about the body - -> CoreBind - -> LneM (StgBinding, FreeVarsInfo) +The CafInfo has already been calculated during the CoreTidy pass. -coreTopBindToStg [binder] body_fvs (NonRec _ rhs) - = coreToStgRhs body_fvs TopLevel (binder,rhs) `thenLne` \ (rhs2, fvs, _) -> - returnLne (StgNonRec binder rhs2, fvs) +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). -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 +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. + + +Interaction of let-no-escape with SRTs [Sept 01] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + let-no-escape x = ...caf1...caf2... in - returnLne (StgRec (binders `zip` rhss2), fvs) - ) -\end{code} + ...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[binds-StgVarInfo]{Setting variable info: top-level, binds, RHSs} +%* * +%************************************************************************ \begin{code} -coreToStgRhs - :: FreeVarsInfo -- Free var info for the scope of the binding - -> TopLevelFlag - -> (Id,CoreExpr) - -> LneM (StgRhs, FreeVarsInfo, EscVarsSet) - -coreToStgRhs scope_fv_info top (binder, rhs) - = coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, rhs_escs) -> - case new_rhs of - - StgLam _ bndrs body - -> let binder_info = lookupFVInfo scope_fv_info binder - in returnLne (StgRhsClosure noCCS - binder_info - noSRT - (getFVs rhs_fvs) - ReEntrant - bndrs - body, - rhs_fvs, rhs_escs) - - StgConApp con args - | isNotTopLevel top || not (isDllConApp con args) - -> returnLne (StgRhsCon noCCS con args, rhs_fvs, rhs_escs) - - _other_expr - -> let binder_info = lookupFVInfo scope_fv_info binder - in returnLne (StgRhsClosure noCCS - binder_info - noSRT - (getFVs rhs_fvs) - (updatable [] new_rhs) - [] - new_rhs, - rhs_fvs, rhs_escs - ) - -updatable args body | null args && isPAP body = ReEntrant - | otherwise = Updatable -{- ToDo: - upd = if isOnceDem dem - then (if isNotTop toplev - then SingleEntry -- HA! Paydirt for "dem" - else -#ifdef DEBUG - trace "WARNING: SE CAFs unsupported, forcing UPD instead" $ -#endif - Updatable) - else Updatable - -- For now we forbid SingleEntry CAFs; they tickle the - -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link, - -- and I don't understand why. There's only one SE_CAF (well, - -- only one that tickled a great gaping bug in an earlier attempt - -- at ClosureInfo.getEntryConvention) in the whole of nofib, - -- specifically Main.lvl6 in spectral/cryptarithm2. - -- So no great loss. KSW 2000-07. --} -\end{code} +coreToStg :: HomeModules -> [CoreBind] -> IO [StgBinding] +coreToStg hmods pgm + = return pgm' + where (_, _, pgm') = coreTopBindsToStg hmods emptyVarEnv pgm -Detect thunks which will reduce immediately to PAPs, and make them -non-updatable. This has several advantages: +coreExprToStg :: CoreExpr -> StgExpr +coreExprToStg expr + = new_expr where (new_expr,_,_) = initLne emptyVarEnv (coreToStgExpr expr) - - the non-updatable thunk behaves exactly like the PAP, - - the thunk is more efficient to enter, because it is - specialised to the task. +coreTopBindsToStg + :: HomeModules + -> IdEnv HowBound -- environment for the bindings + -> [CoreBind] + -> (IdEnv HowBound, FreeVarsInfo, [StgBinding]) - - we save one update frame, one stg_update_PAP, one update - and lots of PAP_enters. +coreTopBindsToStg hmods env [] = (env, emptyFVInfo, []) +coreTopBindsToStg hmods env (b:bs) + = (env2, fvs2, b':bs') + where + -- env accumulates down the list of binds, fvs accumulates upwards + (env1, fvs2, b' ) = coreTopBindToStg hmods env fvs1 b + (env2, fvs1, bs') = coreTopBindsToStg hmods env1 bs - - 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. +coreTopBindToStg + :: HomeModules + -> IdEnv HowBound + -> FreeVarsInfo -- Info about the body + -> CoreBind + -> (IdEnv HowBound, FreeVarsInfo, StgBinding) + +coreTopBindToStg hmods 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 hmods 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 hmods 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 hmods 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) -\begin{code} -isPAP (StgApp f args) = idArity f > length args -isPAP _ = False +#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} --- --------------------------------------------------------------------------- --- Atoms --- --------------------------------------------------------------------------- +\begin{code} +coreToTopStgRhs + :: HomeModules + -> FreeVarsInfo -- Free var info for the scope of the binding + -> (Id,CoreExpr) + -> LneM (StgRhs, FreeVarsInfo) -coreToStgAtoms :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo) -coreToStgAtoms atoms - = let val_atoms = filter isValArg atoms in - mapAndUnzipLne coreToStgAtom val_atoms `thenLne` \ (args', fvs_lists) -> - returnLne (args', unionFVInfos fvs_lists) +coreToTopStgRhs hmods 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 - coreToStgAtom e - = coreToStgExpr e `thenLne` \ (expr, fvs, escs) -> - case expr of - StgApp v [] -> returnLne (StgVarArg v, fvs) - StgConApp con [] -> returnLne (StgVarArg (dataConWrapId con), fvs) - StgLit lit -> returnLne (StgLitArg lit, fvs) - _ -> pprPanic "coreToStgAtom" (ppr expr) + bndr_info = lookupFVInfo scope_fv_info bndr + is_static = rhsIsStatic hmods rhs + +mkTopStgRhs :: Bool -> FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr + -> StgRhs + +mkTopStgRhs is_static rhs_fvs srt binder_info (StgLam _ bndrs body) + = ASSERT( is_static ) + StgRhsClosure noCCS binder_info + (getFVs rhs_fvs) + ReEntrant + srt + bndrs body + +mkTopStgRhs is_static rhs_fvs srt binder_info (StgConApp con args) + | is_static -- StgConApps can be updatable (see isCrossDllConApp) + = StgRhsCon noCCS con args + +mkTopStgRhs is_static rhs_fvs srt binder_info rhs + = ASSERT2( not is_static, ppr rhs ) + StgRhsClosure noCCS binder_info + (getFVs rhs_fvs) + Updatable + srt + [] rhs +\end{code} + -- --------------------------------------------------------------------------- -- Expressions -- --------------------------------------------------------------------------- -{- -@varsExpr@ carries in a monad-ised environment, which binds each -let(rec) variable (ie non top level, not imported, not lambda bound, -not case-alternative bound) to: - - its STG arity, and - - its set of live vars. -For normal variables the set of live vars is just the variable -itself. For let-no-escaped variables, the set of live vars is the set -live at the moment the variable is entered. The set is guaranteed to -have no further let-no-escaped vars in it. --} - +\begin{code} coreToStgExpr :: CoreExpr -> LneM (StgExpr, -- Decorated STG expr @@ -287,152 +293,108 @@ on these components, but it in turn is not scrutinised as the basis for any decisions. Hence no black holes. \begin{code} -coreToStgExpr (Lit l) = returnLne (StgLit l, emptyFVInfo, emptyVarSet) - -coreToStgExpr (Var v) - = coreToStgApp Nothing v [] +coreToStgExpr (Lit l) = returnLne (StgLit l, emptyFVInfo, emptyVarSet) +coreToStgExpr (Var v) = coreToStgApp Nothing v [] coreToStgExpr expr@(App _ _) - = let (f, args) = myCollectArgs expr - in - coreToStgApp Nothing (shouldBeVar f) args + = coreToStgApp Nothing f args + where + (f, args) = myCollectArgs expr coreToStgExpr expr@(Lam _ _) - = let (args, body) = myCollectBinders expr - args' = filter isId args + = 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 + fvs = args' `minusFVBinders` body_fvs + escs = body_escs `delVarSetList` args' + result_expr | null args' = body + | otherwise = StgLam (exprType expr) args' body in - if null args' - then returnLne (body, fvs, escs) - else returnLne (StgLam (exprType expr) args' body, fvs, escs) + 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) - = getVarsLiveInCont `thenLne` \ live_in_cont -> - extendVarEnvLne [(bndr, CaseBound)] $ - vars_alts (findDefault alts) `thenLne` \ (alts2, alts_fvs, alts_escs) -> - lookupLiveVarsForSet alts_fvs `thenLne` \ alts_lvs -> +coreToStgExpr (Case scrut bndr _ alts) + = extendVarEnvLne [(bndr, LambdaBound)] ( + mapAndUnzip3Lne vars_alt alts `thenLne` \ (alts2, fvs_s, escs_s) -> + returnLne ( alts2, + unionFVInfos fvs_s, + unionVarSets escs_s ) + ) `thenLne` \ (alts2, alts_fvs, alts_escs) -> let - -- determine whether the default binder is dead or not - bndr'= if (bndr `elementOfFVInfo` alts_fvs) - then bndr `setIdOccInfo` NoOccInfo - else bndr `setIdOccInfo` IAmDead - - -- for a _ccall_GC_, some of the *arguments* need to live across the - -- call (see findLiveArgs comments.), so we annotate them as being live - -- in the alts to achieve the desired effect. - mb_live_across_case = - case scrut of - -- ToDo: Notes? - e@(App _ _) | (Var v, args) <- myCollectArgs e, - PrimOpId (CCallOp ccall) <- idFlavour v, - ccallMayGC ccall - -> Just (filterVarSet isForeignObjArg (exprFreeVars e)) - _ -> Nothing + -- 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. - live_in_alts = orElse (FMAP unionVarSet mb_live_across_case) id $ - live_in_cont `unionVarSet` - (alts_lvs `minusVarSet` unitVarSet bndr) + alts_fvs_wo_bndr = bndr `minusFVBinder` alts_fvs + alts_escs_wo_bndr = alts_escs `delVarSet` 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) -> - lookupLiveVarsForSet scrut_fvs `thenLne` \ scrut_lvs -> - let - live_in_whole_case = live_in_alts `unionVarSet` scrut_lvs - 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 ( - mkStgCase scrut2 live_in_whole_case live_in_alts bndr' noSRT alts2, - (scrut_fvs `unionFVInfo` alts_fvs) `minusFVBinders` [bndr], - (alts_escs `minusVarSet` unitVarSet bndr) `unionVarSet` getFVSet scrut_fvs - -- You might think we should have scrut_escs, not (getFVSet scrut_fvs), - -- but actually we can't call, and then return from, a let-no-escape thing. + StgCase scrut2 (getLiveVars scrut_lv_info) + (getLiveVars alts_lv_info) + bndr' + (mkSRT alts_lv_info) + (mkStgAltType (idType bndr) alts) + 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 - scrut_ty = idType bndr - prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty) - - vars_alts (alts,deflt) - | prim_case - = mapAndUnzip3Lne vars_prim_alt alts - `thenLne` \ (alts2, alts_fvs_list, alts_escs_list) -> - let - alts_fvs = unionFVInfos alts_fvs_list - alts_escs = unionVarSets alts_escs_list - in - vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) -> - returnLne ( - mkStgPrimAlts scrut_ty alts2 deflt2, - alts_fvs `unionFVInfo` deflt_fvs, - alts_escs `unionVarSet` deflt_escs - ) - - | otherwise - = mapAndUnzip3Lne vars_alg_alt alts - `thenLne` \ (alts2, alts_fvs_list, alts_escs_list) -> - let - alts_fvs = unionFVInfos alts_fvs_list - alts_escs = unionVarSets alts_escs_list - in - vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) -> - returnLne ( - mkStgAlgAlts scrut_ty alts2 deflt2, - alts_fvs `unionFVInfo` deflt_fvs, - alts_escs `unionVarSet` deflt_escs - ) - - where - vars_prim_alt (LitAlt lit, _, rhs) - = coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) -> - returnLne ((lit, rhs2), rhs_fvs, rhs_escs) - - vars_alg_alt (DataAlt con, binders, rhs) - = let - -- remove type variables - binders' = filter isId binders - in - extendVarEnvLne [(b, CaseBound) | b <- binders'] $ - coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) -> - let - good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders' ] - -- records whether each param is used in the RHS - in - returnLne ( - (con, binders', good_use_mask, rhs2), - rhs_fvs `minusFVBinders` binders', - rhs_escs `minusVarSet` mkVarSet binders' - -- ToDo: remove the minusVarSet; - -- since escs won't include any of these binders - ) - - vars_deflt Nothing - = returnLne (StgNoDefault, emptyFVInfo, emptyVarSet) - - vars_deflt (Just rhs) - = coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) -> - returnLne (StgBindDefault rhs2, rhs_fvs, rhs_escs) - + 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 @@ -448,71 +410,37 @@ coreToStgExpr (Let bind body) returnLne (new_let, fvs, escs) \end{code} -If we've got a case containing a _ccall_GC_ primop, we need to -ensure that the arguments are kept live for the duration of the -call. This only an issue - \begin{code} -isForeignObjArg :: Id -> Bool -isForeignObjArg x = isId x && isForeignObjPrimTy (idType x) - -isForeignObjPrimTy ty - = case splitTyConApp_maybe ty of - Just (tycon, _) -> tycon == foreignObjPrimTyCon - Nothing -> False -\end{code} +mkStgAltType scrut_ty alts + = case splitTyConApp_maybe (repType scrut_ty) of + Just (tc,_) | isUnboxedTupleTyCon tc -> UbxTupAlt tc + | isPrimTyCon tc -> PrimAlt tc + | isHiBootTyCon tc -> look_for_better_tycon + | isAlgTyCon tc -> AlgAlt tc + | isFunTyCon tc -> PolyAlt + | otherwise -> pprPanic "mkStgAlts" (ppr tc) + Nothing -> PolyAlt -\begin{code} -mkStgCase scrut@(StgPrimApp ParOp _ _) lvs1 lvs2 bndr srt - (StgPrimAlts tycon _ deflt@(StgBindDefault _)) - = StgCase scrut lvs1 lvs2 bndr srt (StgPrimAlts tycon [] deflt) - -mkStgCase (StgPrimApp SeqOp [scrut] _) lvs1 lvs2 bndr srt - (StgPrimAlts _ _ deflt@(StgBindDefault rhs)) - = StgCase scrut_expr lvs1 lvs2 new_bndr srt new_alts where - new_alts - | isUnLiftedType scrut_ty = WARN( True, text "mkStgCase" ) - mkStgPrimAlts scrut_ty [] deflt - | otherwise = mkStgAlgAlts scrut_ty [] deflt - - scrut_ty = stgArgType scrut - new_bndr = setIdType bndr scrut_ty - -- NB: SeqOp :: forall a. a -> Int# - -- So bndr has type Int# - -- But now we are going to scrutinise the SeqOp's argument directly, - -- so we must change the type of the case binder to match that - -- of the argument expression e. - - scrut_expr = case scrut of - StgVarArg v -> StgApp v [] - -- Others should not happen because - -- seq of a value should have disappeared - StgLitArg l -> WARN( True, text "seq on" <+> ppr l ) StgLit l - -mkStgCase scrut lvs1 lvs2 bndr srt alts - = StgCase scrut lvs1 lvs2 bndr srt alts - - -mkStgAlgAlts ty alts deflt - = case alts of - -- Get the tycon from the data con - (dc, _, _, _) : _rest - -> StgAlgAlts (Just (dataConTyCon dc)) alts deflt - - -- Otherwise just do your best - [] -> case splitTyConApp_maybe (repType ty) of - Just (tc,_) | isAlgTyCon tc - -> StgAlgAlts (Just tc) alts deflt - other - -> StgAlgAlts Nothing alts deflt - -mkStgPrimAlts ty alts deflt - = StgPrimAlts (tyConAppTyCon ty) alts deflt + -- Sometimes, the TyCon in the type of the scrutinee is an HiBootTyCon, + -- which may not have any constructors inside it. If so, then we + -- can get a better TyCon by grabbing the one from a constructor alternative + -- if one exists. + look_for_better_tycon + | ((DataAlt con, _, _) : _) <- data_alts = + AlgAlt (dataConTyCon con) + | otherwise = + ASSERT(null data_alts) + PolyAlt + where + (data_alts, _deflt) = findDefault alts \end{code} -Applications: +-- --------------------------------------------------------------------------- +-- Applications +-- --------------------------------------------------------------------------- + \begin{code} coreToStgApp :: Maybe UpdateFlag -- Just upd <=> this application is @@ -524,44 +452,43 @@ coreToStgApp -> LneM (StgExpr, FreeVarsInfo, EscVarsSet) coreToStgApp maybe_thunk_body f args - = getVarsLiveInCont `thenLne` \ live_in_cont -> - coreToStgAtoms args `thenLne` \ (args', args_fvs) -> + = coreToStgArgs args `thenLne` \ (args', args_fvs) -> lookupVarLne f `thenLne` \ how_bound -> let - n_args = length args - not_letrec_bound = not (isLetrecBound how_bound) - f_arity = idArity f - fun_fvs = singletonFVInfo f how_bound fun_occ + n_val_args = valArgCount args + not_letrec_bound = not (isLetBound how_bound) + fun_fvs + = let fvs = singletonFVInfo f how_bound fun_occ in + -- e.g. (f :: a -> int) (x :: a) + -- Here the free variables are "f", "x" AND the type variable "a" + -- coreToStgArgs will deal with the arguments recursively + if opt_RuntimeTypes then + fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType (idType f)) + else fvs + + -- Mostly, the arity info of a function is in the fn's IdInfo + -- But new bindings introduced by CoreSat may not have no + -- arity info; it would do us no good anyway. For example: + -- let f = \ab -> e in f + -- No point in having correct arity info for f! + -- Hence the hasArity stuff below. + -- NB: f_arity is only consulted for LetBound things + f_arity = stgArity f how_bound + saturated = f_arity <= n_val_args fun_occ - | not_letrec_bound = NoStgBinderInfo -- Uninteresting variable - - -- Otherwise it is letrec bound; must have its arity - | n_args == 0 = stgFakeFunAppOcc -- Function Application - -- with no arguments. - -- used by the lambda lifter. - | f_arity > n_args = stgUnsatOcc -- Unsaturated - - | f_arity == n_args && - maybeToBool maybe_thunk_body -- Exactly saturated, - -- and rhs of thunk - = case maybe_thunk_body of - Just Updatable -> stgStdHeapOcc - Just SingleEntry -> stgNoUpdHeapOcc - other -> panic "coreToStgApp" - - | otherwise = stgNormalOcc - -- Record only that it occurs free - - myself = unitVarSet f - - fun_escs | not_letrec_bound = emptyVarSet - -- Only letrec-bound escapees are interesting - | f_arity == n_args = emptyVarSet - -- Function doesn't escape - | otherwise = myself - -- Inexact application; it does escape + | 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: @@ -574,16 +501,14 @@ coreToStgApp maybe_thunk_body f args -- continuation, but it does no harm to just union the -- two regardless. - -- XXX not needed? - -- live_at_call - -- = live_in_cont `unionVarSet` case how_bound of - -- LetrecBound _ lvs -> lvs `minusVarSet` myself - -- other -> emptyVarSet - - app = case idFlavour f of - DataConId dc -> StgConApp dc args' - PrimOpId op -> StgPrimApp op args' (exprType (mkApps (Var f) args)) - _other -> StgApp f args' + 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' in returnLne ( @@ -595,6 +520,37 @@ coreToStgApp maybe_thunk_body f args ) + +-- --------------------------------------------------------------------------- +-- Argument lists +-- This is the guy that turns applications into A-normal form +-- --------------------------------------------------------------------------- + +coreToStgArgs :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo) +coreToStgArgs [] + = returnLne ([], emptyFVInfo) + +coreToStgArgs (Type ty : args) -- Type argument + = coreToStgArgs args `thenLne` \ (args', fvs) -> + if opt_RuntimeTypes then + returnLne (StgTypeArg ty : args', fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType ty)) + else + returnLne (args', fvs) + +coreToStgArgs (arg : args) -- Non-type argument + = coreToStgArgs args `thenLne` \ (stg_args, args_fvs) -> + coreToStgExpr arg `thenLne` \ (arg', arg_fvs, escs) -> + let + fvs = args_fvs `unionFVInfo` arg_fvs + stg_arg = case arg' of + StgApp v [] -> StgVarArg v + StgConApp con [] -> StgVarArg (dataConWorkId con) + StgLit lit -> StgLitArg lit + _ -> pprPanic "coreToStgArgs" (ppr arg) + in + returnLne (stg_arg : stg_args, fvs) + + -- --------------------------------------------------------------------------- -- The magic for lets: -- --------------------------------------------------------------------------- @@ -610,38 +566,28 @@ coreToStgLet -- is among the escaping vars coreToStgLet let_no_escape bind body - = fixLne (\ ~(_, _, _, rec_bind_lvs, _, rec_body_fvs, _, _) -> + = fixLne (\ ~(_, _, _, _, _, rec_body_fvs, _, _) -> -- Do the bindings, setting live_in_cont to empty if -- we ain't in a let-no-escape world getVarsLiveInCont `thenLne` \ live_in_cont -> - setVarsLiveInCont - (if let_no_escape then live_in_cont else emptyVarSet) - (vars_bind rec_bind_lvs rec_body_fvs bind) - `thenLne` \ (bind2, bind_fvs, bind_escs, env_ext) -> - - -- The live variables of this binding are the ones which are live - -- by virtue of being accessible via the free vars of the binding (lvs_from_fvs) - -- together with the live_in_cont ones - lookupLiveVarsForSet (bind_fvs `minusFVBinders` binders) - `thenLne` \ lvs_from_fvs -> - let - bind_lvs = lvs_from_fvs `unionVarSet` live_in_cont - in - - -- bind_fvs and bind_escs still include the binders of the let(rec) - -- but bind_lvs does not + setVarsLiveInCont (if let_no_escape + then live_in_cont + else emptyLiveInfo) + (vars_bind rec_body_fvs bind) + `thenLne` \ ( bind2, bind_fvs, bind_escs, bind_lv_info, env_ext) -> -- Do the body extendVarEnvLne env_ext ( - coreToStgExpr body `thenLne` \ (body2, body_fvs, body_escs) -> - lookupLiveVarsForSet body_fvs `thenLne` \ body_lvs -> + coreToStgExpr body `thenLne` \(body2, body_fvs, body_escs) -> + freeVarsToLiveVars body_fvs `thenLne` \ body_lv_info -> - returnLne (bind2, bind_fvs, bind_escs, bind_lvs, - body2, body_fvs, body_escs, body_lvs) + returnLne (bind2, bind_fvs, bind_escs, getLiveVars bind_lv_info, + body2, body_fvs, body_escs, getLiveVars body_lv_info) + ) - )) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs, - body2, body_fvs, body_escs, body_lvs) -> + ) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs, + body2, body_fvs, body_escs, body_lvs) -> -- Compute the new let-expression @@ -650,10 +596,10 @@ coreToStgLet let_no_escape bind body | otherwise = StgLet bind2 body2 free_in_whole_let - = (bind_fvs `unionFVInfo` body_fvs) `minusFVBinders` binders + = binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs) live_in_whole_let - = bind_lvs `unionVarSet` (body_lvs `minusVarSet` set_of_binders) + = bind_lvs `unionVarSet` (body_lvs `delVarSetList` binders) real_bind_escs = if let_no_escape then bind_escs @@ -661,10 +607,10 @@ coreToStgLet let_no_escape bind body getFVSet bind_fvs -- Everything escapes which is free in the bindings - let_escs = (real_bind_escs `unionVarSet` body_escs) `minusVarSet` set_of_binders + let_escs = (real_bind_escs `unionVarSet` body_escs) `delVarSetList` binders all_escs = bind_escs `unionVarSet` body_escs -- Still includes binders of - -- this let(rec) + -- this let(rec) no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs) @@ -690,61 +636,147 @@ coreToStgLet let_no_escape bind body )) where set_of_binders = mkVarSet binders - binders = case bind of - NonRec binder rhs -> [binder] - Rec pairs -> map fst pairs + binders = bindersOf bind - mk_binding bind_lvs binder - = (binder, LetrecBound False -- Not top level - live_vars - ) + mk_binding bind_lv_info binder rhs + = (binder, LetBound (NestedLet live_vars) (manifestArity rhs)) where - live_vars = if let_no_escape then - extendVarSet bind_lvs binder - else - unitVarSet binder + live_vars | let_no_escape = addLiveVar bind_lv_info binder + | otherwise = unitLiveVar binder + -- c.f. the invariant on NestedLet - vars_bind :: StgLiveVars - -> FreeVarsInfo -- Free var info for body of binding + vars_bind :: 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) -> + 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@(binder', _) = mk_binding rec_bind_lvs binder + env_ext_item = mk_binding bind_lv_info binder rhs 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) - )) + 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" +is_join_var j = occNameString (getOccName j) == "$j" \end{code} +\begin{code} +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 + + %************************************************************************ %* * \subsection[LNE-monad]{A little monad for this let-no-escaping pass} @@ -752,63 +784,102 @@ is_join_var j = occNameUserString (getOccName j) == "$j" %************************************************************************ 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}. +help. All the stuff here is only passed *down*. \begin{code} -type LneM a = IdEnv HowBound - -> StgLiveVars -- vars live in continuation +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 - | CaseBound - | LambdaBound - | LetrecBound - Bool -- True <=> bound at top level - StgLiveVars -- Live vars... see notes below - -isLetrecBound (LetrecBound _ _) = True -isLetrecBound other = False + = ImportBound -- Used only as a response to lookupBinding; never + -- exists in the range of the (IdEnv HowBound) + + | LetBound -- A let(rec) in this module + LetInfo -- Whether top level or nested + Arity -- Its arity (local Ids don't have arity info at this point) + + | LambdaBound -- Used for both lambda and case + +data LetInfo + = TopLet -- top level things + | NestedLet LiveInfo -- For nested things, what is live if this + -- thing is live? Invariant: the binder + -- itself is always a member of + -- the dynamic set of its own LiveInfo + +isLetBound (LetBound _ _) = True +isLetBound other = False + +topLevelBound ImportBound = True +topLevelBound (LetBound TopLet _) = True +topLevelBound other = False +\end{code} + +For a let(rec)-bound variable, x, we record LiveInfo, the set of +variables that are live if x is live. This LiveInfo comprises + (a) dynamic live variables (ones with a non-top-level binding) + (b) static live variabes (CAFs or things that refer to CAFs) + +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} +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} -For a let(rec)-bound variable, x, we record what varibles are live if -x is live. For "normal" variables that is just x alone. If x is -a let-no-escaped variable then x is represented by a code pointer and -a stack pointer (well, one for each stack). So all of the variables -needed in the execution of x are live if x is, and are therefore recorded -in the LetrecBound constructor; x itself *is* included. The std monad functions: \begin{code} -initLne :: LneM a -> a -initLne m = m emptyVarEnv emptyVarSet +initLne :: IdEnv HowBound -> LneM a -> a +initLne env m = m env emptyLiveInfo + + {-# INLINE thenLne #-} -{-# INLINE thenLne_ #-} {-# INLINE returnLne #-} returnLne :: a -> LneM a returnLne e env lvs_cont = e thenLne :: LneM a -> (a -> LneM b) -> LneM b -thenLne m k env lvs_cont - = case (m env lvs_cont) of - m_result -> k m_result env lvs_cont - -thenLne_ :: LneM a -> LneM b -> LneM b -thenLne_ m k env lvs_cont - = case (m env lvs_cont) of - _ -> k env lvs_cont - -mapLne :: (a -> LneM b) -> [a] -> LneM [b] -mapLne f [] = returnLne [] -mapLne f (x:xs) - = f x `thenLne` \ r -> - mapLne f xs `thenLne` \ rs -> - returnLne (r:rs) +thenLne m k env lvs_cont + = k (m env lvs_cont) env lvs_cont mapAndUnzipLne :: (a -> LneM (b,c)) -> [a] -> LneM ([b],[c]) - mapAndUnzipLne f [] = returnLne ([],[]) mapAndUnzipLne f (x:xs) = f x `thenLne` \ (r1, r2) -> @@ -816,26 +887,33 @@ mapAndUnzipLne f (x:xs) 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 +fixLne expr env lvs_cont + = result where result = expr result env lvs_cont --- ^^^^^^ ------ ^^^^^^ \end{code} Functions specific to this monad: + \begin{code} -getVarsLiveInCont :: LneM StgLiveVars +getVarsLiveInCont :: LneM LiveInfo getVarsLiveInCont env lvs_cont = lvs_cont -setVarsLiveInCont :: StgLiveVars -> LneM a -> LneM a +setVarsLiveInCont :: LiveInfo -> LneM a -> LneM a setVarsLiveInCont new_lvs_cont expr env lvs_cont = expr env new_lvs_cont @@ -844,33 +922,41 @@ 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 +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. -lookupLiveVarsForSet :: FreeVarsInfo -> LneM StgLiveVars - -lookupLiveVarsForSet fvs env lvs_cont - = returnLne (unionVarSets (map do_one (getFVs fvs))) - env lvs_cont +freeVarsToLiveVars :: FreeVarsInfo -> LneM LiveInfo +freeVarsToLiveVars fvs env live_in_cont + = returnLne live_info env live_in_cont where - 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} + live_info = foldr unionLiveInfo live_in_cont lvs_from_fvs + lvs_from_fvs = map do_one (allFreeIds fvs) + + do_one (v, how_bound) + = case how_bound of + ImportBound -> unitLiveCaf v -- Only CAF imports are + -- recorded in fvs + LetBound TopLet _ + | mayHaveCafRefs (idCafInfo v) -> unitLiveCaf v + | otherwise -> emptyLiveInfo + LetBound (NestedLet lvs) _ -> lvs -- lvs already contains v + -- (see the invariant on NestedLet) + + _lambda_or_case_binding -> unitLiveVar v -- Bound by lambda or case +\end{code} %************************************************************************ %* * @@ -879,18 +965,31 @@ lookupLiveVarsForSet fvs env lvs_cont %************************************************************************ \begin{code} -type FreeVarsInfo = IdEnv (Id, Bool, StgBinderInfo) - -- If f is mapped to NoStgBinderInfo, that means - -- that f *is* mentioned (else it wouldn't be in the - -- IdEnv at all), but only in a saturated applications. - -- - -- All case/lambda-bound things are also mapped to - -- NoStgBinderInfo, since we aren't interested in their - -- occurence info. - -- - -- The Bool is True <=> the Id is top level letrec bound - -type EscVarsSet = IdSet +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} \begin{code} @@ -898,9 +997,17 @@ emptyFVInfo :: FreeVarsInfo emptyFVInfo = emptyVarEnv 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) +-- 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 @@ -908,36 +1015,69 @@ unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2 unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs -minusFVBinders :: FreeVarsInfo -> [Id] -> FreeVarsInfo -minusFVBinders fv ids = fv `delVarEnvList` ids +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 -lookupFVInfo fvs id = case lookupVarEnv fvs id of - Nothing -> NoStgBinderInfo +-- 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 -getFVs :: FreeVarsInfo -> [Id] -- Non-top-level things only -getFVs fvs = [id | (id,False,_) <- rngVarEnv fvs] +allFreeIds :: FreeVarsInfo -> [(Id,HowBound)] -- Both top level and non-top-level Ids +allFreeIds fvs = [(id,how_bound) | (id,how_bound,_) <- varEnvElts fvs, isId id] -getFVSet :: FreeVarsInfo -> IdSet +-- 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, _) <- varEnvElts fvs, + not (topLevelBound how_bound) ] + +getFVSet :: FreeVarsInfo -> VarSet getFVSet fvs = mkVarSet (getFVs fvs) -plusFVInfo (id1,top1,info1) (id2,top2,info2) - = ASSERT (id1 == id2 && top1 == top2) - (id1, top1, combineStgBinderInfo info1 info2) +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} -shouldBeVar (Note _ e) = shouldBeVar e -shouldBeVar (Var v) = v -shouldBeVar e = pprPanic "shouldBeVar" (ppr e) +filterStgBinders :: [Var] -> [Var] +filterStgBinders bndrs + | opt_RuntimeTypes = bndrs + | otherwise = filter isId bndrs +\end{code} + --- ignore all notes except SCC +\begin{code} + -- Ignore all notes except SCC myCollectBinders expr = go [] expr where @@ -946,12 +1086,22 @@ myCollectBinders expr go bs (Note _ e) = go bs e go bs e = (reverse bs, e) -myCollectArgs :: Expr b -> (Expr b, [Arg b]) +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 = panic "CoreToStg.myCollectArgs" - go (Note n e) as = go e as - go e as = (e, 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} + +\begin{code} +stgArity :: Id -> HowBound -> Arity +stgArity f (LetBound _ arity) = arity +stgArity f ImportBound = idArity f +stgArity f LambdaBound = 0 \end{code}