diff options
author | Ömer Sinan Ağacan <omeragacan@gmail.com> | 2016-02-08 16:18:23 -0500 |
---|---|---|
committer | Ömer Sinan Ağacan <omeragacan@gmail.com> | 2016-02-08 16:19:28 -0500 |
commit | 023fc92f6f98a8bd003ce20083d3682aec865cb5 (patch) | |
tree | b08895d5e7575cfc29fa0a13e37df4445b93f6bc /compiler | |
parent | 489a9a3beeeae3d150761ef863b4757eba0b02d9 (diff) | |
download | haskell-023fc92f6f98a8bd003ce20083d3682aec865cb5.tar.gz |
Remove unused LiveVars and SRT fields of StgCase
We also need to update `stgBindHasCafRefs` assertion with this change,
as we no longer have the pre-computed SRT, LiveVars etc. We rename it to
`topStgBindHasCafRefs` and implement it like this:
A non-updatable top-level binding may refer to a CAF by referring to a
top-level definition with CAFs. A top-level definition may have CAFs if
it's updatable. At this point (because this is done after TidyPgm)
top-level Ids (whether imported or defined in this module) are
GlobalIds, so the top-levelness test is easy. (see also comments in the
code)
Reviewers: bgamari, simonpj, austin
Reviewed By: simonpj
Subscribers: thomie
Differential Revision: https://phabricator.haskell.org/D1889
GHC Trac Issues: #11550
Diffstat (limited to 'compiler')
-rw-r--r-- | compiler/codeGen/StgCmm.hs | 2 | ||||
-rw-r--r-- | compiler/codeGen/StgCmmBind.hs | 4 | ||||
-rw-r--r-- | compiler/codeGen/StgCmmExpr.hs | 6 | ||||
-rw-r--r-- | compiler/main/HscMain.hs | 4 | ||||
-rw-r--r-- | compiler/profiling/SCCfinal.hs | 24 | ||||
-rw-r--r-- | compiler/simplStg/StgStats.hs | 6 | ||||
-rw-r--r-- | compiler/simplStg/UnariseStg.hs | 26 | ||||
-rw-r--r-- | compiler/stgSyn/CoreToStg.hs | 226 | ||||
-rw-r--r-- | compiler/stgSyn/StgLint.hs | 8 | ||||
-rw-r--r-- | compiler/stgSyn/StgSyn.hs | 170 |
10 files changed, 164 insertions, 312 deletions
diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index b0dd9b11b8..9d14db9bb8 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -141,7 +141,7 @@ cgTopRhs :: DynFlags -> RecFlag -> Id -> StgRhs -> (CgIdInfo, FCode ()) cgTopRhs dflags _rec bndr (StgRhsCon _cc con args) = cgTopRhsCon dflags bndr con args -cgTopRhs dflags rec bndr (StgRhsClosure cc bi fvs upd_flag _srt args body) +cgTopRhs dflags rec bndr (StgRhsClosure cc bi fvs upd_flag args body) = ASSERT(null fvs) -- There should be no free variables cgTopRhsClosure dflags rec bndr cc bi upd_flag args body diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index fde662b317..ea05e8d488 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -210,7 +210,7 @@ cgRhs id (StgRhsCon cc con args) buildDynCon id True cc con args {- See Note [GC recovery] in compiler/codeGen/StgCmmClosure.hs -} -cgRhs name (StgRhsClosure cc bi fvs upd_flag _srt args body) +cgRhs name (StgRhsClosure cc bi fvs upd_flag args body) = do dflags <- getDynFlags mkRhsClosure dflags name cc bi (nonVoidIds fvs) upd_flag args body @@ -268,7 +268,7 @@ mkRhsClosure dflags bndr _cc _bi expr | let strip = snd . stripStgTicksTop (not . tickishIsCode) , StgCase (StgApp scrutinee [{-no args-}]) - _ _ _ _ -- ignore uniq, etc. + _ -- ignore bndr (AlgAlt _) [(DataAlt _, params, _use_mask, sel_expr)] <- strip expr , StgApp selectee [{-no args-}] <- strip sel_expr diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index 923450e6f3..0f3898bf81 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -71,7 +71,7 @@ cgExpr (StgLit lit) = do cmm_lit <- cgLit lit emitReturn [CmmLit cmm_lit] cgExpr (StgLet binds expr) = do { cgBind binds; cgExpr expr } -cgExpr (StgLetNoEscape _ _ binds expr) = +cgExpr (StgLetNoEscape binds expr) = do { u <- newUnique ; let join_id = mkBlockId u ; cgLneBinds join_id binds @@ -79,7 +79,7 @@ cgExpr (StgLetNoEscape _ _ binds expr) = ; emitLabel join_id ; return r } -cgExpr (StgCase expr _live_vars _save_vars bndr _srt alt_type alts) = +cgExpr (StgCase expr bndr alt_type alts) = cgCase expr bndr alt_type alts cgExpr (StgLam {}) = panic "cgExpr: StgLam" @@ -140,7 +140,7 @@ cgLetNoEscapeRhsBody -> Id -> StgRhs -> FCode (CgIdInfo, FCode ()) -cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _bi _ _upd _ args body) +cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _bi _ _upd args body) = cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args) = cgLetNoEscapeClosure bndr local_cc cc [] (StgConApp con args) diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 58434e93c6..4b26cdb03e 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -1436,8 +1436,8 @@ myCoreToStg :: DynFlags -> Module -> CoreProgram -> IO ( [StgBinding] -- output program , CollectedCCs) -- cost centre info (declared and used) myCoreToStg dflags this_mod prepd_binds = do - stg_binds - <- {-# SCC "Core2Stg" #-} + let stg_binds + = {-# SCC "Core2Stg" #-} coreToStg dflags this_mod prepd_binds (stg_binds2, cost_centre_info) diff --git a/compiler/profiling/SCCfinal.hs b/compiler/profiling/SCCfinal.hs index 6cab87c9cd..6bd00b0f61 100644 --- a/compiler/profiling/SCCfinal.hs +++ b/compiler/profiling/SCCfinal.hs @@ -90,7 +90,7 @@ stgMassageForProfiling dflags mod_name _us stg_binds ---------- do_top_rhs :: Id -> StgRhs -> MassageM StgRhs - do_top_rhs _ (StgRhsClosure _ _ _ _ _ [] + do_top_rhs _ (StgRhsClosure _ _ _ _ [] (StgTick (ProfNote _cc False{-not tick-} _push) (StgConApp con args))) | not (isDllConApp dflags mod_name con args) @@ -100,7 +100,7 @@ stgMassageForProfiling dflags mod_name _us stg_binds -- isDllConApp checks for LitLit args too = return (StgRhsCon dontCareCCS con args) - do_top_rhs binder (StgRhsClosure _ bi fv u srt [] body) + do_top_rhs binder (StgRhsClosure _ bi fv u [] body) = do -- Top level CAF without a cost centre attached -- Attach CAF cc (collect if individual CAF ccs) @@ -119,11 +119,11 @@ stgMassageForProfiling dflags mod_name _us stg_binds else return all_cafs_ccs body' <- do_expr body - return (StgRhsClosure caf_ccs bi fv u srt [] body') + return (StgRhsClosure caf_ccs bi fv u [] body') - do_top_rhs _ (StgRhsClosure _no_ccs bi fv u srt args body) + do_top_rhs _ (StgRhsClosure _no_ccs bi fv u args body) = do body' <- do_expr body - return (StgRhsClosure dontCareCCS bi fv u srt args body') + return (StgRhsClosure dontCareCCS bi fv u args body') do_top_rhs _ (StgRhsCon _ con args) -- Top-level (static) data is not counted in heap @@ -155,10 +155,10 @@ stgMassageForProfiling dflags mod_name _us stg_binds expr' <- do_expr expr return (StgTick ti expr') - do_expr (StgCase expr fv1 fv2 bndr srt alt_type alts) = do + do_expr (StgCase expr bndr alt_type alts) = do expr' <- do_expr expr alts' <- mapM do_alt alts - return (StgCase expr' fv1 fv2 bndr srt alt_type alts') + return (StgCase expr' bndr alt_type alts') where do_alt (id, bs, use_mask, e) = do e' <- do_expr e @@ -168,9 +168,9 @@ stgMassageForProfiling dflags mod_name _us stg_binds (b,e) <- do_let b e return (StgLet b e) - do_expr (StgLetNoEscape lvs1 lvs2 b e) = do + do_expr (StgLetNoEscape b e) = do (b,e) <- do_let b e - return (StgLetNoEscape lvs1 lvs2 b e) + return (StgLetNoEscape b e) do_expr other = pprPanic "SCCfinal.do_expr" (ppr other) @@ -200,15 +200,15 @@ stgMassageForProfiling dflags mod_name _us stg_binds -- allocation of the constructor to the wrong place (XXX) -- We should really attach (PushCC cc CurrentCCS) to the rhs, -- but need to reinstate PushCC for that. - do_rhs (StgRhsClosure _closure_cc _bi _fv _u _srt [] + do_rhs (StgRhsClosure _closure_cc _bi _fv _u [] (StgTick (ProfNote cc False{-not tick-} _push) (StgConApp con args))) = do collectCC cc return (StgRhsCon currentCCS con args) - do_rhs (StgRhsClosure _ bi fv u srt args expr) = do + do_rhs (StgRhsClosure _ bi fv u args expr) = do expr' <- do_expr expr - return (StgRhsClosure currentCCS bi fv u srt args expr') + return (StgRhsClosure currentCCS bi fv u args expr') do_rhs (StgRhsCon _ con args) = return (StgRhsCon currentCCS con args) diff --git a/compiler/simplStg/StgStats.hs b/compiler/simplStg/StgStats.hs index dd1f5a64d2..5860f61057 100644 --- a/compiler/simplStg/StgStats.hs +++ b/compiler/simplStg/StgStats.hs @@ -127,7 +127,7 @@ statRhs :: Bool -> (Id, StgRhs) -> StatEnv statRhs top (_, StgRhsCon _ _ _) = countOne (ConstructorBinds top) -statRhs top (_, StgRhsClosure _ _ fv u _ _ body) +statRhs top (_, StgRhsClosure _ _ fv u _ body) = statExpr body `combineSE` countN FreeVariables (length fv) `combineSE` countOne ( @@ -153,7 +153,7 @@ statExpr (StgConApp _ _) = countOne ConstructorApps statExpr (StgOpApp _ _ _) = countOne PrimitiveApps statExpr (StgTick _ e) = statExpr e -statExpr (StgLetNoEscape _ _ binds body) +statExpr (StgLetNoEscape binds body) = statBinding False{-not top-level-} binds `combineSE` statExpr body `combineSE` countOne LetNoEscapes @@ -162,7 +162,7 @@ statExpr (StgLet binds body) = statBinding False{-not top-level-} binds `combineSE` statExpr body -statExpr (StgCase expr _ _ _ _ _ alts) +statExpr (StgCase expr _ _ alts) = statExpr expr `combineSE` stat_alts alts `combineSE` countOne StgCases diff --git a/compiler/simplStg/UnariseStg.hs b/compiler/simplStg/UnariseStg.hs index b16220134d..705fce01b3 100644 --- a/compiler/simplStg/UnariseStg.hs +++ b/compiler/simplStg/UnariseStg.hs @@ -42,7 +42,6 @@ import MkId (realWorldPrimId) import Type import TysWiredIn import DataCon -import VarSet import OccName import Name import Util @@ -74,9 +73,9 @@ unariseBinding us rho bind = case bind of unariseRhs :: UniqSupply -> UnariseEnv -> StgRhs -> StgRhs unariseRhs us rho rhs = case rhs of - StgRhsClosure ccs b_info fvs update_flag srt args expr + StgRhsClosure ccs b_info fvs update_flag args expr -> StgRhsClosure ccs b_info (unariseIds rho fvs) update_flag - (unariseSRT rho srt) args' (unariseExpr us' rho' expr) + args' (unariseExpr us' rho' expr) where (us', rho', args') = unariseIdBinders us rho args StgRhsCon ccs con args -> StgRhsCon ccs con (unariseArgs rho args) @@ -111,10 +110,8 @@ unariseExpr us rho (StgLam xs e) where (us', rho', xs') = unariseIdBinders us rho xs -unariseExpr us rho (StgCase e case_lives alts_lives bndr srt alt_ty alts) - = StgCase (unariseExpr us1 rho e) (unariseLives rho case_lives) - (unariseLives rho alts_lives) bndr (unariseSRT rho srt) - alt_ty alts' +unariseExpr us rho (StgCase e bndr alt_ty alts) + = StgCase (unariseExpr us1 rho e) bndr alt_ty alts' where (us1, us2) = splitUniqSupply us alts' = unariseAlts us2 rho alt_ty bndr alts @@ -124,9 +121,8 @@ unariseExpr us rho (StgLet bind e) where (us1, us2) = splitUniqSupply us -unariseExpr us rho (StgLetNoEscape live_in_let live_in_bind bind e) - = StgLetNoEscape (unariseLives rho live_in_let) (unariseLives rho live_in_bind) - (unariseBinding us1 rho bind) (unariseExpr us2 rho e) +unariseExpr us rho (StgLetNoEscape bind e) + = StgLetNoEscape (unariseBinding us1 rho bind) (unariseExpr us2 rho e) where (us1, us2) = splitUniqSupply us @@ -161,13 +157,6 @@ unariseAlt us rho (con, xs, uses, e) (us', rho', xs', uses') = unariseUsedIdBinders us rho xs uses ------------------------ -unariseSRT :: UnariseEnv -> SRT -> SRT -unariseSRT _ NoSRT = NoSRT -unariseSRT rho (SRTEntries ids) = SRTEntries (concatMapVarSet (unariseId rho) ids) - -unariseLives :: UnariseEnv -> StgLiveVars -> StgLiveVars -unariseLives rho ids = concatMapVarSet (unariseId rho) ids - unariseArgs :: UnariseEnv -> [StgArg] -> [StgArg] unariseArgs rho = concatMap (unariseArg rho) @@ -212,6 +201,3 @@ unariseIdBinder us rho x = case repType (idType x) of unboxedTupleBindersFrom :: UniqSupply -> Id -> [UnaryType] -> [Id] unboxedTupleBindersFrom us x tys = zipWith (mkSysLocalOrCoVar fs) (uniqsFromSupply us) tys where fs = occNameFS (getOccName x) - -concatMapVarSet :: (Var -> [Var]) -> VarSet -> VarSet -concatMapVarSet f xs = mkVarSet [x' | x <- varSetElems xs, x' <- f x] diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs index 0f81ab3027..414571cbf8 100644 --- a/compiler/stgSyn/CoreToStg.hs +++ b/compiler/stgSyn/CoreToStg.hs @@ -50,11 +50,10 @@ import Control.Monad (liftM, ap) -- Note [Live vs free] -- ~~~~~~~~~~~~~~~~~~~ -- --- The actual Stg datatype is decorated with live variable information, as well --- as free variable information. The two are 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 directly again. In --- particular, a dead variable's stack slot (if it has one): +-- The two are 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 directly again. In particular, a dead +-- variable's stack slot (if it has one): -- -- - should be stubbed to avoid space leaks, and -- - may be reused for something else. @@ -88,8 +87,7 @@ import Control.Monad (liftM, ap) -- Note [Collecting live CAF info] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- --- In this pass we also collect information on which CAFs are live for --- constructing SRTs (see SRT.hs). +-- In this pass we also collect information on which CAFs are live. -- -- A top-level Id has CafInfo, which is -- @@ -108,24 +106,6 @@ import Control.Monad (liftM, ap) -- the actual nested SRTs, and replaces the lists of Ids with (offset,length) -- pairs. - --- Note [Interaction of let-no-escape with SRTs] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- 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. - -- Note [What is a non-escaping let] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- @@ -186,9 +166,9 @@ import Control.Monad (liftM, ap) -- Setting variable info: top-level, binds, RHSs -- -------------------------------------------------------------- -coreToStg :: DynFlags -> Module -> CoreProgram -> IO [StgBinding] +coreToStg :: DynFlags -> Module -> CoreProgram -> [StgBinding] coreToStg dflags this_mod pgm - = return pgm' + = pgm' where (_, _, pgm') = coreTopBindsToStg dflags this_mod emptyVarEnv pgm coreExprToStg :: CoreExpr -> StgExpr @@ -273,7 +253,7 @@ consistentCafInfo id bind 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 + binding_is_caffy = topStgBindHasCafRefs bind is_sat_thing = occNameFS (nameOccName (idName id)) == fsLit "sat" coreToTopStgRhs @@ -285,9 +265,8 @@ coreToTopStgRhs coreToTopStgRhs dflags this_mod scope_fv_info (bndr, rhs) = do { (new_rhs, rhs_fvs, _) <- coreToStgExpr rhs - ; lv_info <- freeVarsToLiveVars rhs_fvs - ; let stg_rhs = mkTopStgRhs dflags this_mod rhs_fvs (mkSRT lv_info) bndr bndr_info new_rhs + ; let stg_rhs = mkTopStgRhs dflags this_mod rhs_fvs bndr bndr_info new_rhs stg_arity = stgRhsArity stg_rhs ; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs, rhs_fvs) } @@ -314,7 +293,7 @@ coreToTopStgRhs dflags this_mod scope_fv_info (bndr, rhs) text "STG arity:" <+> ppr stg_arity] mkTopStgRhs :: DynFlags -> Module -> FreeVarsInfo - -> SRT -> Id -> StgBinderInfo -> StgExpr + -> Id -> StgBinderInfo -> StgExpr -> StgRhs mkTopStgRhs dflags this_mod = mkStgRhs' con_updateable @@ -414,23 +393,12 @@ coreToStgExpr (Case scrut bndr _ alts) = do alts_fvs_wo_bndr = bndr `minusFVBinder` alts_fvs alts_escs_wo_bndr = alts_escs `delVarSet` bndr - alts_lv_info <- freeVarsToLiveVars alts_fvs_wo_bndr - -- We tell the scrutinee that everything -- live in the alts is live in it, too. - (scrut2, scrut_fvs, _scrut_escs, scrut_lv_info) - <- setVarsLiveInCont alts_lv_info $ do - (scrut2, scrut_fvs, scrut_escs) <- coreToStgExpr scrut - scrut_lv_info <- freeVarsToLiveVars scrut_fvs - return (scrut2, scrut_fvs, scrut_escs, scrut_lv_info) + (scrut2, scrut_fvs, _scrut_escs) <- coreToStgExpr scrut return ( - StgCase scrut2 (getLiveVars scrut_lv_info) - (getLiveVars alts_lv_info) - bndr' - (mkSRT alts_lv_info) - (mkStgAltType bndr alts) - alts2, + StgCase scrut2 bndr' (mkStgAltType 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 @@ -682,39 +650,29 @@ coreToStgLet -- is among the escaping vars coreToStgLet let_no_escape bind body = do - (bind2, bind_fvs, bind_escs, bind_lvs, - body2, body_fvs, body_escs, body_lvs) - <- mfix $ \ ~(_, _, _, _, _, rec_body_fvs, _, _) -> do - - -- Do the bindings, setting live_in_cont to empty if - -- we ain't in a let-no-escape world - live_in_cont <- getVarsLiveInCont - ( bind2, bind_fvs, bind_escs, bind_lv_info, env_ext) - <- setVarsLiveInCont (if let_no_escape - then live_in_cont - else emptyLiveInfo) - (vars_bind rec_body_fvs bind) + (bind2, bind_fvs, bind_escs, + body2, body_fvs, body_escs) + <- mfix $ \ ~(_, _, _, _, rec_body_fvs, _) -> do + + ( bind2, bind_fvs, bind_escs, env_ext) + <- vars_bind rec_body_fvs bind -- Do the body extendVarEnvLne env_ext $ do (body2, body_fvs, body_escs) <- coreToStgExpr body - body_lv_info <- freeVarsToLiveVars body_fvs - return (bind2, bind_fvs, bind_escs, getLiveVars bind_lv_info, - body2, body_fvs, body_escs, getLiveVars body_lv_info) + return (bind2, bind_fvs, bind_escs, + body2, body_fvs, body_escs) -- Compute the new let-expression let - new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2 + new_let | let_no_escape = StgLetNoEscape 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 @@ -747,49 +705,43 @@ coreToStgLet let_no_escape bind body = do 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 + mk_binding binder rhs + = (binder, LetBound NestedLet (manifestArity rhs)) 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) = do - (rhs2, bind_fvs, bind_lv_info, escs) <- coreToStgRhs body_fvs [] (binder,rhs) + (rhs2, bind_fvs, escs) <- coreToStgRhs body_fvs (binder,rhs) let - env_ext_item = mk_binding bind_lv_info binder rhs + env_ext_item = mk_binding binder rhs return (StgNonRec binder rhs2, - bind_fvs, escs, bind_lv_info, [env_ext_item]) + bind_fvs, escs, [env_ext_item]) vars_bind body_fvs (Rec pairs) - = mfix $ \ ~(_, rec_rhs_fvs, _, bind_lv_info, _) -> + = mfix $ \ ~(_, rec_rhs_fvs, _, _) -> let rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs binders = map fst pairs - env_ext = [ mk_binding bind_lv_info b rhs + env_ext = [ mk_binding b rhs | (b,rhs) <- pairs ] in extendVarEnvLne env_ext $ do - (rhss2, fvss, lv_infos, escss) - <- mapAndUnzip4M (coreToStgRhs rec_scope_fvs binders) pairs + (rhss2, fvss, escss) + <- mapAndUnzip3M (coreToStgRhs rec_scope_fvs) pairs let bind_fvs = unionFVInfos fvss - bind_lv_info = foldr unionLiveInfo emptyLiveInfo lv_infos escs = unionVarSets escss return (StgRec (binders `zip` rhss2), - bind_fvs, escs, bind_lv_info, env_ext) + bind_fvs, escs, env_ext) is_join_var :: Id -> Bool @@ -798,37 +750,35 @@ is_join_var :: Id -> Bool is_join_var j = occNameString (getOccName j) == "$j" coreToStgRhs :: FreeVarsInfo -- Free var info for the scope of the binding - -> [Id] -> (Id,CoreExpr) - -> LneM (StgRhs, FreeVarsInfo, LiveInfo, EscVarsSet) + -> LneM (StgRhs, FreeVarsInfo, EscVarsSet) -coreToStgRhs scope_fv_info binders (bndr, rhs) = do +coreToStgRhs scope_fv_info (bndr, rhs) = do (new_rhs, rhs_fvs, rhs_escs) <- coreToStgExpr rhs - lv_info <- freeVarsToLiveVars (binders `minusFVBinders` rhs_fvs) - return (mkStgRhs rhs_fvs (mkSRT lv_info) bndr bndr_info new_rhs, - rhs_fvs, lv_info, rhs_escs) + return (mkStgRhs rhs_fvs bndr bndr_info new_rhs, + rhs_fvs, rhs_escs) where bndr_info = lookupFVInfo scope_fv_info bndr -mkStgRhs :: FreeVarsInfo -> SRT -> Id -> StgBinderInfo -> StgExpr -> StgRhs +mkStgRhs :: FreeVarsInfo -> Id -> StgBinderInfo -> StgExpr -> StgRhs mkStgRhs = mkStgRhs' con_updateable where con_updateable _ _ = False mkStgRhs' :: (DataCon -> [StgArg] -> Bool) - -> FreeVarsInfo -> SRT -> Id -> StgBinderInfo -> StgExpr -> StgRhs -mkStgRhs' con_updateable rhs_fvs srt bndr binder_info rhs + -> FreeVarsInfo -> Id -> StgBinderInfo -> StgExpr -> StgRhs +mkStgRhs' con_updateable rhs_fvs bndr binder_info rhs | StgLam bndrs body <- rhs = StgRhsClosure noCCS binder_info (getFVs rhs_fvs) ReEntrant - srt bndrs body + bndrs body | StgConApp con args <- unticked_rhs , not (con_updateable con args) = StgRhsCon noCCS con args | otherwise = StgRhsClosure noCCS binder_info (getFVs rhs_fvs) - upd_flag srt [] rhs + upd_flag [] rhs where (_, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs @@ -896,17 +846,10 @@ isPAP env _ = False newtype LneM a = LneM { unLneM :: 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 @@ -920,10 +863,7 @@ data HowBound 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 + | NestedLet isLetBound :: HowBound -> Bool isLetBound (LetBound _ _) = True @@ -948,31 +888,10 @@ topLevelBound _ = False -- The set of dynamic live variables is guaranteed ot have no further -- let-no-escaped variables in it. -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 - -- The std monad functions: initLne :: IdEnv HowBound -> LneM a -> a -initLne env m = unLneM m env emptyLiveInfo +initLne env m = unLneM m env @@ -980,11 +899,11 @@ initLne env m = unLneM m env emptyLiveInfo {-# INLINE returnLne #-} returnLne :: a -> LneM a -returnLne e = LneM $ \_ _ -> e +returnLne e = LneM $ \_ -> e thenLne :: LneM a -> (a -> LneM b) -> LneM b -thenLne m k = LneM $ \env lvs_cont - -> unLneM (k (unLneM m env lvs_cont)) env lvs_cont +thenLne m k = LneM $ \env + -> unLneM (k (unLneM m env)) env instance Functor LneM where fmap = liftM @@ -997,27 +916,19 @@ instance Monad LneM where (>>=) = thenLne instance MonadFix LneM where - mfix expr = LneM $ \env lvs_cont -> - let result = unLneM (expr result) env lvs_cont + mfix expr = LneM $ \env -> + let result = unLneM (expr result) env in result -- Functions specific to this monad: -getVarsLiveInCont :: LneM LiveInfo -getVarsLiveInCont = LneM $ \_env lvs_cont -> lvs_cont - -setVarsLiveInCont :: LiveInfo -> LneM a -> LneM a -setVarsLiveInCont new_lvs_cont expr - = LneM $ \env _lvs_cont - -> unLneM expr env new_lvs_cont - extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a extendVarEnvLne ids_w_howbound expr - = LneM $ \env lvs_cont - -> unLneM expr (extendVarEnvList env ids_w_howbound) lvs_cont + = LneM $ \env + -> unLneM expr (extendVarEnvList env ids_w_howbound) lookupVarLne :: Id -> LneM HowBound -lookupVarLne v = LneM $ \env _lvs_cont -> lookupBinding env v +lookupVarLne v = LneM $ \env -> lookupBinding env v lookupBinding :: IdEnv HowBound -> Id -> HowBound lookupBinding env v = case lookupVarEnv env v of @@ -1025,32 +936,6 @@ lookupBinding env v = case lookupVarEnv env v of 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 = LneM freeVarsToLiveVars' - where - freeVarsToLiveVars' _env live_in_cont = live_info - 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 - - -- --------------------------------------------------------------------------- -- Free variable information -- --------------------------------------------------------------------------- @@ -1117,11 +1002,6 @@ lookupFVInfo fvs id Nothing -> noBinderInfo Just (_,_,info) -> info -allFreeIds :: FreeVarsInfo -> [(Id,HowBound)] -- Both top level and non-top-level Ids -allFreeIds fvs = ASSERT( all (isId . fst) ids ) ids - where - ids = [(id,how_bound) | (id,how_bound,_) <- varEnvElts fvs] - -- Non-top-level things only, both type variables and ids getFVs :: FreeVarsInfo -> [Var] getFVs fvs = [id | (id, how_bound, _) <- varEnvElts fvs, @@ -1145,9 +1025,9 @@ check_eq_how_bound (LetBound li1 ar1) (LetBound li2 ar2) = ar1 == ar2 && check_e check_eq_how_bound _ _ = False check_eq_li :: LetInfo -> LetInfo -> Bool -check_eq_li (NestedLet _) (NestedLet _) = True -check_eq_li TopLet TopLet = True -check_eq_li _ _ = False +check_eq_li NestedLet NestedLet = True +check_eq_li TopLet TopLet = True +check_eq_li _ _ = False -- Misc. diff --git a/compiler/stgSyn/StgLint.hs b/compiler/stgSyn/StgLint.hs index a871778e32..df3c4e57df 100644 --- a/compiler/stgSyn/StgLint.hs +++ b/compiler/stgSyn/StgLint.hs @@ -124,10 +124,10 @@ lint_binds_help (binder, rhs) lintStgRhs :: StgRhs -> LintM (Maybe Type) -- Just ty => type is exact -lintStgRhs (StgRhsClosure _ _ _ _ _ [] expr) +lintStgRhs (StgRhsClosure _ _ _ _ [] expr) = lintStgExpr expr -lintStgRhs (StgRhsClosure _ _ _ _ _ binders expr) +lintStgRhs (StgRhsClosure _ _ _ _ binders expr) = addLoc (LambdaBodyOf binders) $ addInScopeVars binders $ runMaybeT $ do body_ty <- MaybeT $ lintStgExpr expr @@ -176,7 +176,7 @@ lintStgExpr (StgLet binds body) = do addInScopeVars binders $ lintStgExpr body -lintStgExpr (StgLetNoEscape _ _ binds body) = do +lintStgExpr (StgLetNoEscape binds body) = do binders <- lintStgBinds binds addLoc (BodyOfLetRec binders) $ addInScopeVars binders $ @@ -184,7 +184,7 @@ lintStgExpr (StgLetNoEscape _ _ binds body) = do lintStgExpr (StgTick _ expr) = lintStgExpr expr -lintStgExpr (StgCase scrut _ _ bndr _ alts_type alts) = runMaybeT $ do +lintStgExpr (StgCase scrut bndr alts_type alts) = runMaybeT $ do _ <- MaybeT $ lintStgExpr scrut in_scope <- MaybeT $ liftM Just $ diff --git a/compiler/stgSyn/StgSyn.hs b/compiler/stgSyn/StgSyn.hs index 204e843567..1fc84125f9 100644 --- a/compiler/stgSyn/StgSyn.hs +++ b/compiler/stgSyn/StgSyn.hs @@ -31,11 +31,8 @@ module StgSyn ( -- StgOp StgOp(..), - -- SRTs - SRT(..), - -- utils - stgBindHasCafRefs, stgArgHasCafRefs, stgRhsArity, + topStgBindHasCafRefs, stgArgHasCafRefs, stgRhsArity, isDllConApp, stgArgType, stripStgTicksTop, @@ -69,7 +66,6 @@ import Type ( typePrimRep ) import UniqSet import Unique ( Unique ) import Util -import VarSet ( IdSet, isEmptyVarSet ) {- ************************************************************************ @@ -82,8 +78,6 @@ As usual, expressions are interesting; other things are boring. Here are the boring things [except note the @GenStgRhs@], parameterised with respect to binder and occurrence information (just as in @CoreSyn@): - -There is one SRT for each group of bindings. -} data GenStgBinding bndr occ @@ -237,23 +231,8 @@ This has the same boxed/unboxed business as Core case expressions. (GenStgExpr bndr occ) -- the thing to examine - (GenStgLiveVars occ) - -- Live vars of whole case expression, - -- plus everything that happens after the case - -- i.e., those which mustn't be overwritten - - (GenStgLiveVars occ) - -- Live vars of RHSs (plus what happens afterwards) - -- i.e., those which must be saved before eval. - -- - -- note that an alt's constructor's - -- binder-variables are NOT counted in the - -- free vars for the alt's RHS - bndr -- binds the result of evaluating the scrutinee - SRT -- The SRT for the continuation - AltType [GenStgAlt bndr occ] @@ -358,16 +337,7 @@ And so the code for let(rec)-things: (GenStgBinding bndr occ) -- right hand sides (see below) (GenStgExpr bndr occ) -- body - | StgLetNoEscape -- remember: ``advanced stuff'' - (GenStgLiveVars occ) -- Live in the whole let-expression - -- Mustn't overwrite these stack slots - -- _Doesn't_ include binders of the let(rec). - - (GenStgLiveVars occ) -- Live in the right hand sides (only) - -- These are the ones which must be saved on - -- the stack if they aren't there already - -- _Does_ include binders of the let(rec) if recursive. - + | StgLetNoEscape (GenStgBinding bndr occ) -- right hand sides (see below) (GenStgExpr bndr occ) -- body @@ -405,7 +375,6 @@ data GenStgRhs bndr occ [occ] -- non-global free vars; a list, rather than -- a set, because order is important !UpdateFlag -- ReEntrant | Updatable | SingleEntry - SRT -- The SRT reference [bndr] -- arguments; if empty, then not a function; -- as above, order is important. (GenStgExpr bndr occ) -- body @@ -436,24 +405,84 @@ The second flavour of right-hand-side is for constructors (simple but important) [GenStgArg occ] -- args stgRhsArity :: StgRhs -> Int -stgRhsArity (StgRhsClosure _ _ _ _ _ bndrs _) +stgRhsArity (StgRhsClosure _ _ _ _ bndrs _) = ASSERT( all isId bndrs ) length bndrs -- The arity never includes type parameters, but they should have gone by now stgRhsArity (StgRhsCon _ _ _) = 0 -stgBindHasCafRefs :: GenStgBinding bndr Id -> Bool -stgBindHasCafRefs (StgNonRec _ rhs) = rhsHasCafRefs rhs -stgBindHasCafRefs (StgRec binds) = any rhsHasCafRefs (map snd binds) +-- Note [CAF consistency] +-- ~~~~~~~~~~~~~~~~~~~~~~ +-- +-- `topStgBindHasCafRefs` is only used by an assert (`consistentCafInfo` in +-- `CoreToStg`) to make sure CAF-ness predicted by `TidyPgm` is consistent with +-- reality. +-- +-- Specifically, if the RHS mentions any Id that itself is marked +-- `MayHaveCafRefs`; or if the binding is a top-level updateable thunk; then the +-- `Id` for the binding should be marked `MayHaveCafRefs`. The potential trouble +-- is that `TidyPgm` computed the CAF info on the `Id` but some transformations +-- have taken place since then. + +topStgBindHasCafRefs :: GenStgBinding bndr Id -> Bool +topStgBindHasCafRefs (StgNonRec _ rhs) + = topRhsHasCafRefs rhs +topStgBindHasCafRefs (StgRec binds) + = any topRhsHasCafRefs (map snd binds) + +topRhsHasCafRefs :: GenStgRhs bndr Id -> Bool +topRhsHasCafRefs (StgRhsClosure _ _ _ upd _ body) + = -- See Note [CAF consistency] + isUpdatable upd || exprHasCafRefs body +topRhsHasCafRefs (StgRhsCon _ _ args) + = any stgArgHasCafRefs args + +exprHasCafRefs :: GenStgExpr bndr Id -> Bool +exprHasCafRefs (StgApp f args) + = stgIdHasCafRefs f || any stgArgHasCafRefs args +exprHasCafRefs StgLit{} + = False +exprHasCafRefs (StgConApp _ args) + = any stgArgHasCafRefs args +exprHasCafRefs (StgOpApp _ args _) + = any stgArgHasCafRefs args +exprHasCafRefs (StgLam _ body) + = exprHasCafRefs body +exprHasCafRefs (StgCase scrt _ _ alts) + = exprHasCafRefs scrt || any altHasCafRefs alts +exprHasCafRefs (StgLet bind body) + = bindHasCafRefs bind || exprHasCafRefs body +exprHasCafRefs (StgLetNoEscape bind body) + = bindHasCafRefs bind || exprHasCafRefs body +exprHasCafRefs (StgTick _ expr) + = exprHasCafRefs expr + +bindHasCafRefs :: GenStgBinding bndr Id -> Bool +bindHasCafRefs (StgNonRec _ rhs) + = rhsHasCafRefs rhs +bindHasCafRefs (StgRec binds) + = any rhsHasCafRefs (map snd binds) rhsHasCafRefs :: GenStgRhs bndr Id -> Bool -rhsHasCafRefs (StgRhsClosure _ _ _ upd srt _ _) - = isUpdatable upd || nonEmptySRT srt +rhsHasCafRefs (StgRhsClosure _ _ _ _ _ body) + = exprHasCafRefs body rhsHasCafRefs (StgRhsCon _ _ args) = any stgArgHasCafRefs args +altHasCafRefs :: GenStgAlt bndr Id -> Bool +altHasCafRefs (_, _, _, rhs) = exprHasCafRefs rhs + stgArgHasCafRefs :: GenStgArg Id -> Bool -stgArgHasCafRefs (StgVarArg id) = mayHaveCafRefs (idCafInfo id) -stgArgHasCafRefs _ = False +stgArgHasCafRefs (StgVarArg id) + = stgIdHasCafRefs id +stgArgHasCafRefs _ + = False + +stgIdHasCafRefs :: Id -> Bool +stgIdHasCafRefs id = + -- We are looking for occurrences of an Id that is bound at top level, and may + -- have CAF refs. At this point (after TidyPgm) top-level Ids (whether + -- imported or defined in this module) are GlobalIds, so the test is easy. + isGlobalId id && mayHaveCafRefs (idCafInfo id) -- Here's the @StgBinderInfo@ type, and its combining op: @@ -494,7 +523,7 @@ Very like in @CoreSyntax@ (except no type-world stuff). The type constructor is guaranteed not to be abstract; that is, we can see its representation. This is important because the code generator uses it to determine return conventions etc. But it's not trivial -where there's a moduule loop involved, because some versions of a type +where there's a module loop involved, because some versions of a type constructor might not have all the constructors visible. So mkStgAlgAlts (in CoreToStg) ensures that it gets the TyCon from the constructors or literals (which are guaranteed to have the Real McCoy) @@ -587,34 +616,6 @@ data StgOp {- ************************************************************************ * * -\subsubsection[Static Reference Tables]{@SRT@} -* * -************************************************************************ - -There is one SRT per top-level function group. Each local binding and -case expression within this binding group has a subrange of the whole -SRT, expressed as an offset and length. - -In CoreToStg we collect the list of CafRefs at each SRT site, which is later -converted into the length and offset form by the SRT pass. --} - -data SRT - = NoSRT - | SRTEntries IdSet - -- generated by CoreToStg - -nonEmptySRT :: SRT -> Bool -nonEmptySRT NoSRT = False -nonEmptySRT (SRTEntries vs) = not (isEmptyVarSet vs) - -pprSRT :: SRT -> SDoc -pprSRT (NoSRT) = text "_no_srt_" -pprSRT (SRTEntries ids) = text "SRT:" <> ppr ids - -{- -************************************************************************ -* * \subsection[Stg-pretty-printing]{Pretty-printing} * * ************************************************************************ @@ -719,15 +720,10 @@ pprStgExpr (StgLet bind expr) = sep [hang (text "let {") 2 (pprGenStgBinding bind), hang (text "} in ") 2 (ppr expr)] -pprStgExpr (StgLetNoEscape lvs_whole lvs_rhss bind expr) +pprStgExpr (StgLetNoEscape bind expr) = sep [hang (text "let-no-escape {") 2 (pprGenStgBinding bind), - hang (text "} in " <> - ifPprDebug ( - nest 4 ( - hcat [ptext (sLit "-- lvs: ["), interppSP (uniqSetToList lvs_whole), - text "]; rhs lvs: [", interppSP (uniqSetToList lvs_rhss), - char ']']))) + hang (text "} in ") 2 (ppr expr)] pprStgExpr (StgTick tickish expr) @@ -737,17 +733,11 @@ pprStgExpr (StgTick tickish expr) else pprStgExpr expr -pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alt_type alts) +pprStgExpr (StgCase expr bndr alt_type alts) = sep [sep [text "case", nest 4 (hsep [pprStgExpr expr, ifPprDebug (dcolon <+> ppr alt_type)]), text "of", pprBndr CaseBind bndr, char '{'], - ifPprDebug ( - nest 4 ( - hcat [ptext (sLit "-- lvs: ["), interppSP (uniqSetToList lvs_whole), - text "]; rhs lvs: [", interppSP (uniqSetToList lvs_rhss), - text "]; ", - pprMaybeSRT srt])), nest 2 (vcat (map pprStgAlt alts)), char '}'] @@ -780,25 +770,21 @@ pprStgRhs :: (OutputableBndr bndr, Outputable bdee, Ord bdee) => GenStgRhs bndr bdee -> SDoc -- special case -pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag srt [{-no args-}] (StgApp func [])) +pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func [])) = hcat [ ppr cc, pp_binder_info bi, brackets (ifPprDebug (ppr free_var)), - text " \\", ppr upd_flag, pprMaybeSRT srt, ptext (sLit " [] "), ppr func ] + text " \\", ppr upd_flag, ptext (sLit " [] "), ppr func ] -- general case -pprStgRhs (StgRhsClosure cc bi free_vars upd_flag srt args body) +pprStgRhs (StgRhsClosure cc bi free_vars upd_flag args body) = sdocWithDynFlags $ \dflags -> hang (hsep [if gopt Opt_SccProfilingOn dflags then ppr cc else empty, pp_binder_info bi, ifPprDebug (brackets (interppSP free_vars)), - char '\\' <> ppr upd_flag, pprMaybeSRT srt, brackets (interppSP args)]) + char '\\' <> ppr upd_flag, brackets (interppSP args)]) 4 (ppr body) pprStgRhs (StgRhsCon cc con args) = hcat [ ppr cc, space, ppr con, text "! ", brackets (interppSP args)] - -pprMaybeSRT :: SRT -> SDoc -pprMaybeSRT (NoSRT) = empty -pprMaybeSRT srt = text "srt:" <> pprSRT srt |