X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FstgSyn%2FCoreToStg.lhs;h=38c9c4ddc5e5554723007545c59c8350602d74dd;hb=e66018084e22615311828b7a221d5df25cdf09ea;hp=04da56d59be7b7bfe38257895493edb5c594b3ca;hpb=3af411e913102d8ec1234f32abe99374f077e3f7;p=ghc-hetmet.git diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 04da56d..38c9c4d 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -20,23 +20,24 @@ import TyCon ( isAlgTyCon ) import Literal import Id import Var ( Var, globalIdDetails, varType ) +#ifdef ILX +import MkId ( unsafeCoerceId ) +#endif import IdInfo import DataCon import CostCentre ( noCCS ) import VarSet import VarEnv import DataCon ( dataConWrapId ) -import IdInfo ( OccInfo(..) ) import Maybes ( maybeToBool ) import Name ( getOccName, isExternallyVisibleName, isDllName ) import OccName ( occNameUserString ) import BasicTypes ( TopLevelFlag(..), isNotTopLevel, Arity ) import CmdLineOpts ( DynFlags, opt_RuntimeTypes ) import FastTypes hiding ( fastOr ) +import Util ( listLengthCmp ) import Outputable -import List ( partition ) - infixr 9 `thenLne` \end{code} @@ -116,6 +117,25 @@ 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} @@ -155,24 +175,21 @@ coreTopBindToStg coreTopBindToStg env body_fvs (NonRec id rhs) = let - caf_info = hasCafRefs env rhs - - env' = extendVarEnv env id (LetBound how_bound emptyLVS (predictArity rhs)) + caf_info = hasCafRefs env rhs + env' = extendVarEnv env id how_bound + how_bound = LetBound (TopLet caf_info) (manifestArity rhs) - how_bound | mayHaveCafRefs caf_info = TopLevelHasCafs - | otherwise = TopLevelNoCafs - - (stg_rhs, fvs', cafs) = + (stg_rhs, fvs', lv_info) = initLne env ( - coreToStgRhs body_fvs TopLevel (id,rhs) - `thenLne` \ (stg_rhs, fvs', _) -> - freeVarsToLiveVars fvs' `thenLne` \ (_, cafs) -> - returnLne (stg_rhs, fvs', cafs) + coreToStgRhs body_fvs TopLevel (id,rhs) `thenLne` \ (stg_rhs, fvs', _) -> + freeVarsToLiveVars fvs' `thenLne` \ lv_info -> + returnLne (stg_rhs, fvs', lv_info) ) - bind = StgNonRec (SRTEntries cafs) id stg_rhs + bind = StgNonRec (mkSRT lv_info) id stg_rhs in - ASSERT2(predictArity rhs == stgRhsArity stg_rhs, ppr id) + ASSERT2(isLocalId id || idArity id == manifestArity rhs, ppr id) + ASSERT2(manifestArity 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) @@ -181,33 +198,31 @@ coreTopBindToStg env body_fvs (Rec pairs) = let (binders, rhss) = unzip pairs - -- to calculate caf_info, we initially map all the binders to - -- TopLevelNoCafs. + -- To calculate caf_info, we initially map + -- all the binders to NoCafRefs env1 = extendVarEnvList env - [ (b, LetBound TopLevelNoCafs emptyLVS (error "no arity")) + [ (b, LetBound (TopLet NoCafRefs) (error "no arity")) | b <- binders ] caf_info = hasCafRefss env1{-NB: not env'-} rhss env' = extendVarEnvList env - [ (b, LetBound how_bound emptyLVS (predictArity rhs)) + [ (b, LetBound (TopLet caf_info) (manifestArity rhs)) | (b,rhs) <- pairs ] - how_bound | mayHaveCafRefs caf_info = TopLevelHasCafs - | otherwise = TopLevelNoCafs - - (stg_rhss, fvs', cafs) + (stg_rhss, fvs', lv_info) = 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) + freeVarsToLiveVars fvs' `thenLne` \ lv_info -> + returnLne (stg_rhss, fvs', lv_info) ) - bind = StgRec (SRTEntries cafs) (zip binders stg_rhss) + bind = StgRec (mkSRT lv_info) (zip binders stg_rhss) in - ASSERT2(and [predictArity rhs == stgRhsArity stg_rhs | (rhs,stg_rhs) <- rhss `zip` stg_rhss], ppr binders) + ASSERT2(and [isLocalId bndr || manifestArity rhs == idArity bndr | (bndr,rhs) <- pairs], ppr binders) + ASSERT2(and [manifestArity 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) @@ -291,7 +306,7 @@ to do it before the SRT pass to save the SRT entries associated with any top-level PAPs. \begin{code} -isPAP (StgApp f args) = idArity f > length args +isPAP (StgApp f args) = listLengthCmp args (idArity f) == LT -- idArity f > length args isPAP _ = False \end{code} @@ -328,15 +343,15 @@ coreToStgExpr expr@(App _ _) (f, args) = myCollectArgs expr coreToStgExpr expr@(Lam _ _) - = let (args, body) = myCollectBinders expr + = 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 = args' `minusFVBinders` body_fvs - escs = body_escs `minusVarSet` set_of_args + escs = body_escs `delVarSetList` args' result_expr | null args' = body | otherwise = StgLam (exprType expr) args' body in @@ -346,112 +361,80 @@ 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, CaseBound)] $ - vars_alts (findDefault alts) `thenLne` \ (alts2, alts_fvs, alts_escs) -> - freeVarsToLiveVars alts_fvs `thenLne` \ (alts_lvs, alts_caf_refs) -> + = extendVarEnvLne [(bndr, LambdaBound)] ( + mapAndUnzip3Lne vars_alt alts `thenLne` \ (alts2, fvs_s, escs_s) -> + returnLne ( mkStgAlts (idType bndr) alts2, + unionFVInfos fvs_s, + unionVarSets escs_s ) + ) `thenLne` \ (alts2, alts_fvs, alts_escs) -> let - -- determine whether the default binder is dead or not + -- 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'= if (bndr `elementOfFVInfo` alts_fvs) - then bndr - else bndr `setIdOccInfo` IAmDead + 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 = (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,alts_caf_refs) ( + + 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_lvs, _) -> - returnLne (scrut2, scrut_fvs, scrut_escs, scrut_lvs) + freeVarsToLiveVars scrut_fvs `thenLne` \ scrut_lv_info -> + returnLne (scrut2, scrut_fvs, scrut_escs, scrut_lv_info) ) - `thenLne` \ (scrut2, scrut_fvs, scrut_escs, scrut_lvs) -> + `thenLne` \ (scrut2, scrut_fvs, scrut_escs, scrut_lv_info) -> - let srt = SRTEntries alts_caf_refs - in returnLne ( - 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 + StgCase scrut2 (getLiveVars scrut_lv_info) + (getLiveVars alts_lv_info) + bndr' + (mkSRT alts_lv_info) + alts2, + scrut_fvs `unionFVInfo` alts_fvs_wo_bndr, + alts_escs_wo_bndr `unionVarSet` getFVSet scrut_fvs -- You might think we should have scrut_escs, not -- (getFVSet scrut_fvs), but actually we can't call, and -- then return from, a let-no-escape thing. ) where - scrut_ty = idType bndr - prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty) - - vars_alts (alts,deflt) - | prim_case - = mapAndUnzip3Lne vars_prim_alt alts - `thenLne` \ (alts2, alts_fvs_list, alts_escs_list) -> - let - alts_fvs = unionFVInfos alts_fvs_list - alts_escs = unionVarSets alts_escs_list - in - vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) -> - returnLne ( - mkStgPrimAlts scrut_ty alts2 deflt2, - alts_fvs `unionFVInfo` deflt_fvs, - alts_escs `unionVarSet` deflt_escs - ) - - | otherwise - = mapAndUnzip3Lne vars_alg_alt alts - `thenLne` \ (alts2, alts_fvs_list, alts_escs_list) -> - let - alts_fvs = unionFVInfos alts_fvs_list - alts_escs = unionVarSets alts_escs_list - in - vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) -> - returnLne ( - mkStgAlgAlts scrut_ty alts2 deflt2, - alts_fvs `unionFVInfo` deflt_fvs, - alts_escs `unionVarSet` deflt_escs - ) - - where - vars_prim_alt (LitAlt lit, _, rhs) - = coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) -> - returnLne ((lit, rhs2), rhs_fvs, rhs_escs) - - vars_alg_alt (DataAlt con, binders, rhs) - = let - -- remove type variables - binders' = filterStgBinders binders - in - extendVarEnvLne [(b, CaseBound) | b <- binders'] $ - coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) -> - let - good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders' ] - -- records whether each param is used in the RHS - in - returnLne ( - (con, binders', good_use_mask, rhs2), - 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) - - 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 @@ -468,21 +451,28 @@ coreToStgExpr (Let bind body) \end{code} \begin{code} -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 +mkStgAlts scrut_ty orig_alts + | is_prim_case = StgPrimAlts (tyConAppTyCon scrut_ty) prim_alts deflt + | otherwise = StgAlgAlts maybe_tycon alg_alts deflt + where + is_prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty) + + prim_alts = [(lit, rhs) | (LitAlt lit, _, _, rhs) <- other_alts] + alg_alts = [(con, bndrs, use, rhs) | (DataAlt con, bndrs, use, rhs) <- other_alts] + + (other_alts, deflt) + = case orig_alts of -- DEFAULT is always first if it's there at all + (DEFAULT, _, _, rhs) : other_alts -> (other_alts, StgBindDefault rhs) + other -> (orig_alts, StgNoDefault) + + maybe_tycon = case alg_alts of + -- Get the tycon from the data con + (dc, _, _, _) : _rest -> Just (dataConTyCon dc) + + -- Otherwise just do your best + [] -> case splitTyConApp_maybe (repType scrut_ty) of + Just (tc,_) | isAlgTyCon tc -> Just tc + _other -> Nothing \end{code} @@ -522,14 +512,17 @@ 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. + -- NB: f_arity is only consulted for LetBound things f_arity = case how_bound of - LetBound _ _ arity -> arity - _ -> 0 + LetBound _ arity -> arity + ImportBound -> idArity f + + saturated = f_arity <= n_val_args fun_occ - | 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 + | 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 @@ -552,10 +545,12 @@ coreToStgApp maybe_thunk_body 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' + DataConId 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 ( @@ -613,28 +608,27 @@ coreToStgLet -- is among the escaping vars coreToStgLet let_no_escape bind body - = fixLne (\ ~(_, _, _, _, _, _, 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 emptyLVS) + else emptyLiveInfo) (vars_bind rec_body_fvs bind) - `thenLne` \ ( bind2, bind_fvs, bind_escs - , bind_lvs, bind_cafs, env_ext) -> + `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_lvs, _) -> + freeVarsToLiveVars body_fvs `thenLne` \ body_lv_info -> - returnLne (bind2, bind_fvs, bind_escs, bind_lvs, bind_cafs, - 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, bind_cafs, + ) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs, body2, body_fvs, body_escs, body_lvs) -> @@ -647,7 +641,7 @@ coreToStgLet let_no_escape bind body = 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 @@ -655,7 +649,7 @@ 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) @@ -684,27 +678,21 @@ 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 bind_cafs binder rhs - = (binder, LetBound NotTopLevelBound -- Not top level - live_vars (predictArity rhs) - ) + 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, bind_cafs) - else - (unitVarSet binder, emptyVarSet) + 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 - StgLiveVars, -- vars live in binding - IdSet, -- CAFs live in binding + LiveInfo, -- Vars and CAFs live in binding [(Id, HowBound)]) -- extension to environment @@ -712,20 +700,20 @@ coreToStgLet let_no_escape bind body = coreToStgRhs body_fvs NotTopLevel (binder,rhs) `thenLne` \ (rhs2, bind_fvs, escs) -> - freeVarsToLiveVars bind_fvs `thenLne` \ (bind_lvs, bind_cafs) -> + freeVarsToLiveVars bind_fvs `thenLne` \ bind_lv_info -> let - env_ext_item = mk_binding bind_lvs bind_cafs binder rhs + env_ext_item = mk_binding bind_lv_info binder rhs in - returnLne (StgNonRec (SRTEntries bind_cafs) binder rhs2, - bind_fvs, escs, bind_lvs, bind_cafs, [env_ext_item]) + returnLne (StgNonRec (mkSRT bind_lv_info) binder rhs2, + bind_fvs, escs, bind_lv_info, [env_ext_item]) vars_bind body_fvs (Rec pairs) - = fixLne (\ ~(_, rec_rhs_fvs, _, bind_lvs, bind_cafs, _) -> + = 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_lvs bind_cafs b rhs + env_ext = [ mk_binding bind_lv_info b rhs | (b,rhs) <- pairs ] in extendVarEnvLne env_ext ( @@ -736,10 +724,10 @@ coreToStgLet let_no_escape bind body escs = unionVarSets escss in freeVarsToLiveVars (binders `minusFVBinders` bind_fvs) - `thenLne` \ (bind_lvs, bind_cafs) -> + `thenLne` \ bind_lv_info -> - returnLne (StgRec (SRTEntries bind_cafs) (binders `zip` rhss2), - bind_fvs, escs, bind_lvs, bind_cafs, env_ext) + returnLne (StgRec (mkSRT bind_lv_info) (binders `zip` rhss2), + bind_fvs, escs, bind_lv_info, env_ext) ) ) @@ -749,28 +737,6 @@ is_join_var :: Id -> Bool is_join_var j = occNameUserString (getOccName j) == "$j" \end{code} -%************************************************************************ -%* * -\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} - %************************************************************************ %* * @@ -783,40 +749,84 @@ help. All the stuff here is only passed *down*. \begin{code} type LneM a = IdEnv HowBound - -> (StgLiveVars, -- vars live in continuation - IdSet) -- cafs live in continuation + -> 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 - | LetBound - TopLevelCafInfo - (StgLiveVars, IdSet) -- (Live vars, Live CAFs)... see notes below - Arity -- its arity (local Ids don't have arity info at this point) - -isLetBound (LetBound _ _ _) = True -isLetBound 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 = 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 + | TopLet CafInfo -- For top level things, is it a CAF, or can it refer to one? + +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 StgLiveVars, the set of -variables that are live if x is live. For "normal" variables that is -just x alone. If x is a let-no-escaped variable then x is represented -by a code pointer and a stack pointer (well, one for each stack). So -all of the variables needed in the execution of x are live if x is, -and are therefore recorded in the LetBound constructor; x itself -*is* included. +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) -The set of live variables is guaranteed ot have no further let-no-escaped +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 emptyLVS +initLne env m = m env emptyLiveInfo + -emptyLVS = (emptyVarSet,emptyVarSet) {-# INLINE thenLne #-} {-# INLINE returnLne #-} @@ -861,10 +871,10 @@ fixLne expr env lvs_cont Functions specific to this monad: \begin{code} -getVarsLiveInCont :: LneM (StgLiveVars, IdSet) +getVarsLiveInCont :: LneM LiveInfo getVarsLiveInCont env lvs_cont = lvs_cont -setVarsLiveInCont :: (StgLiveVars,IdSet) -> LneM a -> LneM a +setVarsLiveInCont :: LiveInfo -> LneM a -> LneM a setVarsLiveInCont new_lvs_cont expr env lvs_cont = expr env new_lvs_cont @@ -873,45 +883,37 @@ 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 + +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 (StgLiveVars, IdSet) +freeVarsToLiveVars :: FreeVarsInfo -> LneM LiveInfo freeVarsToLiveVars fvs env live_in_cont - = returnLne (lvs, cafs) env live_in_cont + = returnLne live_info 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 - = 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) + 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 caf_info) _ + | mayHaveCafRefs caf_info -> 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} %************************************************************************ @@ -921,7 +923,21 @@ freeVarsToLiveVars fvs env live_in_cont %************************************************************************ \begin{code} -type FreeVarsInfo = VarEnv (Var, TopLevelCafInfo, StgBinderInfo) +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. @@ -932,14 +948,6 @@ type FreeVarsInfo = VarEnv (Var, TopLevelCafInfo, StgBinderInfo) -- -- 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} \begin{code} @@ -947,18 +955,17 @@ 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, TopLevelHasCafs, info) + | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, ImportBound, info) | otherwise = emptyVarEnv -singletonFVInfo id (LetBound top_level _ _) info - = unitVarEnv id (id, top_level, info) -singletonFVInfo id other info - = unitVarEnv id (id, NotTopLevelBound, info) +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, NotTopLevelBound, noBinderInfo) + 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 @@ -989,20 +996,33 @@ lookupFVInfo fvs id Nothing -> noBinderInfo Just (_,_,info) -> info -allFreeIds :: FreeVarsInfo -> [Id] -- Non-top-level things only -allFreeIds fvs = [id | (id,_,_) <- rngVarEnv fvs, isId id] +allFreeIds :: FreeVarsInfo -> [(Id,HowBound)] -- Both top level and non-top-level Ids +allFreeIds fvs = [(id,how_bound) | (id,how_bound,_) <- rngVarEnv fvs, isId id] --- Non-top-level things only, both type variables and ids (type variables --- only if opt_RuntimeTypes. +-- 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] +getFVs fvs = [id | (id, how_bound, _) <- rngVarEnv 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. @@ -1077,22 +1097,24 @@ hasCafRefss p exprs | any isCAF exprs || isFastTrue (cafRefss p exprs) = MayHaveCafRefs | otherwise = NoCafRefs --- cafRefs compiles to beautiful code :) +-- The environment that cafRefs uses has top-level bindings *only*. +-- We don't bother to add local bindings as cafRefs traverses the expression +-- because they will all be for LocalIds (all nested things are LocalIds) +-- However, we must look in the env first, because some top level things +-- might be local Ids 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 + = case lookupVarEnv p id of + Just (LetBound (TopLet caf_info) _) -> fastBool (mayHaveCafRefs caf_info) + Nothing | isGlobalId id -> fastBool (mayHaveCafRefs (idCafInfo id)) -- Imported + | otherwise -> fastBool False -- Nested binder + _other -> error ("cafRefs " ++ showSDoc (ppr id)) -- No nested things in env 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 (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