summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
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
commitd30352add1da67dd0346613853cd423c7becbaeb (patch)
tree634126b59821c7b6b27cd00fc3fa287811d86b25
parent13ff0b7ced097286e0d7b054f050871effe07f86 (diff)
downloadhaskell-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.hs4
-rw-r--r--compiler/codeGen/StgCmmBind.hs15
-rw-r--r--compiler/codeGen/StgCmmClosure.hs86
-rw-r--r--compiler/codeGen/StgCmmExpr.hs2
-rw-r--r--compiler/simplStg/StgCse.hs8
-rw-r--r--compiler/simplStg/StgStats.hs2
-rw-r--r--compiler/simplStg/UnariseStg.hs4
-rw-r--r--compiler/stgSyn/CoreToStg.hs140
-rw-r--r--compiler/stgSyn/StgLint.hs4
-rw-r--r--compiler/stgSyn/StgSyn.hs44
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)])