X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FstgSyn%2FCoreToStg.lhs;h=04da56d59be7b7bfe38257895493edb5c594b3ca;hb=3af411e913102d8ec1234f32abe99374f077e3f7;hp=e4752c5bf6f4276d367203a77dd4bb4af4348cde;hpb=44637383d831bd3ca8f3aa3cf80e6a0c90986b41;p=ghc-hetmet.git diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index e4752c5..04da56d 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -12,15 +12,14 @@ module CoreToStg ( coreToStg, coreExprToStg ) where #include "HsVersions.h" import CoreSyn -import CoreFVs import CoreUtils -import SimplUtils import StgSyn import Type import TyCon ( isAlgTyCon ) +import Literal import Id -import Var ( Var ) +import Var ( Var, globalIdDetails, varType ) import IdInfo import DataCon import CostCentre ( noCCS ) @@ -28,16 +27,16 @@ import VarSet import VarEnv import DataCon ( dataConWrapId ) import IdInfo ( OccInfo(..) ) -import PrimOp ( PrimOp(..), ccallMayGC ) -import TysPrim ( foreignObjPrimTyCon ) -import Maybes ( maybeToBool, orElse ) -import Name ( getOccName, isExternallyVisibleName ) -import Module ( Module ) +import Maybes ( maybeToBool ) +import Name ( getOccName, isExternallyVisibleName, isDllName ) import OccName ( occNameUserString ) -import BasicTypes ( TopLevelFlag(..), isNotTopLevel ) -import CmdLineOpts ( DynFlags, opt_KeepStgTypes ) +import BasicTypes ( TopLevelFlag(..), isNotTopLevel, Arity ) +import CmdLineOpts ( DynFlags, opt_RuntimeTypes ) +import FastTypes hiding ( fastOr ) import Outputable +import List ( partition ) + infixr 9 `thenLne` \end{code} @@ -92,64 +91,129 @@ if @v@ is. %************************************************************************ %* * +\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 + +we collect the CafInfo first by analysing the original Core expression, and +also place this information in the environment. + +During CoreToStg, we then pin onto each binding and case expression, a +list of Ids which represents the "live" CAFs at that point. The meaning +of "live" here is the same as for live variables, see above (which is +why it's convenient to collect CAF information here rather than elsewhere). + +The later SRT pass takes these lists of Ids and uses them to construct +the actual nested SRTs, and replaces the lists of Ids with (offset,length) +pairs. + +%************************************************************************ +%* * \subsection[binds-StgVarInfo]{Setting variable info: top-level, binds, RHSs} %* * %************************************************************************ \begin{code} -coreToStg :: DynFlags -> Module -> [CoreBind] -> IO [StgBinding] -coreToStg dflags this_mod pgm - = return (fst (initLne (coreTopBindsToStg pgm))) +coreToStg :: DynFlags -> [CoreBind] -> IO [StgBinding] +coreToStg dflags pgm + = return pgm' + where (_, _, pgm') = coreTopBindsToStg emptyVarEnv pgm coreExprToStg :: CoreExpr -> StgExpr coreExprToStg expr - = new_expr where (new_expr,_,_) = initLne (coreToStgExpr expr) - --- For top-level guys, we basically aren't worried about this --- live-variable stuff; we do need to keep adding to the environment --- as we step through the bindings (using @extendVarEnv@). - -coreTopBindsToStg :: [CoreBind] -> LneM ([StgBinding], FreeVarsInfo) - -coreTopBindsToStg [] = returnLne ([], emptyFVInfo) -coreTopBindsToStg (bind:binds) - = let - binders = bindersOf bind - env_extension = binders `zip` repeat how_bound - how_bound = LetrecBound True {- top level -} - emptyVarSet - in - - extendVarEnvLne env_extension ( - coreTopBindsToStg binds `thenLne` \ (binds', fv_binds) -> - coreTopBindToStg binders fv_binds bind `thenLne` \ (bind', fv_bind) -> - returnLne ( - (bind' : binds'), - (fv_binds `unionFVInfo` fv_bind) `minusFVBinders` binders - ) - ) + = new_expr where (new_expr,_,_) = initLne emptyVarEnv (coreToStgExpr expr) + + +coreTopBindsToStg + :: IdEnv HowBound -- environment for the bindings + -> [CoreBind] + -> (IdEnv HowBound, FreeVarsInfo, [StgBinding]) + +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 - :: [Id] -- New binders (with correct arity) + :: IdEnv HowBound -> FreeVarsInfo -- Info about the body -> CoreBind - -> LneM (StgBinding, FreeVarsInfo) + -> (IdEnv HowBound, FreeVarsInfo, StgBinding) -coreTopBindToStg [binder] body_fvs (NonRec _ rhs) - = coreToStgRhs body_fvs TopLevel (binder,rhs) `thenLne` \ (rhs2, fvs, _) -> - returnLne (StgNonRec binder rhs2, fvs) +coreTopBindToStg env body_fvs (NonRec id rhs) + = let + caf_info = hasCafRefs env rhs -coreTopBindToStg binders body_fvs (Rec pairs) - = fixLne (\ ~(_, rec_rhs_fvs) -> - let scope_fvs = unionFVInfo body_fvs rec_rhs_fvs - in - mapAndUnzip3Lne (coreToStgRhs scope_fvs TopLevel) pairs - `thenLne` \ (rhss2, fvss, _) -> - let fvs = unionFVInfos fvss - in - returnLne (StgRec (binders `zip` rhss2), fvs) - ) + env' = extendVarEnv env id (LetBound how_bound emptyLVS (predictArity rhs)) + + how_bound | mayHaveCafRefs caf_info = TopLevelHasCafs + | otherwise = TopLevelNoCafs + + (stg_rhs, fvs', cafs) = + initLne env ( + coreToStgRhs body_fvs TopLevel (id,rhs) + `thenLne` \ (stg_rhs, fvs', _) -> + freeVarsToLiveVars fvs' `thenLne` \ (_, cafs) -> + returnLne (stg_rhs, fvs', cafs) + ) + + bind = StgNonRec (SRTEntries cafs) id stg_rhs + in + ASSERT2(predictArity rhs == stgRhsArity stg_rhs, ppr id) + ASSERT2(consistent caf_info bind, ppr id) +-- WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info) + (env', fvs' `unionFVInfo` body_fvs, bind) + +coreTopBindToStg env body_fvs (Rec pairs) + = let + (binders, rhss) = unzip pairs + + -- to calculate caf_info, we initially map all the binders to + -- TopLevelNoCafs. + env1 = extendVarEnvList env + [ (b, LetBound TopLevelNoCafs emptyLVS (error "no arity")) + | b <- binders ] + + caf_info = hasCafRefss env1{-NB: not env'-} rhss + + env' = extendVarEnvList env + [ (b, LetBound how_bound emptyLVS (predictArity rhs)) + | (b,rhs) <- pairs ] + + how_bound | mayHaveCafRefs caf_info = TopLevelHasCafs + | otherwise = TopLevelNoCafs + + (stg_rhss, fvs', cafs) + = initLne env' ( + mapAndUnzip3Lne (coreToStgRhs body_fvs TopLevel) pairs + `thenLne` \ (stg_rhss, fvss', _) -> + let fvs' = unionFVInfos fvss' in + freeVarsToLiveVars fvs' `thenLne` \ (_, cafs) -> + returnLne (stg_rhss, fvs', cafs) + ) + + bind = StgRec (SRTEntries cafs) (zip binders stg_rhss) + in + ASSERT2(and [predictArity rhs == stgRhsArity stg_rhs | (rhs,stg_rhs) <- rhss `zip` stg_rhss], ppr binders) + ASSERT2(consistent caf_info bind, ppr binders) +-- WARN(not (consistent caf_info bind), ppr binders <+> ppr cafs <+> ppCafInfo caf_info) + (env', fvs' `unionFVInfo` body_fvs, bind) + +-- assertion helper +consistent caf_info bind = mayHaveCafRefs caf_info == stgBindHasCafRefs bind \end{code} \begin{code} @@ -170,7 +234,7 @@ mkStgRhs :: TopLevelFlag -> FreeVarsInfo -> StgBinderInfo -> StgExpr -> StgRhs mkStgRhs top rhs_fvs binder_info (StgLam _ bndrs body) - = StgRhsClosure noCCS binder_info noSRT + = StgRhsClosure noCCS binder_info (getFVs rhs_fvs) ReEntrant bndrs body @@ -180,7 +244,7 @@ mkStgRhs top rhs_fvs binder_info (StgConApp con args) = StgRhsCon noCCS con args mkStgRhs top rhs_fvs binder_info rhs - = StgRhsClosure noCCS binder_info noSRT + = StgRhsClosure noCCS binder_info (getFVs rhs_fvs) (updatable [] rhs) [] rhs @@ -271,12 +335,12 @@ coreToStgExpr expr@(Lam _ _) coreToStgExpr body `thenLne` \ (body, body_fvs, body_escs) -> let set_of_args = mkVarSet args' - fvs = body_fvs `minusFVBinders` args' + fvs = args' `minusFVBinders` body_fvs escs = body_escs `minusVarSet` set_of_args + result_expr | null args' = body + | otherwise = StgLam (exprType expr) args' body in - 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) -> @@ -289,51 +353,40 @@ coreToStgExpr (Note other_note 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 -> + = extendVarEnvLne [(bndr, CaseBound)] $ + vars_alts (findDefault alts) `thenLne` \ (alts2, alts_fvs, alts_escs) -> + freeVarsToLiveVars alts_fvs `thenLne` \ (alts_lvs, alts_caf_refs) -> let -- determine whether the default binder is dead or not - bndr' = bndr `setIdOccInfo` occ_info - occ_info | bndr `elementOfFVInfo` alts_fvs = NoOccInfo - | otherwise = IAmDead - - -- for a _ccall_GC_, some of the *arguments* need to live across the - -- call (see findLiveArgs comments.), so we annotate them as being live - -- in the alts to achieve the desired effect. - mb_live_across_case = - case scrut of - -- ToDo: Notes? - e@(App _ _) | (v, args) <- myCollectArgs e, - PrimOpId (CCallOp ccall) <- idFlavour v, - ccallMayGC ccall - -> Just (filterVarSet isForeignObjArg (exprFreeVars e)) - _ -> Nothing + -- This helps the code generator to avoid generating an assignment + -- for the case binder (is extremely rare cases) ToDo: remove. + bndr'= if (bndr `elementOfFVInfo` alts_fvs) + then bndr + else bndr `setIdOccInfo` IAmDead -- Don't consider the default binder as being 'live in alts', -- since this is from the point of view of the case expr, where -- the default binder is not free. - live_in_alts = orElse (FMAP unionVarSet mb_live_across_case) id $ - live_in_cont `unionVarSet` - (alts_lvs `minusVarSet` unitVarSet bndr) + live_in_alts = (alts_lvs `minusVarSet` unitVarSet bndr) in -- we tell the scrutinee that everything live in the alts -- is live in it, too. - setVarsLiveInCont live_in_alts ( - 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 + setVarsLiveInCont (live_in_alts,alts_caf_refs) ( + coreToStgExpr scrut `thenLne` \ (scrut2, scrut_fvs, scrut_escs) -> + freeVarsToLiveVars scrut_fvs `thenLne` \ (scrut_lvs, _) -> + returnLne (scrut2, scrut_fvs, scrut_escs, scrut_lvs) + ) + `thenLne` \ (scrut2, scrut_fvs, scrut_escs, scrut_lvs) -> + + let srt = SRTEntries alts_caf_refs in returnLne ( - StgCase scrut2 live_in_whole_case live_in_alts bndr' noSRT alts2, - (scrut_fvs `unionFVInfo` alts_fvs) `minusFVBinders` [bndr], + StgCase scrut2 scrut_lvs live_in_alts bndr' srt alts2, + bndr `minusFVBinder` (scrut_fvs `unionFVInfo` alts_fvs), (alts_escs `minusVarSet` unitVarSet bndr) `unionVarSet` getFVSet scrut_fvs - -- You might think we should have scrut_escs, not (getFVSet scrut_fvs), - -- but actually we can't call, and then return from, a let-no-escape thing. + -- 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 @@ -386,11 +439,12 @@ coreToStgExpr (Case scrut bndr alts) in returnLne ( (con, binders', good_use_mask, rhs2), - rhs_fvs `minusFVBinders` binders', + binders' `minusFVBinders` rhs_fvs, rhs_escs `minusVarSet` mkVarSet binders' -- ToDo: remove the minusVarSet; -- since escs won't include any of these binders ) + vars_alg_alt other = pprPanic "vars_alg_alt" (ppr other) vars_deflt Nothing = returnLne (StgNoDefault, emptyFVInfo, emptyVarSet) @@ -413,20 +467,6 @@ 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} - \begin{code} mkStgAlgAlts ty alts deflt = case alts of @@ -461,14 +501,20 @@ coreToStgApp -> LneM (StgExpr, FreeVarsInfo, EscVarsSet) coreToStgApp maybe_thunk_body f args - = getVarsLiveInCont `thenLne` \ live_in_cont -> - coreToStgArgs 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) - 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 (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 @@ -476,18 +522,18 @@ coreToStgApp maybe_thunk_body f args -- let f = \ab -> e in f -- No point in having correct arity info for f! -- Hence the hasArity stuff below. - f_arity_info = idArityInfo f - f_arity = arityLowerBound f_arity_info -- Zero if no info + f_arity = case how_bound of + LetBound _ _ arity -> arity + _ -> 0 fun_occ - | not_letrec_bound = noBinderInfo -- Uninteresting variable - | f_arity > 0 && f_arity <= n_args = stgSatOcc -- Saturated or over-saturated function call - | otherwise = stgUnsatOcc -- Unsaturated function or thunk + | not_letrec_bound = noBinderInfo -- Uninteresting variable + | f_arity > 0 && f_arity <= n_val_args = stgSatOcc -- Saturated or over-saturated function call + | otherwise = stgUnsatOcc -- Unsaturated function or thunk fun_escs - | not_letrec_bound = emptyVarSet -- Only letrec-bound escapees are interesting - | hasArity f_arity_info && - f_arity == n_args = emptyVarSet -- A function *or thunk* with an exactly + | 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) @@ -504,9 +550,11 @@ coreToStgApp maybe_thunk_body f args -- continuation, but it does no harm to just union the -- two regardless. - app = case idFlavour f of - DataConId dc -> StgConApp dc args' - PrimOpId op -> StgPrimApp op args' (exprType (mkApps (Var f) args)) + res_ty = exprType (mkApps (Var f) args) + app = case globalIdDetails f of + DataConId dc -> StgConApp dc args' + PrimOpId op -> StgOpApp (StgPrimOp op) args' res_ty + FCallId call -> StgOpApp (StgFCallOp call (idUnique f)) args' res_ty _other -> StgApp f args' in @@ -531,7 +579,7 @@ coreToStgArgs [] coreToStgArgs (Type ty : args) -- Type argument = coreToStgArgs args `thenLne` \ (args', fvs) -> - if opt_KeepStgTypes then + if opt_RuntimeTypes then returnLne (StgTypeArg ty : args', fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType ty)) else returnLne (args', fvs) @@ -565,38 +613,29 @@ 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 emptyLVS) + (vars_bind rec_body_fvs bind) + `thenLne` \ ( bind2, bind_fvs, bind_escs + , bind_lvs, bind_cafs, env_ext) -> -- Do the body extendVarEnvLne env_ext ( - coreToStgExpr body `thenLne` \ (body2, body_fvs, body_escs) -> - lookupLiveVarsForSet body_fvs `thenLne` \ body_lvs -> + coreToStgExpr body `thenLne` \(body2, body_fvs, body_escs) -> + freeVarsToLiveVars body_fvs `thenLne` \(body_lvs, _) -> - returnLne (bind2, bind_fvs, bind_escs, bind_lvs, - body2, body_fvs, body_escs, body_lvs) + returnLne (bind2, bind_fvs, bind_escs, bind_lvs, bind_cafs, + body2, body_fvs, body_escs, body_lvs) + ) - )) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs, - body2, body_fvs, body_escs, body_lvs) -> + ) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs, bind_cafs, + body2, body_fvs, body_escs, body_lvs) -> -- Compute the new let-expression @@ -605,7 +644,7 @@ 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) @@ -649,50 +688,60 @@ coreToStgLet let_no_escape bind body NonRec binder rhs -> [binder] Rec pairs -> map fst pairs - mk_binding bind_lvs binder - = (binder, LetrecBound False -- Not top level - live_vars + mk_binding bind_lvs bind_cafs binder rhs + = (binder, LetBound NotTopLevelBound -- Not top level + live_vars (predictArity rhs) ) where live_vars = if let_no_escape then - extendVarSet bind_lvs binder + (extendVarSet bind_lvs binder, bind_cafs) else - unitVarSet binder + (unitVarSet binder, emptyVarSet) - 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 + StgLiveVars, -- vars live in binding + IdSet, -- CAFs live in binding + [(Id, HowBound)]) -- extension to environment + + + vars_bind body_fvs (NonRec binder rhs) + = coreToStgRhs body_fvs NotTopLevel (binder,rhs) + `thenLne` \ (rhs2, bind_fvs, escs) -> + + freeVarsToLiveVars bind_fvs `thenLne` \ (bind_lvs, bind_cafs) -> let - env_ext_item@(binder', _) = mk_binding rec_bind_lvs binder + env_ext_item = mk_binding bind_lvs bind_cafs 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 + returnLne (StgNonRec (SRTEntries bind_cafs) binder rhs2, + bind_fvs, escs, bind_lvs, bind_cafs, [env_ext_item]) + + + vars_bind body_fvs (Rec pairs) + = fixLne (\ ~(_, rec_rhs_fvs, _, bind_lvs, bind_cafs, _) -> + let + rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs + binders = map fst pairs + env_ext = [ mk_binding bind_lvs bind_cafs b rhs + | (b,rhs) <- pairs ] + in + extendVarEnvLne env_ext ( + mapAndUnzip3Lne (coreToStgRhs rec_scope_fvs NotTopLevel) pairs `thenLne` \ (rhss2, fvss, escss) -> - let - fvs = unionFVInfos fvss - escs = unionVarSets escss - in - returnLne (StgRec (binders `zip` rhss2), fvs, escs, env_ext) - )) + let + bind_fvs = unionFVInfos fvss + escs = unionVarSets escss + in + freeVarsToLiveVars (binders `minusFVBinders` bind_fvs) + `thenLne` \ (bind_lvs, bind_cafs) -> + + returnLne (StgRec (SRTEntries bind_cafs) (binders `zip` rhss2), + bind_fvs, escs, bind_lvs, bind_cafs, env_ext) + ) + ) is_join_var :: Id -> Bool -- A hack (used only for compiler debuggging) to tell if @@ -702,28 +751,53 @@ is_join_var j = occNameUserString (getOccName j) == "$j" %************************************************************************ %* * +\subsection{Arity prediction} +%* * +%************************************************************************ + +To avoid yet another knot, we predict the arity of each function from +its Core form, based on the number of visible top-level lambdas. +It should be the same as the arity of the STG RHS! + +\begin{code} +predictArity :: CoreExpr -> Int +predictArity (Lam x e) + | isTyVar x = predictArity e + | otherwise = 1 + predictArity e +predictArity (Note _ e) + -- Ignore coercions. Top level sccs are removed by the final + -- profiling pass, so we ignore those too. + = predictArity e +predictArity _ = 0 +\end{code} + + +%************************************************************************ +%* * \subsection[LNE-monad]{A little monad for this let-no-escaping pass} %* * %************************************************************************ There's a lot of stuff to pass around, so we use this @LneM@ monad to -help. All the stuff here is only passed {\em down}. +help. All the stuff here is only passed *down*. \begin{code} type LneM a = IdEnv HowBound - -> StgLiveVars -- vars live in continuation + -> (StgLiveVars, -- vars live in continuation + IdSet) -- cafs live in continuation -> a data HowBound = ImportBound | CaseBound | LambdaBound - | LetrecBound - Bool -- True <=> bound at top level - StgLiveVars -- Live vars... see notes below + | LetBound + TopLevelCafInfo + (StgLiveVars, IdSet) -- (Live vars, Live CAFs)... see notes below + Arity -- its arity (local Ids don't have arity info at this point) -isLetrecBound (LetrecBound _ _) = True -isLetrecBound other = False +isLetBound (LetBound _ _ _) = True +isLetBound other = False \end{code} For a let(rec)-bound variable, x, we record StgLiveVars, the set of @@ -731,7 +805,7 @@ variables that are live if x is live. For "normal" variables that is just x alone. If x is a let-no-escaped variable then x is represented by a code pointer and a stack pointer (well, one for each stack). So all of the variables needed in the execution of x are live if x is, -and are therefore recorded in the LetrecBound constructor; x itself +and are therefore recorded in the LetBound constructor; x itself *is* included. The set of live variables is guaranteed ot have no further let-no-escaped @@ -739,8 +813,10 @@ variables in it. 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 emptyLVS + +emptyLVS = (emptyVarSet,emptyVarSet) {-# INLINE thenLne #-} {-# INLINE returnLne #-} @@ -749,7 +825,7 @@ returnLne :: a -> LneM a returnLne e env lvs_cont = e thenLne :: LneM a -> (a -> LneM b) -> LneM b -thenLne m k env lvs_cont +thenLne m k env lvs_cont = k (m env lvs_cont) env lvs_cont mapLne :: (a -> LneM b) -> [a] -> LneM [b] @@ -785,10 +861,10 @@ fixLne expr env lvs_cont Functions specific to this monad: \begin{code} -getVarsLiveInCont :: LneM StgLiveVars +getVarsLiveInCont :: LneM (StgLiveVars, IdSet) getVarsLiveInCont env lvs_cont = lvs_cont -setVarsLiveInCont :: StgLiveVars -> LneM a -> LneM a +setVarsLiveInCont :: (StgLiveVars,IdSet) -> LneM a -> LneM a setVarsLiveInCont new_lvs_cont expr env lvs_cont = expr env new_lvs_cont @@ -808,23 +884,36 @@ lookupVarLne v env lvs_cont -- 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 (StgLiveVars, IdSet) +freeVarsToLiveVars fvs env live_in_cont + = returnLne (lvs, cafs) env live_in_cont where + (lvs_cont, cafs_cont) = live_in_cont -- not a strict pattern match! + (local, global) = partition isLocalId (allFreeIds fvs) + + (lvs_from_fvs, caf_extras) = unzip (map do_one local) + + lvs = unionVarSets lvs_from_fvs + `unionVarSet` lvs_cont + + cafs = mkVarSet (filter is_caf_one global) + `unionVarSet` (unionVarSets caf_extras) + `unionVarSet` cafs_cont + do_one v - = 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 + = case (lookupVarEnv env v) of + Just (LetBound _ (lvs,cafs) _) -> (extendVarSet lvs v, cafs) + Just _ -> (unitVarSet v, emptyVarSet) + Nothing -> pprPanic "lookupLiveVarsForSet/do_one:" (ppr v) + + is_caf_one v + = case lookupVarEnv env v of + Just (LetBound TopLevelHasCafs (lvs,_) _) -> + ASSERT( isEmptyVarSet lvs ) True + Just (LetBound _ _ _) -> False + _otherwise -> mayHaveCafRefs (idCafInfo v) \end{code} - %************************************************************************ %* * \subsection[Free-var info]{Free variable information} @@ -832,20 +921,24 @@ lookupLiveVarsForSet fvs env lvs_cont %************************************************************************ \begin{code} -type FreeVarsInfo = VarEnv (Var, Bool, StgBinderInfo) +type FreeVarsInfo = VarEnv (Var, TopLevelCafInfo, StgBinderInfo) -- If f is mapped to noBinderInfo, that means -- that f *is* mentioned (else it wouldn't be in the - -- IdEnv at all), but only in a saturated applications. + -- 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. -- - -- The Bool is True <=> the Id is top level letrec bound - -- -- For ILX we track free var info for type variables too; -- hence VarEnv not IdEnv +data TopLevelCafInfo + = NotTopLevelBound + | TopLevelNoCafs + | TopLevelHasCafs + deriving Eq + type EscVarsSet = IdSet \end{code} @@ -854,14 +947,18 @@ 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) +singletonFVInfo id ImportBound info + | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, TopLevelHasCafs, info) + | otherwise = emptyVarEnv +singletonFVInfo id (LetBound top_level _ _) info + = unitVarEnv id (id, top_level, info) +singletonFVInfo id other info + = unitVarEnv id (id, NotTopLevelBound, info) tyvarFVInfo :: TyVarSet -> FreeVarsInfo tyvarFVInfo tvs = foldVarSet add emptyFVInfo tvs - where - add tv fvs = extendVarEnv fvs tv (tv, False, noBinderInfo) + where + add tv fvs = extendVarEnv fvs tv (tv, NotTopLevelBound, noBinderInfo) unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2 @@ -869,8 +966,16 @@ 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) @@ -884,10 +989,15 @@ lookupFVInfo fvs id Nothing -> noBinderInfo Just (_,_,info) -> info -getFVs :: FreeVarsInfo -> [Id] -- Non-top-level things only -getFVs fvs = [id | (id,False,_) <- rngVarEnv fvs] +allFreeIds :: FreeVarsInfo -> [Id] -- Non-top-level things only +allFreeIds fvs = [id | (id,_,_) <- rngVarEnv fvs, isId id] + +-- Non-top-level things only, both type variables and ids (type variables +-- only if opt_RuntimeTypes. +getFVs :: FreeVarsInfo -> [Var] +getFVs fvs = [id | (id,NotTopLevelBound,_) <- rngVarEnv fvs] -getFVSet :: FreeVarsInfo -> IdSet +getFVSet :: FreeVarsInfo -> VarSet getFVSet fvs = mkVarSet (getFVs fvs) plusFVInfo (id1,top1,info1) (id2,top2,info2) @@ -899,7 +1009,7 @@ Misc. \begin{code} filterStgBinders :: [Var] -> [Var] filterStgBinders bndrs - | opt_KeepStgTypes = bndrs + | opt_RuntimeTypes = bndrs | otherwise = filter isId bndrs \end{code} @@ -926,3 +1036,133 @@ myCollectArgs expr go (Note n e) as = go e as go _ as = pprPanic "CoreToStg.myCollectArgs" (ppr expr) \end{code} + +%************************************************************************ +%* * +\subsection{Figuring out CafInfo for an expression} +%* * +%************************************************************************ + +hasCafRefs decides whether a top-level closure can point into the dynamic heap. +We mark such things as `MayHaveCafRefs' because this information is +used to decide whether a particular closure needs to be referenced +in an SRT or not. + +There are two reasons for setting MayHaveCafRefs: + a) The RHS is a CAF: a top-level updatable thunk. + b) The RHS refers to something that MayHaveCafRefs + +Possible improvement: In an effort to keep the number of CAFs (and +hence the size of the SRTs) down, we could also look at the expression and +decide whether it requires a small bounded amount of heap, so we can ignore +it as a CAF. In these cases however, we would need to use an additional +CAF list to keep track of non-collectable CAFs. + +\begin{code} +hasCafRefs :: IdEnv HowBound -> CoreExpr -> CafInfo +-- Only called for the RHS of top-level lets +hasCafRefss :: IdEnv HowBound -> [CoreExpr] -> CafInfo + -- predicate returns True for a given Id if we look at this Id when + -- calculating the result. Used to *avoid* looking at the CafInfo + -- field for an Id that is part of the current recursive group. + +hasCafRefs p expr + | isCAF expr || isFastTrue (cafRefs p expr) = MayHaveCafRefs + | otherwise = NoCafRefs + + -- used for recursive groups. The whole group is set to + -- "MayHaveCafRefs" if at least one of the group is a CAF or + -- refers to any CAFs. +hasCafRefss p exprs + | any isCAF exprs || isFastTrue (cafRefss p exprs) = MayHaveCafRefs + | otherwise = NoCafRefs + +-- cafRefs compiles to beautiful code :) + +cafRefs p (Var id) + | isLocalId id = fastBool False + | otherwise = + case lookupVarEnv p id of + Just (LetBound TopLevelHasCafs _ _) -> fastBool True + Just (LetBound _ _ _) -> fastBool False + Nothing -> fastBool (cgMayHaveCafRefs (idCgInfo id)) -- imported Ids + +cafRefs p (Lit l) = fastBool False +cafRefs p (App f a) = fastOr (cafRefs p f) (cafRefs p) a +cafRefs p (Lam x e) = cafRefs p e +cafRefs p (Let b e) = fastOr (cafRefss p (rhssOfBind b)) (cafRefs p) e +cafRefs p (Case e bndr alts) = fastOr (cafRefs p e) + (cafRefss p) (rhssOfAlts alts) +cafRefs p (Note n e) = cafRefs p e +cafRefs p (Type t) = fastBool False + +cafRefss p [] = fastBool False +cafRefss p (e:es) = fastOr (cafRefs p e) (cafRefss p) es + +-- hack for lazy-or over FastBool. +fastOr a f x = fastBool (isFastTrue a || isFastTrue (f x)) + +isCAF :: CoreExpr -> Bool +-- Only called for the RHS of top-level lets +isCAF e = not (rhsIsNonUpd e) + {- ToDo: check type for onceness, i.e. non-updatable thunks? -} + + +rhsIsNonUpd :: CoreExpr -> Bool + -- True => Value-lambda, constructor, PAP + -- This is a bit like CoreUtils.exprIsValue, with the following differences: + -- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC) + -- + -- b) (C x xs), where C is a contructors is updatable if the application is + -- dynamic: see isDynConApp + -- + -- c) don't look through unfolding of f in (f x). I'm suspicious of this one + +-- This function has to line up with what the update flag +-- for the StgRhs gets set to in mkStgRhs (above) +-- +-- When opt_RuntimeTypes is on, we keep type lambdas and treat +-- them as making the RHS re-entrant (non-updatable). +rhsIsNonUpd (Lam b e) = isRuntimeVar b || rhsIsNonUpd e +rhsIsNonUpd (Note (SCC _) e) = False +rhsIsNonUpd (Note _ e) = rhsIsNonUpd e +rhsIsNonUpd other_expr + = go other_expr 0 [] + where + go (Var f) n_args args = idAppIsNonUpd f n_args args + + go (App f a) n_args args + | isTypeArg a = go f n_args args + | otherwise = go f (n_args + 1) (a:args) + + go (Note (SCC _) f) n_args args = False + go (Note _ f) n_args args = go f n_args args + + go other n_args args = False + +idAppIsNonUpd :: Id -> Int -> [CoreExpr] -> Bool +idAppIsNonUpd id n_val_args args + | Just con <- isDataConId_maybe id = not (isCrossDllConApp con args) + | otherwise = n_val_args < idArity id + +isCrossDllConApp :: DataCon -> [CoreExpr] -> Bool +isCrossDllConApp con args = isDllName (dataConName con) || any isCrossDllArg args +-- Top-level constructor applications can usually be allocated +-- statically, but they can't if +-- a) the constructor, or any of the arguments, come from another DLL +-- b) any of the arguments are LitLits +-- (because we can't refer to static labels in other DLLs). +-- If this happens we simply make the RHS into an updatable thunk, +-- and 'exectute' it rather than allocating it statically. +-- All this should match the decision in (see CoreToStg.coreToStgRhs) + + +isCrossDllArg :: CoreExpr -> Bool +-- True if somewhere in the expression there's a cross-DLL reference +isCrossDllArg (Type _) = False +isCrossDllArg (Var v) = isDllName (idName v) +isCrossDllArg (Note _ e) = isCrossDllArg e +isCrossDllArg (Lit lit) = isLitLitLit lit +isCrossDllArg (App e1 e2) = isCrossDllArg e1 || isCrossDllArg e2 -- must be a type app +isCrossDllArg (Lam v e) = isCrossDllArg e -- must be a type lam +\end{code}