diff options
author | Ömer Sinan Ağacan <omeragacan@gmail.com> | 2018-11-12 06:50:54 +0300 |
---|---|---|
committer | Ömer Sinan Ağacan <omeragacan@gmail.com> | 2018-11-12 06:51:49 +0300 |
commit | d30352add1da67dd0346613853cd423c7becbaeb (patch) | |
tree | 634126b59821c7b6b27cd00fc3fa287811d86b25 | |
parent | 13ff0b7ced097286e0d7b054f050871effe07f86 (diff) | |
download | haskell-d30352add1da67dd0346613853cd423c7becbaeb.tar.gz |
Remove StgBinderInfo and related computation in CoreToStg
- The StgBinderInfo type was never used in the code gen, so the type, related
computation in CoreToStg, and some comments about it are removed. See #15770
for more details.
- Simplified CoreToStg after removing the StgBinderInfo computation: removed
StgBinderInfo arguments and mfix stuff.
The StgBinderInfo values were not used in the code gen, but I still run nofib
just to make sure: 0.0% change in allocations and binary sizes.
Test Plan: Validated locally
Reviewers: simonpj, simonmar, bgamari, sgraf
Reviewed By: sgraf
Subscribers: AndreasK, sgraf, rwbarton, carter
Differential Revision: https://phabricator.haskell.org/D5232
-rw-r--r-- | compiler/codeGen/StgCmm.hs | 4 | ||||
-rw-r--r-- | compiler/codeGen/StgCmmBind.hs | 15 | ||||
-rw-r--r-- | compiler/codeGen/StgCmmClosure.hs | 86 | ||||
-rw-r--r-- | compiler/codeGen/StgCmmExpr.hs | 2 | ||||
-rw-r--r-- | compiler/simplStg/StgCse.hs | 8 | ||||
-rw-r--r-- | compiler/simplStg/StgStats.hs | 2 | ||||
-rw-r--r-- | compiler/simplStg/UnariseStg.hs | 4 | ||||
-rw-r--r-- | compiler/stgSyn/CoreToStg.hs | 140 | ||||
-rw-r--r-- | compiler/stgSyn/StgLint.hs | 4 | ||||
-rw-r--r-- | compiler/stgSyn/StgSyn.hs | 44 |
10 files changed, 61 insertions, 248 deletions
diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index 60be1ca01b..5b80ba61d9 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -153,9 +153,9 @@ cgTopRhs dflags _rec bndr (StgRhsCon _cc con args) -- con args are always non-void, -- see Note [Post-unarisation invariants] in UnariseStg -cgTopRhs dflags rec bndr (StgRhsClosure cc bi fvs upd_flag args body) +cgTopRhs dflags rec bndr (StgRhsClosure cc fvs upd_flag args body) = ASSERT(null fvs) -- There should be no free variables - cgTopRhsClosure dflags rec bndr cc bi upd_flag args body + cgTopRhsClosure dflags rec bndr cc upd_flag args body --------------------------------------------------------------- diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index aa2b954a95..004bf90c67 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -62,13 +62,12 @@ cgTopRhsClosure :: DynFlags -> RecFlag -- member of a recursive group? -> Id -> CostCentreStack -- Optional cost centre annotation - -> StgBinderInfo -> UpdateFlag -> [Id] -- Args -> StgExpr -> (CgIdInfo, FCode ()) -cgTopRhsClosure dflags rec id ccs _ upd_flag args body = +cgTopRhsClosure dflags rec id ccs upd_flag args body = let closure_label = mkLocalClosureLabel (idName id) (idCafInfo id) cg_id_info = litIdInfo dflags id lf_info (CmmLabel closure_label) lf_info = mkClosureLFInfo dflags id TopLevel [] upd_flag args @@ -207,15 +206,15 @@ cgRhs id (StgRhsCon cc con args) -- see Note [Post-unarisation invariants] in UnariseStg {- See Note [GC recovery] in compiler/codeGen/StgCmmClosure.hs -} -cgRhs id (StgRhsClosure cc bi fvs upd_flag args body) +cgRhs id (StgRhsClosure cc fvs upd_flag args body) = do dflags <- getDynFlags - mkRhsClosure dflags id cc bi (nonVoidIds fvs) upd_flag args body + mkRhsClosure dflags id cc (nonVoidIds fvs) upd_flag args body ------------------------------------------------------------------------ -- Non-constructor right hand sides ------------------------------------------------------------------------ -mkRhsClosure :: DynFlags -> Id -> CostCentreStack -> StgBinderInfo +mkRhsClosure :: DynFlags -> Id -> CostCentreStack -> [NonVoid Id] -- Free vars -> UpdateFlag -> [Id] -- Args @@ -258,7 +257,7 @@ for semi-obvious reasons. -} ---------- Note [Selectors] ------------------ -mkRhsClosure dflags bndr _cc _bi +mkRhsClosure dflags bndr _cc [NonVoid the_fv] -- Just one free var upd_flag -- Updatable thunk [] -- A thunk @@ -291,7 +290,7 @@ mkRhsClosure dflags bndr _cc _bi in cgRhsStdThunk bndr lf_info [StgVarArg the_fv] ---------- Note [Ap thunks] ------------------ -mkRhsClosure dflags bndr _cc _bi +mkRhsClosure dflags bndr _cc fvs upd_flag [] -- No args; a thunk @@ -323,7 +322,7 @@ mkRhsClosure dflags bndr _cc _bi payload = StgVarArg fun_id : args ---------- Default case ------------------ -mkRhsClosure dflags bndr cc _ fvs upd_flag args body +mkRhsClosure dflags bndr cc fvs upd_flag args body = do { let lf_info = mkClosureLFInfo dflags bndr NotTopLevel fvs upd_flag args ; (id_info, reg) <- rhsIdInfo bndr lf_info ; return (id_info, gen_code lf_info reg) } diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index 6f0feaa557..65e7cf7dab 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -623,92 +623,6 @@ getCallMethod _ _name _ LFLetNoEscape _n_args _v_args (LneLoc blk_id lne_regs) getCallMethod _ _ _ _ _ _ _ _ = panic "Unknown call method" ----------------------------------------------------------------------------- --- staticClosureRequired ------------------------------------------------------------------------------ - -{- staticClosureRequired is never called (hence commented out) - - SimonMar writes (Sept 07) It's an optimisation we used to apply at - one time, I believe, but it got lost probably in the rewrite of - the RTS/code generator. I left that code there to remind me to - look into whether it was worth doing sometime - -{- Avoiding generating entries and info tables - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -At present, for every function we generate all of the following, -just in case. But they aren't always all needed, as noted below: - -[NB1: all of this applies only to *functions*. Thunks always -have closure, info table, and entry code.] - -[NB2: All are needed if the function is *exported*, just to play safe.] - -* Fast-entry code ALWAYS NEEDED - -* Slow-entry code - Needed iff (a) we have any un-saturated calls to the function - OR (b) the function is passed as an arg - OR (c) we're in the parallel world and the function has free vars - [Reason: in parallel world, we always enter functions - with free vars via the closure.] - -* The function closure - Needed iff (a) we have any un-saturated calls to the function - OR (b) the function is passed as an arg - OR (c) if the function has free vars (ie not top level) - - Why case (a) here? Because if the arg-satis check fails, - UpdatePAP stuffs a pointer to the function closure in the PAP. - [Could be changed; UpdatePAP could stuff in a code ptr instead, - but doesn't seem worth it.] - - [NB: these conditions imply that we might need the closure - without the slow-entry code. Here's how. - - f x y = let g w = ...x..y..w... - in - ...(g t)... - - Here we need a closure for g which contains x and y, - but since the calls are all saturated we just jump to the - fast entry point for g, with R1 pointing to the closure for g.] - - -* Standard info table - Needed iff (a) we have any un-saturated calls to the function - OR (b) the function is passed as an arg - OR (c) the function has free vars (ie not top level) - - NB. In the sequential world, (c) is only required so that the function closure has - an info table to point to, to keep the storage manager happy. - If (c) alone is true we could fake up an info table by choosing - one of a standard family of info tables, whose entry code just - bombs out. - - [NB In the parallel world (c) is needed regardless because - we enter functions with free vars via the closure.] - - If (c) is retained, then we'll sometimes generate an info table - (for storage mgr purposes) without slow-entry code. Then we need - to use an error label in the info table to substitute for the absent - slow entry code. --} - -staticClosureRequired - :: Name - -> StgBinderInfo - -> LambdaFormInfo - -> Bool -staticClosureRequired binder bndr_info - (LFReEntrant top_level _ _ _ _) -- It's a function - = ASSERT( isTopLevel top_level ) - -- Assumption: it's a top-level, no-free-var binding - not (satCallsOnly bndr_info) - -staticClosureRequired binder other_binder_info other_lf_info = True --} - ------------------------------------------------------------------------------ -- Data types for closure information ----------------------------------------------------------------------------- diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index 1af8fb3376..7fc9dfc829 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -151,7 +151,7 @@ cgLetNoEscapeRhsBody -> Id -> StgRhs -> FCode (CgIdInfo, FCode ()) -cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _bi _ _upd args body) +cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _ _upd args body) = cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args) = cgLetNoEscapeClosure bndr local_cc cc [] diff --git a/compiler/simplStg/StgCse.hs b/compiler/simplStg/StgCse.hs index 2caf006e3f..fe7943c7d8 100644 --- a/compiler/simplStg/StgCse.hs +++ b/compiler/simplStg/StgCse.hs @@ -284,9 +284,9 @@ stgCseTopLvl in_scope (StgTopLifted (StgRec eqs)) where in_scope' = in_scope `extendInScopeSetList` [ bndr | (bndr, _) <- eqs ] stgCseTopLvlRhs :: InScopeSet -> InStgRhs -> OutStgRhs -stgCseTopLvlRhs in_scope (StgRhsClosure ccs info occs upd args body) +stgCseTopLvlRhs in_scope (StgRhsClosure ccs occs upd args body) = let body' = stgCseExpr (initEnv in_scope) body - in StgRhsClosure ccs info occs upd args body' + in StgRhsClosure ccs occs upd args body' stgCseTopLvlRhs _ (StgRhsCon ccs dataCon args) = StgRhsCon ccs dataCon args @@ -402,11 +402,11 @@ stgCseRhs env bndr (StgRhsCon ccs dataCon args) pair = (bndr, StgRhsCon ccs dataCon args') in (Just pair, env') where args' = substArgs env args -stgCseRhs env bndr (StgRhsClosure ccs info occs upd args body) +stgCseRhs env bndr (StgRhsClosure ccs occs upd args body) = let (env1, args') = substBndrs env args env2 = forgetCse env1 -- See note [Free variables of an StgClosure] body' = stgCseExpr env2 body - in (Just (substVar env bndr, StgRhsClosure ccs info occs' upd args' body'), env) + in (Just (substVar env bndr, StgRhsClosure ccs occs' upd args' body'), env) where occs' = substVars env occs diff --git a/compiler/simplStg/StgStats.hs b/compiler/simplStg/StgStats.hs index 712ec2d22e..c548d80707 100644 --- a/compiler/simplStg/StgStats.hs +++ b/compiler/simplStg/StgStats.hs @@ -131,7 +131,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 ( diff --git a/compiler/simplStg/UnariseStg.hs b/compiler/simplStg/UnariseStg.hs index 5c271c2ea0..a46497452f 100644 --- a/compiler/simplStg/UnariseStg.hs +++ b/compiler/simplStg/UnariseStg.hs @@ -281,11 +281,11 @@ unariseBinding rho (StgRec xrhss) = StgRec <$> mapM (\(x, rhs) -> (x,) <$> unariseRhs rho rhs) xrhss unariseRhs :: UnariseEnv -> StgRhs -> UniqSM StgRhs -unariseRhs rho (StgRhsClosure ccs b_info fvs update_flag args expr) +unariseRhs rho (StgRhsClosure ccs fvs update_flag args expr) = do (rho', args1) <- unariseFunArgBinders rho args expr' <- unariseExpr rho' expr let fvs' = unariseFreeVars rho fvs - return (StgRhsClosure ccs b_info fvs' update_flag args1 expr') + return (StgRhsClosure ccs fvs' update_flag args1 expr') unariseRhs rho (StgRhsCon ccs con args) = ASSERT(not (isUnboxedTupleCon con || isUnboxedSumCon con)) diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs index 8275564448..12940753f9 100644 --- a/compiler/stgSyn/CoreToStg.hs +++ b/compiler/stgSyn/CoreToStg.hs @@ -118,19 +118,6 @@ import Control.Monad (liftM, ap) -- -- See also: Commentary/Rts/Storage/GC/CAFs on the GHC Wiki. --- Note [Collecting live CAF info] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- In this pass we also collect information on which CAFs are live. --- --- 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. --- -- Note [What is a non-escaping let] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- @@ -282,7 +269,7 @@ coreTopBindToStg dflags this_mod env body_fvs ccs (NonRec id rhs) (stg_rhs, fvs', ccs') = initCts env $ - coreToTopStgRhs dflags ccs this_mod body_fvs (id,rhs) + coreToTopStgRhs dflags ccs this_mod (id,rhs) bind = StgTopLifted $ StgNonRec id stg_rhs in @@ -308,7 +295,7 @@ coreTopBindToStg dflags this_mod env body_fvs ccs (Rec pairs) = initCts env' $ do mapAccumLM (\(fvs, ccs) rhs -> do (rhs', fvs', ccs') <- - coreToTopStgRhs dflags ccs this_mod body_fvs rhs + coreToTopStgRhs dflags ccs this_mod rhs return ((fvs' `unionFVInfo` fvs, ccs'), rhs')) (body_fvs, ccs) pairs @@ -338,15 +325,14 @@ coreToTopStgRhs :: DynFlags -> CollectedCCs -> Module - -> FreeVarsInfo -- Free var info for the scope of the binding -> (Id,CoreExpr) -> CtsM (StgRhs, FreeVarsInfo, CollectedCCs) -coreToTopStgRhs dflags ccs this_mod scope_fv_info (bndr, rhs) +coreToTopStgRhs dflags ccs this_mod (bndr, rhs) = do { (new_rhs, rhs_fvs) <- coreToStgExpr rhs ; let (stg_rhs, ccs') = - mkTopStgRhs dflags this_mod ccs rhs_fvs bndr bndr_info new_rhs + mkTopStgRhs dflags this_mod ccs rhs_fvs bndr new_rhs stg_arity = stgRhsArity stg_rhs @@ -354,8 +340,6 @@ coreToTopStgRhs dflags ccs this_mod scope_fv_info (bndr, rhs) rhs_fvs, ccs') } where - bndr_info = lookupFVInfo scope_fv_info bndr - -- It's vital that the arity on a top-level Id matches -- the arity of the generated STG binding, else an importing -- module will use the wrong calling convention @@ -558,8 +542,7 @@ coreToStgApp _ f args ticks = do let n_val_args = valArgCount args - not_letrec_bound = not (isLetBound how_bound) - fun_fvs = singletonFVInfo f how_bound fun_occ + fun_fvs = singletonFVInfo f how_bound -- 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 @@ -574,11 +557,6 @@ coreToStgApp _ f args ticks = do 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 - res_ty = exprType (mkApps (Var f) args) app = case idDetails f of DataConWorkId dc @@ -612,8 +590,6 @@ coreToStgApp _ f args ticks = do fvs ) - - -- --------------------------------------------------------------------------- -- Argument lists -- This is the guy that turns applications into A-normal form @@ -686,10 +662,10 @@ coreToStgLet coreToStgLet bind body = do (bind2, bind_fvs, body2, body_fvs) - <- mfix $ \ ~(_, _, _, rec_body_fvs) -> do + <- do ( bind2, bind_fvs, env_ext) - <- vars_bind rec_body_fvs bind + <- vars_bind bind -- Do the body extendVarEnvCts env_ext $ do @@ -698,7 +674,6 @@ coreToStgLet bind body = do return (bind2, bind_fvs, body2, body_fvs) - -- Compute the new let-expression let new_let | isJoinBind bind = StgLetNoEscape bind2 body2 @@ -717,59 +692,51 @@ coreToStgLet bind body = do mk_binding binder rhs = (binder, LetBound NestedLet (manifestArity rhs)) - vars_bind :: FreeVarsInfo -- Free var info for body of binding - -> CoreBind + vars_bind :: CoreBind -> CtsM (StgBinding, FreeVarsInfo, [(Id, HowBound)]) -- extension to environment - - vars_bind body_fvs (NonRec binder rhs) = do - (rhs2, bind_fvs) <- coreToStgRhs body_fvs (binder,rhs) + vars_bind (NonRec binder rhs) = do + (rhs2, bind_fvs) <- coreToStgRhs (binder,rhs) let env_ext_item = mk_binding binder rhs return (StgNonRec binder rhs2, bind_fvs, [env_ext_item]) - - vars_bind body_fvs (Rec pairs) - = mfix $ \ ~(_, rec_rhs_fvs, _) -> - let - rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs + vars_bind (Rec pairs) + = let binders = map fst pairs env_ext = [ mk_binding b rhs | (b,rhs) <- pairs ] in extendVarEnvCts env_ext $ do (rhss2, fvss) - <- mapAndUnzipM (coreToStgRhs rec_scope_fvs) pairs + <- mapAndUnzipM coreToStgRhs pairs let bind_fvs = unionFVInfos fvss return (StgRec (binders `zip` rhss2), bind_fvs, env_ext) -coreToStgRhs :: FreeVarsInfo -- Free var info for the scope of the binding - -> (Id,CoreExpr) +coreToStgRhs :: (Id,CoreExpr) -> CtsM (StgRhs, FreeVarsInfo) -coreToStgRhs scope_fv_info (bndr, rhs) = do +coreToStgRhs (bndr, rhs) = do (new_rhs, rhs_fvs) <- coreToStgExpr rhs - return (mkStgRhs rhs_fvs bndr bndr_info new_rhs, rhs_fvs) - where - bndr_info = lookupFVInfo scope_fv_info bndr + return (mkStgRhs rhs_fvs bndr new_rhs, rhs_fvs) -- Generate a top-level RHS. Any new cost centres generated for CAFs will be -- appended to `CollectedCCs` argument. mkTopStgRhs :: DynFlags -> Module -> CollectedCCs - -> FreeVarsInfo -> Id -> StgBinderInfo -> StgExpr + -> FreeVarsInfo -> Id -> StgExpr -> (StgRhs, CollectedCCs) -mkTopStgRhs dflags this_mod ccs rhs_fvs bndr binder_info rhs +mkTopStgRhs dflags this_mod ccs rhs_fvs bndr rhs | StgLam bndrs body <- rhs = -- StgLam can't have empty arguments, so not CAF - ( StgRhsClosure dontCareCCS binder_info + ( StgRhsClosure dontCareCCS (getFVs rhs_fvs) ReEntrant (toList bndrs) body @@ -785,13 +752,13 @@ mkTopStgRhs dflags this_mod ccs rhs_fvs bndr binder_info rhs -- Otherwise it's a CAF, see Note [Cost-centre initialization plan]. | gopt Opt_AutoSccsOnIndividualCafs dflags - = ( StgRhsClosure caf_ccs binder_info + = ( StgRhsClosure caf_ccs (getFVs rhs_fvs) upd_flag [] rhs , collectCC caf_cc caf_ccs ccs ) | otherwise - = ( StgRhsClosure all_cafs_ccs binder_info + = ( StgRhsClosure all_cafs_ccs (getFVs rhs_fvs) upd_flag [] rhs , ccs ) @@ -816,17 +783,17 @@ mkTopStgRhs dflags this_mod ccs rhs_fvs bndr binder_info rhs -- Generate a non-top-level RHS. Cost-centre is always currentCCS, -- see Note [Cost-centre initialzation plan]. -mkStgRhs :: FreeVarsInfo -> Id -> StgBinderInfo -> StgExpr -> StgRhs -mkStgRhs rhs_fvs bndr binder_info rhs +mkStgRhs :: FreeVarsInfo -> Id -> StgExpr -> StgRhs +mkStgRhs rhs_fvs bndr rhs | StgLam bndrs body <- rhs - = StgRhsClosure currentCCS binder_info + = StgRhsClosure currentCCS (getFVs rhs_fvs) ReEntrant (toList bndrs) body | isJoinId bndr -- must be a nullary join point = ASSERT(idJoinArity bndr == 0) - StgRhsClosure currentCCS binder_info + StgRhsClosure currentCCS (getFVs rhs_fvs) ReEntrant -- ignored for LNE [] rhs @@ -835,7 +802,7 @@ mkStgRhs rhs_fvs bndr binder_info rhs = StgRhsCon currentCCS con args | otherwise - = StgRhsClosure currentCCS binder_info + = StgRhsClosure currentCCS (getFVs rhs_fvs) upd_flag [] rhs where @@ -924,10 +891,6 @@ data LetInfo | NestedLet deriving (Eq) -isLetBound :: HowBound -> Bool -isLetBound (LetBound _ _) = True -isLetBound _ = False - topLevelBound :: HowBound -> Bool topLevelBound ImportBound = True topLevelBound (LetBound TopLet _) = True @@ -974,11 +937,6 @@ instance Applicative CtsM where instance Monad CtsM where (>>=) = thenCts -instance MonadFix CtsM where - mfix expr = CtsM $ \env -> - let result = unCtsM (expr result) env - in result - -- Functions specific to this monad: extendVarEnvCts :: [(Id, HowBound)] -> CtsM a -> CtsM a @@ -1007,7 +965,7 @@ getAllCAFsCC this_mod = -- Free variable information -- --------------------------------------------------------------------------- -type FreeVarsInfo = VarEnv (Var, HowBound, StgBinderInfo) +type FreeVarsInfo = VarEnv (Var, HowBound) -- The Var is so we can gather up the free variables -- as a set. -- @@ -1017,31 +975,16 @@ type FreeVarsInfo = VarEnv (Var, HowBound, StgBinderInfo) -- 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 - -- occurrence info. - -- - -- For ILX we track free var info for type variables too; - -- hence VarEnv not IdEnv emptyFVInfo :: FreeVarsInfo emptyFVInfo = emptyVarEnv -singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo +singletonFVInfo :: Id -> HowBound -> 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) +singletonFVInfo id ImportBound + | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, ImportBound) | otherwise = emptyVarEnv -singletonFVInfo id how_bound info = unitVarEnv id (id, how_bound, info) +singletonFVInfo id how_bound = unitVarEnv id (id, how_bound) unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2 @@ -1060,29 +1003,20 @@ minusFVBinder v fv = fv `delVarEnv` v elementOfFVInfo :: Id -> FreeVarsInfo -> Bool elementOfFVInfo id fvs = isJust (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 - -- Non-top-level things only, both type variables and ids getFVs :: FreeVarsInfo -> [Var] -getFVs fvs = [id | (id, how_bound, _) <- nonDetEltsUFM fvs, +getFVs fvs = [id | (id, how_bound) <- nonDetEltsUFM fvs, -- It's OK to use nonDetEltsUFM here because we're not aiming for -- bit-for-bit determinism. -- See Note [Unique Determinism and code generation] not (topLevelBound how_bound) ] -plusFVInfo :: (Var, HowBound, StgBinderInfo) - -> (Var, HowBound, StgBinderInfo) - -> (Var, HowBound, StgBinderInfo) -plusFVInfo (id1,hb1,info1) (id2,hb2,info2) +plusFVInfo :: (Var, HowBound) + -> (Var, HowBound) + -> (Var, HowBound) +plusFVInfo (id1,hb1) (id2,hb2) = ASSERT(id1 == id2 && hb1 == hb2) - (id1, hb1, combineStgBinderInfo info1 info2) + (id1, hb1) -- Misc. diff --git a/compiler/stgSyn/StgLint.hs b/compiler/stgSyn/StgLint.hs index 58f14a1b3f..35a498f368 100644 --- a/compiler/stgSyn/StgLint.hs +++ b/compiler/stgSyn/StgLint.hs @@ -116,10 +116,10 @@ lint_binds_help (binder, rhs) lintStgRhs :: StgRhs -> LintM () -lintStgRhs (StgRhsClosure _ _ _ _ [] expr) +lintStgRhs (StgRhsClosure _ _ _ [] expr) = lintStgExpr expr -lintStgRhs (StgRhsClosure _ _ _ _ binders expr) +lintStgRhs (StgRhsClosure _ _ _ binders expr) = addLoc (LambdaBodyOf binders) $ addInScopeVars binders $ lintStgExpr expr diff --git a/compiler/stgSyn/StgSyn.hs b/compiler/stgSyn/StgSyn.hs index eb905f7456..7d347f4865 100644 --- a/compiler/stgSyn/StgSyn.hs +++ b/compiler/stgSyn/StgSyn.hs @@ -19,10 +19,6 @@ module StgSyn ( UpdateFlag(..), isUpdatable, - StgBinderInfo, - noBinderInfo, stgSatOcc, stgUnsatOcc, satCallsOnly, - combineStgBinderInfo, - -- a set of synonyms for the most common (only :-) parameterisation StgArg, StgTopBinding, StgBinding, StgExpr, StgRhs, StgAlt, @@ -393,7 +389,6 @@ flavour is for closures: data GenStgRhs bndr occ = StgRhsClosure CostCentreStack -- CCS to be attached (default is CurrentCCS) - StgBinderInfo -- Info about how this binder is used (see below) [occ] -- non-global free vars; a list, rather than -- a set, because order is important !UpdateFlag -- ReEntrant | Updatable | SingleEntry @@ -428,7 +423,7 @@ 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 @@ -455,7 +450,7 @@ topStgBindHasCafRefs StgTopStringLit{} = False topRhsHasCafRefs :: GenStgRhs bndr Id -> Bool -topRhsHasCafRefs (StgRhsClosure _ _ _ upd _ body) +topRhsHasCafRefs (StgRhsClosure _ _ upd _ body) = -- See Note [CAF consistency] isUpdatable upd || exprHasCafRefs body topRhsHasCafRefs (StgRhsCon _ _ args) @@ -488,7 +483,7 @@ bindHasCafRefs (StgRec binds) = any rhsHasCafRefs (map snd binds) rhsHasCafRefs :: GenStgRhs bndr Id -> Bool -rhsHasCafRefs (StgRhsClosure _ _ _ _ _ body) +rhsHasCafRefs (StgRhsClosure _ _ _ _ body) = exprHasCafRefs body rhsHasCafRefs (StgRhsCon _ _ args) = any stgArgHasCafRefs args @@ -509,33 +504,6 @@ stgIdHasCafRefs id = -- 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: - -data StgBinderInfo - = NoStgBinderInfo - | SatCallsOnly -- All occurrences are *saturated* *function* calls - -- This means we don't need to build an info table and - -- slow entry code for the thing - -- Thunks never get this value - -noBinderInfo, stgUnsatOcc, stgSatOcc :: StgBinderInfo -noBinderInfo = NoStgBinderInfo -stgUnsatOcc = NoStgBinderInfo -stgSatOcc = SatCallsOnly - -satCallsOnly :: StgBinderInfo -> Bool -satCallsOnly SatCallsOnly = True -satCallsOnly NoStgBinderInfo = False - -combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo -combineStgBinderInfo SatCallsOnly SatCallsOnly = SatCallsOnly -combineStgBinderInfo _ _ = NoStgBinderInfo - --------------- -pp_binder_info :: StgBinderInfo -> SDoc -pp_binder_info NoStgBinderInfo = empty -pp_binder_info SatCallsOnly = text "sat-only" - {- ************************************************************************ * * @@ -818,19 +786,17 @@ pprStgRhs :: (OutputableBndr bndr, Outputable bdee, Ord bdee) => GenStgRhs bndr bdee -> SDoc -- special case -pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func [])) +pprStgRhs (StgRhsClosure cc [free_var] upd_flag [{-no args-}] (StgApp func [])) = sdocWithDynFlags $ \dflags -> hsep [ ppr cc, - pp_binder_info bi, if not $ gopt Opt_SuppressStgFreeVars dflags then brackets (ppr free_var) else empty, text " \\", ppr upd_flag, ptext (sLit " [] "), ppr func ] -- general case -pprStgRhs (StgRhsClosure cc bi free_vars upd_flag args body) +pprStgRhs (StgRhsClosure cc free_vars upd_flag args body) = sdocWithDynFlags $ \dflags -> hang (hsep [if gopt Opt_SccProfilingOn dflags then ppr cc else empty, - pp_binder_info bi, if not $ gopt Opt_SuppressStgFreeVars dflags then brackets (interppSP free_vars) else empty, char '\\' <> ppr upd_flag, brackets (interppSP args)]) |