X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FstgSyn%2FCoreToStg.lhs;fp=ghc%2Fcompiler%2FstgSyn%2FCoreToStg.lhs;h=0000000000000000000000000000000000000000;hb=0065d5ab628975892cea1ec7303f968c3338cbe1;hp=824cabaacbd51c1468cf5ea6d56c8143c3a5edfc;hpb=28a464a75e14cece5db40f2765a29348273ff2d2;p=ghc-hetmet.git diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs deleted file mode 100644 index 824caba..0000000 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ /dev/null @@ -1,1107 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 -% -\section[CoreToStg]{Converts Core to STG Syntax} - -And, as we have the info in hand, we may convert some lets to -let-no-escapes. - -\begin{code} -module CoreToStg ( coreToStg, coreExprToStg ) where - -#include "HsVersions.h" - -import CoreSyn -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 Maybes ( maybeToBool ) -import Name ( getOccName, isExternalName, nameOccName ) -import OccName ( occNameString, occNameFS ) -import BasicTypes ( Arity ) -import Packages ( HomeModules ) -import StaticFlags ( 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. - -%************************************************************************ -%* * -\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 CafInfo has already been calculated during the CoreTidy pass. - -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. - - -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[binds-StgVarInfo]{Setting variable info: top-level, binds, RHSs} -%* * -%************************************************************************ - -\begin{code} -coreToStg :: HomeModules -> [CoreBind] -> IO [StgBinding] -coreToStg hmods pgm - = return pgm' - where (_, _, pgm') = coreTopBindsToStg hmods emptyVarEnv pgm - -coreExprToStg :: CoreExpr -> StgExpr -coreExprToStg expr - = new_expr where (new_expr,_,_) = initLne emptyVarEnv (coreToStgExpr expr) - - -coreTopBindsToStg - :: HomeModules - -> IdEnv HowBound -- environment for the bindings - -> [CoreBind] - -> (IdEnv HowBound, FreeVarsInfo, [StgBinding]) - -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 - - -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) - -#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} -coreToTopStgRhs - :: HomeModules - -> FreeVarsInfo -- Free var info for the scope of the binding - -> (Id,CoreExpr) - -> LneM (StgRhs, FreeVarsInfo) - -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 - 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 --- --------------------------------------------------------------------------- - -\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} - -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} -coreToStgExpr (Lit l) = returnLne (StgLit l, emptyFVInfo, emptyVarSet) -coreToStgExpr (Var v) = coreToStgApp Nothing v [] - -coreToStgExpr expr@(App _ _) - = coreToStgApp Nothing f args - where - (f, args) = myCollectArgs expr - -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 ( 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) - (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 - 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. - -(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} -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 - - where - -- 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 --- --------------------------------------------------------------------------- - -\begin{code} -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 -> - - 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 (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 = 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' - - 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. - ) - - - --- --------------------------------------------------------------------------- --- 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: --- --------------------------------------------------------------------------- - -coreToStgLet - :: Bool -- True <=> yes, we are let-no-escaping this let - -> CoreBind -- bindings - -> CoreExpr -- body - -> LneM (StgExpr, -- new let - FreeVarsInfo, -- variables free in the whole let - EscVarsSet, -- variables that escape from the whole let - Bool) -- True <=> none of the binders in the bindings - -- is among the escaping vars - -coreToStgLet let_no_escape bind body - = fixLne (\ ~(_, _, _, _, _, rec_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 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) -> - freeVarsToLiveVars body_fvs `thenLne` \ body_lv_info -> - - 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) -> - - - -- 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 - returnLne ( - new_let, - free_in_whole_let, - let_escs, - checked_no_binder_escapes - )) - where - set_of_binders = mkVarSet binders - binders = bindersOf bind - - 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 - - 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 = 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} -%* * -%************************************************************************ - -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} -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} - -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} - - -The std monad functions: -\begin{code} -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 - -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 - result = expr result env lvs_cont -\end{code} - -Functions specific to this monad: - -\begin{code} -getVarsLiveInCont :: LneM LiveInfo -getVarsLiveInCont env lvs_cont = lvs_cont - -setVarsLiveInCont :: LiveInfo -> LneM a -> LneM a -setVarsLiveInCont new_lvs_cont expr env lvs_cont - = expr env new_lvs_cont - -extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a -extendVarEnvLne ids_w_howbound expr env lvs_cont - = expr (extendVarEnvList env ids_w_howbound) lvs_cont - -lookupVarLne :: Id -> LneM HowBound -lookupVarLne v env lvs_cont = returnLne (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 - 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} - -%************************************************************************ -%* * -\subsection[Free-var info]{Free variable information} -%* * -%************************************************************************ - -\begin{code} -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} -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,_) <- varEnvElts 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, _) <- varEnvElts 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} -filterStgBinders :: [Var] -> [Var] -filterStgBinders bndrs - | opt_RuntimeTypes = bndrs - | otherwise = filter isId bndrs -\end{code} - - -\begin{code} - -- Ignore all notes except SCC -myCollectBinders expr - = go [] expr - where - go bs (Lam b e) = go (b:bs) e - go bs e@(Note (SCC _) _) = (reverse bs, e) - go bs (Note _ e) = go bs e - go bs e = (reverse bs, e) - -myCollectArgs :: CoreExpr -> (Id, [CoreArg]) - -- We assume that we only have variables - -- in the function position by now -myCollectArgs expr - = go expr [] - where - go (Var v) as = (v, as) - go (App f a) as = go f (a:as) - go (Note (SCC _) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr) - go (Note n e) as = go e as - go _ as = pprPanic "CoreToStg.myCollectArgs" (ppr expr) -\end{code} - -\begin{code} -stgArity :: Id -> HowBound -> Arity -stgArity f (LetBound _ arity) = arity -stgArity f ImportBound = idArity f -stgArity f LambdaBound = 0 -\end{code}