summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSebastian Graf <sebastian.graf@kit.edu>2018-11-19 17:48:44 +0100
committerSebastian Graf <sebastian.graf@kit.edu>2018-11-19 17:48:44 +0100
commit47bbc709cb221e32310c6e28eb2f33acf78488c7 (patch)
tree07326ee259a4b547d4a568e815204b7c1f543567
parentcc615c697b54e3141e7b30b975de0b07dc9b8b29 (diff)
downloadhaskell-47bbc709cb221e32310c6e28eb2f33acf78488c7.tar.gz
Don't track free variables in STG syntax by default
Summary: Currently, `CoreToStg` annotates `StgRhsClosure`s with their set of non-global free variables. This free variable information is only needed in the final code generation step (i.e. `StgCmm.codeGen`), which leads to transformations such as `StgCse` and `StgUnarise` having to maintain this information. This is tiresome and unnecessary, so this patch introduces a trees-to-grow-like approach that only introduces the free variable set into the syntax tree in the code gen pass, along with a free variable analysis on STG terms to generate that information. Fixes #15754. Reviewers: simonpj, osa1, bgamari, simonmar Reviewed By: osa1 Subscribers: rwbarton, carter GHC Trac Issues: #15754 Differential Revision: https://phabricator.haskell.org/D5324
Diffstat
-rw-r--r--compiler/basicTypes/VarSet.hs5
-rw-r--r--compiler/codeGen/StgCmm.hs14
-rw-r--r--compiler/codeGen/StgCmmBind.hs20
-rw-r--r--compiler/codeGen/StgCmmBind.hs-boot4
-rw-r--r--compiler/codeGen/StgCmmExpr.hs26
-rw-r--r--compiler/ghc.cabal.in1
-rw-r--r--compiler/main/DynFlags.hs8
-rw-r--r--compiler/main/HscMain.hs4
-rw-r--r--compiler/simplStg/StgCse.hs12
-rw-r--r--compiler/simplStg/StgStats.hs8
-rw-r--r--compiler/simplStg/UnariseStg.hs23
-rw-r--r--compiler/stgSyn/CoreToStg.hs295
-rw-r--r--compiler/stgSyn/StgFVs.hs125
-rw-r--r--compiler/stgSyn/StgSyn.hs224
-rw-r--r--compiler/utils/UniqDSet.hs7
-rw-r--r--testsuite/tests/simplCore/should_compile/noinline01.stderr8
16 files changed, 408 insertions, 376 deletions
diff --git a/compiler/basicTypes/VarSet.hs b/compiler/basicTypes/VarSet.hs
index fb44d31fd3..ec8a325b25 100644
--- a/compiler/basicTypes/VarSet.hs
+++ b/compiler/basicTypes/VarSet.hs
@@ -35,7 +35,7 @@ module VarSet (
intersectDVarSet, dVarSetIntersectVarSet,
intersectsDVarSet, disjointDVarSet,
isEmptyDVarSet, delDVarSet, delDVarSetList,
- minusDVarSet, foldDVarSet, filterDVarSet,
+ minusDVarSet, foldDVarSet, filterDVarSet, mapDVarSet,
dVarSetMinusVarSet, anyDVarSet, allDVarSet,
transCloDVarSet,
sizeDVarSet, seqDVarSet,
@@ -295,6 +295,9 @@ anyDVarSet p = anyUDFM p . getUniqDSet
allDVarSet :: (Var -> Bool) -> DVarSet -> Bool
allDVarSet p = allUDFM p . getUniqDSet
+mapDVarSet :: Uniquable b => (a -> b) -> UniqDSet a -> UniqDSet b
+mapDVarSet = mapUniqDSet
+
filterDVarSet :: (Var -> Bool) -> DVarSet -> DVarSet
filterDVarSet = filterUniqDSet
diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs
index 5b80ba61d9..59ceba8706 100644
--- a/compiler/codeGen/StgCmm.hs
+++ b/compiler/codeGen/StgCmm.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
-----------------------------------------------------------------------------
--
@@ -44,6 +45,7 @@ import Module
import Outputable
import Stream
import BasicTypes
+import VarSet ( isEmptyVarSet )
import OrdList
import MkGraph
@@ -57,10 +59,10 @@ codeGen :: DynFlags
-> Module
-> [TyCon]
-> CollectedCCs -- (Local/global) cost-centres needing declaring/registering.
- -> [StgTopBinding] -- Bindings to convert
+ -> [CgStgTopBinding] -- Bindings to convert
-> HpcInfo
-> Stream IO CmmGroup () -- Output as a stream, so codegen can
- -- be interleaved with output
+ -- be interleaved with output
codeGen dflags this_mod data_tycons
cost_centre_info stg_binds hpc_info
@@ -117,7 +119,7 @@ This is so that we can write the top level processing in a compositional
style, with the increasing static environment being plumbed as a state
variable. -}
-cgTopBinding :: DynFlags -> StgTopBinding -> FCode ()
+cgTopBinding :: DynFlags -> CgStgTopBinding -> FCode ()
cgTopBinding dflags (StgTopLifted (StgNonRec id rhs))
= do { id' <- maybeExternaliseId dflags id
; let (info, fcode) = cgTopRhs dflags NonRecursive id' rhs
@@ -144,7 +146,7 @@ cgTopBinding dflags (StgTopStringLit id str)
; addBindC (litIdInfo dflags id' mkLFStringLit lit)
}
-cgTopRhs :: DynFlags -> RecFlag -> Id -> StgRhs -> (CgIdInfo, FCode ())
+cgTopRhs :: DynFlags -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ())
-- The Id is passed along for setting up a binding...
-- It's already been externalised if necessary
@@ -153,8 +155,8 @@ 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 fvs upd_flag args body)
- = ASSERT(null fvs) -- There should be no free variables
+cgTopRhs dflags rec bndr (StgRhsClosure fvs cc upd_flag args body)
+ = ASSERT(isEmptyVarSet fvs) -- There should be no free variables
cgTopRhsClosure dflags rec bndr cc upd_flag args body
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index 004bf90c67..dba122fd0c 100644
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -44,6 +44,7 @@ import Name
import Module
import ListSetOps
import Util
+import UniqSet ( nonDetEltsUniqSet )
import BasicTypes
import Outputable
import FastString
@@ -64,7 +65,7 @@ cgTopRhsClosure :: DynFlags
-> CostCentreStack -- Optional cost centre annotation
-> UpdateFlag
-> [Id] -- Args
- -> StgExpr
+ -> CgStgExpr
-> (CgIdInfo, FCode ())
cgTopRhsClosure dflags rec id ccs upd_flag args body =
@@ -121,7 +122,7 @@ cgTopRhsClosure dflags rec id ccs upd_flag args body =
-- Non-top-level bindings
------------------------------------------------------------------------
-cgBind :: StgBinding -> FCode ()
+cgBind :: CgStgBinding -> FCode ()
cgBind (StgNonRec name rhs)
= do { (info, fcode) <- cgRhs name rhs
; addBindC info
@@ -190,7 +191,7 @@ cgBind (StgRec pairs)
-}
cgRhs :: Id
- -> StgRhs
+ -> CgStgRhs
-> FCode (
CgIdInfo -- The info for this binding
, FCode CmmAGraph -- A computation which will generate the
@@ -206,9 +207,12 @@ 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 fvs upd_flag args body)
+cgRhs id (StgRhsClosure fvs cc upd_flag args body)
= do dflags <- getDynFlags
- mkRhsClosure dflags id cc (nonVoidIds fvs) upd_flag args body
+ mkRhsClosure dflags id cc (nonVoidIds (nonDetEltsUniqSet fvs)) upd_flag args body
+ -- It's OK to use nonDetEltsUniqSet here because we're not aiming for
+ -- bit-for-bit determinism.
+ -- See Note [Unique Determinism and code generation]
------------------------------------------------------------------------
-- Non-constructor right hand sides
@@ -218,7 +222,7 @@ mkRhsClosure :: DynFlags -> Id -> CostCentreStack
-> [NonVoid Id] -- Free vars
-> UpdateFlag
-> [Id] -- Args
- -> StgExpr
+ -> CgStgExpr
-> FCode (CgIdInfo, FCode CmmAGraph)
{- mkRhsClosure looks for two special forms of the right-hand side:
@@ -436,7 +440,7 @@ closureCodeBody :: Bool -- whether this is a top-level binding
-> CostCentreStack -- Optional cost centre attached to closure
-> [NonVoid Id] -- incoming args to the closure
-> Int -- arity, including void args
- -> StgExpr
+ -> CgStgExpr
-> [(NonVoid Id, ByteOff)] -- the closure's free vars
-> FCode ()
@@ -560,7 +564,7 @@ mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node'
-----------------------------------------
thunkCode :: ClosureInfo -> [(NonVoid Id, ByteOff)] -> CostCentreStack
- -> LocalReg -> Int -> StgExpr -> FCode ()
+ -> LocalReg -> Int -> CgStgExpr -> FCode ()
thunkCode cl_info fv_details _cc node arity body
= do { dflags <- getDynFlags
; let node_points = nodeMustPointToIt dflags (closureLFInfo cl_info)
diff --git a/compiler/codeGen/StgCmmBind.hs-boot b/compiler/codeGen/StgCmmBind.hs-boot
index 5840e990c8..8e3dd38ad8 100644
--- a/compiler/codeGen/StgCmmBind.hs-boot
+++ b/compiler/codeGen/StgCmmBind.hs-boot
@@ -1,6 +1,6 @@
module StgCmmBind where
import StgCmmMonad( FCode )
-import StgSyn( StgBinding )
+import StgSyn( CgStgBinding )
-cgBind :: StgBinding -> FCode ()
+cgBind :: CgStgBinding -> FCode ()
diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index 7fc9dfc829..e8d111f9d5 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -56,7 +56,7 @@ import Data.Function ( on )
-- cgExpr: the main function
------------------------------------------------------------------------
-cgExpr :: StgExpr -> FCode ReturnKind
+cgExpr :: CgStgExpr -> FCode ReturnKind
cgExpr (StgApp fun args) = cgIdApp fun args
@@ -114,7 +114,7 @@ bound only to stable things like stack locations.. The 'e' part will
execute *next*, just like the scrutinee of a case. -}
-------------------------
-cgLneBinds :: BlockId -> StgBinding -> FCode ()
+cgLneBinds :: BlockId -> CgStgBinding -> FCode ()
cgLneBinds join_id (StgNonRec bndr rhs)
= do { local_cc <- saveCurrentCostCentre
-- See Note [Saving the current cost centre]
@@ -135,7 +135,7 @@ cgLetNoEscapeRhs
:: BlockId -- join point for successor of let-no-escape
-> Maybe LocalReg -- Saved cost centre
-> Id
- -> StgRhs
+ -> CgStgRhs
-> FCode (CgIdInfo, FCode ())
cgLetNoEscapeRhs join_id local_cc bndr rhs =
@@ -149,9 +149,9 @@ cgLetNoEscapeRhs join_id local_cc bndr rhs =
cgLetNoEscapeRhsBody
:: Maybe LocalReg -- Saved cost centre
-> Id
- -> StgRhs
+ -> CgStgRhs
-> FCode (CgIdInfo, FCode ())
-cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _ _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 []
@@ -168,7 +168,7 @@ cgLetNoEscapeClosure
-> Maybe LocalReg -- Slot for saved current cost centre
-> CostCentreStack -- XXX: *** NOT USED *** why not?
-> [NonVoid Id] -- Args (as in \ args -> body)
- -> StgExpr -- Body (as in above)
+ -> CgStgExpr -- Body (as in above)
-> FCode (CgIdInfo, FCode ())
cgLetNoEscapeClosure bndr cc_slot _unused_cc args body
@@ -298,7 +298,7 @@ data GcPlan
-- of the case alternative(s) into the upstream check
-------------------------------------
-cgCase :: StgExpr -> Id -> AltType -> [StgAlt] -> FCode ReturnKind
+cgCase :: CgStgExpr -> Id -> AltType -> [CgStgAlt] -> FCode ReturnKind
cgCase (StgOpApp (StgPrimOp op) args _) bndr (AlgAlt tycon) alts
| isEnumerationTyCon tycon -- Note [case on bool]
@@ -547,7 +547,7 @@ maybeSaveCostCentre simple_scrut
-----------------
-isSimpleScrut :: StgExpr -> AltType -> FCode Bool
+isSimpleScrut :: CgStgExpr -> AltType -> FCode Bool
-- Simple scrutinee, does not block or allocate; hence safe to amalgamate
-- heap usage from alternatives into the stuff before the case
-- NB: if you get this wrong, and claim that the expression doesn't allocate
@@ -570,7 +570,7 @@ isSimpleOp (StgPrimOp op) stg_args = do
isSimpleOp (StgPrimCallOp _) _ = return False
-----------------
-chooseReturnBndrs :: Id -> AltType -> [StgAlt] -> [NonVoid Id]
+chooseReturnBndrs :: Id -> AltType -> [CgStgAlt] -> [NonVoid Id]
-- These are the binders of a case that are assigned by the evaluation of the
-- scrutinee.
-- They're non-void, see Note [Post-unarisation invariants] in UnariseStg.
@@ -591,7 +591,7 @@ chooseReturnBndrs _ _ _ = panic "chooseReturnBndrs"
-- MultiValAlt has only one alternative
-------------------------------------
-cgAlts :: (GcPlan,ReturnKind) -> NonVoid Id -> AltType -> [StgAlt]
+cgAlts :: (GcPlan,ReturnKind) -> NonVoid Id -> AltType -> [CgStgAlt]
-> FCode ReturnKind
-- At this point the result of the case are in the binders
cgAlts gc_plan _bndr PolyAlt [(_, _, rhs)]
@@ -666,7 +666,7 @@ cgAlts _ _ _ _ = panic "cgAlts"
-- goto L1
-------------------
-cgAlgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [StgAlt]
+cgAlgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [CgStgAlt]
-> FCode ( Maybe CmmAGraphScoped
, [(ConTagZ, CmmAGraphScoped)] )
cgAlgAltRhss gc_plan bndr alts
@@ -686,13 +686,13 @@ cgAlgAltRhss gc_plan bndr alts
-------------------
-cgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [StgAlt]
+cgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [CgStgAlt]
-> FCode [(AltCon, CmmAGraphScoped)]
cgAltRhss gc_plan bndr alts = do
dflags <- getDynFlags
let
base_reg = idToReg dflags bndr
- cg_alt :: StgAlt -> FCode (AltCon, CmmAGraphScoped)
+ cg_alt :: CgStgAlt -> FCode (AltCon, CmmAGraphScoped)
cg_alt (con, bndrs, rhs)
= getCodeScoped $
maybeAltHeapCheck gc_plan $
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 2844e2d56e..893f959b1c 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -441,6 +441,7 @@ Library
CoreToStg
StgLint
StgSyn
+ StgFVs
CallArity
DmdAnal
Exitify
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index d78b5984e1..2b1992274b 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -616,7 +616,7 @@ data GeneralFlag
-- Except for uniques, as some simplifier phases introduce new
-- variables that have otherwise identical names.
| Opt_SuppressUniques
- | Opt_SuppressStgFreeVars
+ | Opt_SuppressStgExts
| Opt_SuppressTicks -- Replaces Opt_PprShowTicks
| Opt_SuppressTimestamps -- ^ Suppress timestamps in dumps
@@ -3166,7 +3166,7 @@ dynamic_flags_deps = [
setGeneralFlag Opt_SuppressTypeApplications
setGeneralFlag Opt_SuppressIdInfo
setGeneralFlag Opt_SuppressTicks
- setGeneralFlag Opt_SuppressStgFreeVars
+ setGeneralFlag Opt_SuppressStgExts
setGeneralFlag Opt_SuppressTypeSignatures
setGeneralFlag Opt_SuppressTimestamps)
@@ -3976,7 +3976,9 @@ dFlagsDeps = [
depFlagSpec' "ppr-ticks" Opt_PprShowTicks
(\turn_on -> useInstead "-d" "suppress-ticks" (not turn_on)),
flagSpec "suppress-ticks" Opt_SuppressTicks,
- flagSpec "suppress-stg-free-vars" Opt_SuppressStgFreeVars,
+ depFlagSpec' "suppress-stg-free-vars" Opt_SuppressStgExts
+ (useInstead "-d" "suppress-stg-exts"),
+ flagSpec "suppress-stg-exts" Opt_SuppressStgExts,
flagSpec "suppress-coercions" Opt_SuppressCoercions,
flagSpec "suppress-idinfo" Opt_SuppressIdInfo,
flagSpec "suppress-unfoldings" Opt_SuppressUnfoldings,
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 9dd750736a..837e903631 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -124,6 +124,7 @@ import CorePrep
import CoreToStg ( coreToStg )
import qualified StgCmm ( codeGen )
import StgSyn
+import StgFVs ( annTopBindingsFreeVars )
import CostCentre
import ProfInit
import TyCon
@@ -1426,10 +1427,11 @@ doCodeGen hsc_env this_mod data_tycons
cost_centre_info stg_binds hpc_info = do
let dflags = hsc_dflags hsc_env
+ let stg_binds_w_fvs = annTopBindingsFreeVars stg_binds
let cmm_stream :: Stream IO CmmGroup ()
cmm_stream = {-# SCC "StgCmm" #-}
StgCmm.codeGen dflags this_mod data_tycons
- cost_centre_info stg_binds hpc_info
+ cost_centre_info stg_binds_w_fvs hpc_info
-- codegen consumes a stream of CmmGroup, and produces a new
-- stream of CmmGroup (not necessarily synchronised: one
diff --git a/compiler/simplStg/StgCse.hs b/compiler/simplStg/StgCse.hs
index fe7943c7d8..a22a7c1400 100644
--- a/compiler/simplStg/StgCse.hs
+++ b/compiler/simplStg/StgCse.hs
@@ -227,9 +227,6 @@ substArg :: CseEnv -> InStgArg -> OutStgArg
substArg env (StgVarArg from) = StgVarArg (substVar env from)
substArg _ (StgLitArg lit) = StgLitArg lit
-substVars :: CseEnv -> [InId] -> [OutId]
-substVars env = map (substVar env)
-
substVar :: CseEnv -> InId -> OutId
substVar env id = fromMaybe id $ lookupVarEnv (ce_subst env) id
@@ -284,9 +281,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 occs upd args body)
+stgCseTopLvlRhs in_scope (StgRhsClosure ext ccs upd args body)
= let body' = stgCseExpr (initEnv in_scope) body
- in StgRhsClosure ccs occs upd args body'
+ in StgRhsClosure ext ccs upd args body'
stgCseTopLvlRhs _ (StgRhsCon ccs dataCon args)
= StgRhsCon ccs dataCon args
@@ -402,12 +399,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 occs upd args body)
+stgCseRhs env bndr (StgRhsClosure ext ccs 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 occs' upd args' body'), env)
- where occs' = substVars env occs
+ in (Just (substVar env bndr, StgRhsClosure ext ccs upd args' body'), env)
mkStgCase :: StgExpr -> OutId -> AltType -> [StgAlt] -> StgExpr
diff --git a/compiler/simplStg/StgStats.hs b/compiler/simplStg/StgStats.hs
index c548d80707..a2a9a8530f 100644
--- a/compiler/simplStg/StgStats.hs
+++ b/compiler/simplStg/StgStats.hs
@@ -66,9 +66,6 @@ combineSEs = foldr combineSE emptySE
countOne :: CounterType -> StatEnv
countOne c = Map.singleton c 1
-countN :: CounterType -> Int -> StatEnv
-countN = Map.singleton
-
{-
************************************************************************
* *
@@ -131,9 +128,8 @@ statRhs :: Bool -> (Id, StgRhs) -> StatEnv
statRhs top (_, StgRhsCon _ _ _)
= countOne (ConstructorBinds top)
-statRhs top (_, StgRhsClosure _ fv u _ body)
- = statExpr body `combineSE`
- countN FreeVariables (length fv) `combineSE`
+statRhs top (_, StgRhsClosure _ _ u _ body)
+ = statExpr body `combineSE`
countOne (
case u of
ReEntrant -> ReEntrantBinds top
diff --git a/compiler/simplStg/UnariseStg.hs b/compiler/simplStg/UnariseStg.hs
index a46497452f..c3a8bc76e2 100644
--- a/compiler/simplStg/UnariseStg.hs
+++ b/compiler/simplStg/UnariseStg.hs
@@ -281,11 +281,10 @@ unariseBinding rho (StgRec xrhss)
= StgRec <$> mapM (\(x, rhs) -> (x,) <$> unariseRhs rho rhs) xrhss
unariseRhs :: UnariseEnv -> StgRhs -> UniqSM StgRhs
-unariseRhs rho (StgRhsClosure ccs fvs update_flag args expr)
+unariseRhs rho (StgRhsClosure ext ccs update_flag args expr)
= do (rho', args1) <- unariseFunArgBinders rho args
expr' <- unariseExpr rho' expr
- let fvs' = unariseFreeVars rho fvs
- return (StgRhsClosure ccs fvs' update_flag args1 expr')
+ return (StgRhsClosure ext ccs update_flag args1 expr')
unariseRhs rho (StgRhsCon ccs con args)
= ASSERT(not (isUnboxedTupleCon con || isUnboxedSumCon con))
@@ -723,24 +722,6 @@ unariseConArgBinders rho xs = second concat <$> mapAccumLM unariseConArgBinder r
unariseConArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
unariseConArgBinder = unariseArgBinder True
-unariseFreeVars :: UnariseEnv -> [InId] -> [OutId]
-unariseFreeVars rho fvs
- = [ v | fv <- fvs, StgVarArg v <- unariseFreeVar rho fv ]
- -- Notice that we filter out any StgLitArgs
- -- e.g. case e of (x :: (# Int | Bool #))
- -- (# v | #) -> ... let {g = \y. ..x...} in ...
- -- (# | w #) -> ...
- -- Here 'x' is free in g's closure, and the env will have
- -- x :-> [1, v]
- -- we want to capture 'v', but not 1, in the free vars
-
-unariseFreeVar :: UnariseEnv -> Id -> [StgArg]
-unariseFreeVar rho x =
- case lookupVarEnv rho x of
- Just (MultiVal args) -> args
- Just (UnaryVal arg) -> [arg]
- Nothing -> [StgVarArg x]
-
--------------------------------------------------------------------------------
mkIds :: FastString -> [UnaryType] -> UniqSM [Id]
diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs
index 12940753f9..1b1d4639f2 100644
--- a/compiler/stgSyn/CoreToStg.hs
+++ b/compiler/stgSyn/CoreToStg.hs
@@ -46,11 +46,10 @@ import DynFlags
import ForeignCall
import Demand ( isUsedOnce )
import PrimOp ( PrimCall(..) )
-import UniqFM
import SrcLoc ( mkGeneralSrcSpan )
import Data.List.NonEmpty (nonEmpty, toList)
-import Data.Maybe (isJust, fromMaybe)
+import Data.Maybe (fromMaybe)
import Control.Monad (liftM, ap)
-- Note [Live vs free]
@@ -208,7 +207,7 @@ coreToStg :: DynFlags -> Module -> CoreProgram
coreToStg dflags this_mod pgm
= (pgm', final_ccs)
where
- (_, _, (local_ccs, local_cc_stacks), pgm')
+ (_, (local_ccs, local_cc_stacks), pgm')
= coreTopBindsToStg dflags this_mod emptyVarEnv emptyCollectedCCs pgm
prof = WayProf `elem` ways dflags
@@ -229,45 +228,41 @@ coreTopBindsToStg
-> IdEnv HowBound -- environment for the bindings
-> CollectedCCs
-> CoreProgram
- -> (IdEnv HowBound, FreeVarsInfo, CollectedCCs, [StgTopBinding])
+ -> (IdEnv HowBound, CollectedCCs, [StgTopBinding])
coreTopBindsToStg _ _ env ccs []
- = (env, emptyFVInfo, ccs, [])
+ = (env, ccs, [])
coreTopBindsToStg dflags this_mod env ccs (b:bs)
- = (env2, fvs2, ccs2, b':bs')
+ = (env2, ccs2, b':bs')
where
- -- Notice the mutually-recursive "knot" here:
- -- env accumulates down the list of binds,
- -- fvs accumulates upwards
- (env1, fvs2, ccs1, b' ) =
- coreTopBindToStg dflags this_mod env fvs1 ccs b
- (env2, fvs1, ccs2, bs') =
+ (env1, ccs1, b' ) =
+ coreTopBindToStg dflags this_mod env ccs b
+ (env2, ccs2, bs') =
coreTopBindsToStg dflags this_mod env1 ccs1 bs
coreTopBindToStg
:: DynFlags
-> Module
-> IdEnv HowBound
- -> FreeVarsInfo -- Info about the body
-> CollectedCCs
-> CoreBind
- -> (IdEnv HowBound, FreeVarsInfo, CollectedCCs, StgTopBinding)
+ -> (IdEnv HowBound, CollectedCCs, StgTopBinding)
-coreTopBindToStg _ _ env body_fvs ccs (NonRec id e)
+coreTopBindToStg _ _ env ccs (NonRec id e)
| Just str <- exprIsTickedString_maybe e
-- top-level string literal
-- See Note [CoreSyn top-level string literals] in CoreSyn
= let
env' = extendVarEnv env id how_bound
how_bound = LetBound TopLet 0
- in (env', body_fvs, ccs, StgTopStringLit id str)
+ in (env', ccs, StgTopStringLit id str)
-coreTopBindToStg dflags this_mod env body_fvs ccs (NonRec id rhs)
+coreTopBindToStg dflags this_mod env ccs (NonRec id rhs)
= let
env' = extendVarEnv env id how_bound
how_bound = LetBound TopLet $! manifestArity rhs
- (stg_rhs, fvs', ccs') =
+ (stg_rhs, ccs') =
initCts env $
coreToTopStgRhs dflags ccs this_mod (id,rhs)
@@ -278,9 +273,9 @@ coreTopBindToStg dflags this_mod env body_fvs ccs (NonRec id rhs)
-- as well as 'id', but that led to a black hole
-- where printing the assertion error tripped the
-- assertion again!
- (env', fvs' `unionFVInfo` body_fvs, ccs', bind)
+ (env', ccs', bind)
-coreTopBindToStg dflags this_mod env body_fvs ccs (Rec pairs)
+coreTopBindToStg dflags this_mod env ccs (Rec pairs)
= ASSERT( not (null pairs) )
let
binders = map fst pairs
@@ -289,28 +284,27 @@ coreTopBindToStg dflags this_mod env body_fvs ccs (Rec pairs)
| (b, rhs) <- pairs ]
env' = extendVarEnvList env extra_env'
- -- generate StgTopBindings, accumulate body_fvs and CAF cost centres
- -- created for CAFs
- ((fvs', ccs'), stg_rhss)
+ -- generate StgTopBindings and CAF cost centres created for CAFs
+ (ccs', stg_rhss)
= initCts env' $ do
- mapAccumLM (\(fvs, ccs) rhs -> do
- (rhs', fvs', ccs') <-
+ mapAccumLM (\ccs rhs -> do
+ (rhs', ccs') <-
coreToTopStgRhs dflags ccs this_mod rhs
- return ((fvs' `unionFVInfo` fvs, ccs'), rhs'))
- (body_fvs, ccs)
+ return (ccs', rhs'))
+ ccs
pairs
bind = StgTopLifted $ StgRec (zip binders stg_rhss)
in
ASSERT2(consistentCafInfo (head binders) bind, ppr binders)
- (env', fvs' `unionFVInfo` body_fvs, ccs', bind)
+ (env', ccs', bind)
-- Assertion helper: this checks that the CafInfo on the Id matches
-- what CoreToStg has figured out about the binding's SRT. The
-- CafInfo will be exact in all cases except when CorePrep has
-- floated out a binding, in which case it will be approximate.
-consistentCafInfo :: Id -> GenStgTopBinding Var Id -> Bool
+consistentCafInfo :: Id -> StgTopBinding -> Bool
consistentCafInfo id bind
= WARN( not (exact || is_sat_thing) , ppr id <+> ppr id_marked_caffy <+> ppr binding_is_caffy )
safe
@@ -326,18 +320,17 @@ coreToTopStgRhs
-> CollectedCCs
-> Module
-> (Id,CoreExpr)
- -> CtsM (StgRhs, FreeVarsInfo, CollectedCCs)
+ -> CtsM (StgRhs, CollectedCCs)
coreToTopStgRhs dflags ccs this_mod (bndr, rhs)
- = do { (new_rhs, rhs_fvs) <- coreToStgExpr rhs
+ = do { new_rhs <- coreToStgExpr rhs
; let (stg_rhs, ccs') =
- mkTopStgRhs dflags this_mod ccs rhs_fvs bndr new_rhs
+ mkTopStgRhs dflags this_mod ccs bndr new_rhs
stg_arity =
stgRhsArity stg_rhs
; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs,
- rhs_fvs,
ccs') }
where
-- It's vital that the arity on a top-level Id matches
@@ -365,8 +358,7 @@ coreToTopStgRhs dflags ccs this_mod (bndr, rhs)
coreToStgExpr
:: CoreExpr
- -> CtsM (StgExpr, -- Decorated STG expr
- FreeVarsInfo) -- Its free vars (NB free, not live)
+ -> CtsM StgExpr
-- The second and third components can be derived in a simple bottom up pass, not
-- dependent on any decisions about which variables will be let-no-escaped or
@@ -378,7 +370,7 @@ coreToStgExpr
-- CorePrep should have converted them all to a real core representation.
coreToStgExpr (Lit (LitNumber LitNumInteger _ _)) = panic "coreToStgExpr: LitInteger"
coreToStgExpr (Lit (LitNumber LitNumNatural _ _)) = panic "coreToStgExpr: LitNatural"
-coreToStgExpr (Lit l) = return (StgLit l, emptyFVInfo)
+coreToStgExpr (Lit l) = return (StgLit l)
coreToStgExpr (App (Lit RubbishLit) _some_unlifted_type)
-- We lower 'RubbishLit' to @()@ here, which is much easier than doing it in
-- a STG to Cmm pass.
@@ -397,14 +389,13 @@ coreToStgExpr expr@(Lam _ _)
args' = filterStgBinders args
in
extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $ do
- (body, body_fvs) <- coreToStgExpr body
+ body' <- coreToStgExpr body
let
- fvs = args' `minusFVBinders` body_fvs
result_expr = case nonEmpty args' of
- Nothing -> body
- Just args'' -> StgLam args'' body
+ Nothing -> body'
+ Just args'' -> StgLam args'' body'
- return (result_expr, fvs)
+ return result_expr
coreToStgExpr (Tick tick expr)
= do case tick of
@@ -412,8 +403,8 @@ coreToStgExpr (Tick tick expr)
ProfNote{} -> return ()
SourceNote{} -> return ()
Breakpoint{} -> panic "coreToStgExpr: breakpoint should not happen"
- (expr2, fvs) <- coreToStgExpr expr
- return (StgTick tick expr2, fvs)
+ expr2 <- coreToStgExpr expr
+ return (StgTick tick expr2)
coreToStgExpr (Cast expr _)
= coreToStgExpr expr
@@ -433,31 +424,9 @@ coreToStgExpr (Case scrut _ _ [])
coreToStgExpr (Case scrut bndr _ alts) = do
- (alts2, alts_fvs)
- <- extendVarEnvCts [(bndr, LambdaBound)] $ do
- (alts2, fvs_s) <- mapAndUnzipM vars_alt alts
- return ( alts2,
- unionFVInfos fvs_s )
- let
- -- Determine whether the default binder is dead or not
- -- This helps the code generator to avoid generating an assignment
- -- for the case binder (is extremely rare cases) ToDo: remove.
- bndr' | bndr `elementOfFVInfo` alts_fvs = bndr
- | otherwise = bndr `setIdOccInfo` IAmDead
-
- -- Don't consider the default binder as being 'live in alts',
- -- since this is from the point of view of the case expr, where
- -- the default binder is not free.
- alts_fvs_wo_bndr = bndr `minusFVBinder` alts_fvs
-
- -- We tell the scrutinee that everything
- -- live in the alts is live in it, too.
- (scrut2, scrut_fvs) <- coreToStgExpr scrut
-
- return (
- StgCase scrut2 bndr' (mkStgAltType bndr alts) alts2,
- scrut_fvs `unionFVInfo` alts_fvs_wo_bndr
- )
+ alts2 <- extendVarEnvCts [(bndr, LambdaBound)] (mapM vars_alt alts)
+ scrut2 <- coreToStgExpr scrut
+ return (StgCase scrut2 bndr (mkStgAltType bndr alts) alts2)
where
vars_alt (con, binders, rhs)
| DataAlt c <- con, c == unboxedUnitDataCon
@@ -465,16 +434,15 @@ coreToStgExpr (Case scrut bndr _ alts) = do
-- See Note [Nullary unboxed tuple] in Type.hs
-- where a nullary tuple is mapped to (State# World#)
ASSERT( null binders )
- do { (rhs2, rhs_fvs) <- coreToStgExpr rhs
- ; return ((DEFAULT, [], rhs2), rhs_fvs) }
+ do { rhs2 <- coreToStgExpr rhs
+ ; return (DEFAULT, [], rhs2) }
| otherwise
= let -- Remove type variables
binders' = filterStgBinders binders
in
extendVarEnvCts [(b, LambdaBound) | b <- binders'] $ do
- (rhs2, rhs_fvs) <- coreToStgExpr rhs
- return ( (con, binders', rhs2),
- binders' `minusFVBinders` rhs_fvs )
+ rhs2 <- coreToStgExpr rhs
+ return (con, binders', rhs2)
coreToStgExpr (Let bind body) = do
coreToStgLet bind body
@@ -533,19 +501,15 @@ coreToStgApp
-> Id -- Function
-> [CoreArg] -- Arguments
-> [Tickish Id] -- Debug ticks
- -> CtsM (StgExpr, FreeVarsInfo)
+ -> CtsM StgExpr
coreToStgApp _ f args ticks = do
- (args', args_fvs, ticks') <- coreToStgArgs args
+ (args', ticks') <- coreToStgArgs args
how_bound <- lookupVarCts f
let
n_val_args = valArgCount args
- 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
-- Mostly, the arity info of a function is in the fn's IdInfo
-- But new bindings introduced by CoreSat may not have no
@@ -579,45 +543,39 @@ coreToStgApp _ f args ticks = do
TickBoxOpId {} -> pprPanic "coreToStg TickBox" $ ppr (f,args')
_other -> StgApp f args'
- fvs = fun_fvs `unionFVInfo` args_fvs
tapp = foldr StgTick app (ticks ++ ticks')
-- Forcing these fixes a leak in the code generator, noticed while
-- profiling for trac #4367
- app `seq` fvs `seq` return (
- tapp,
- fvs
- )
+ app `seq` return tapp
-- ---------------------------------------------------------------------------
-- Argument lists
-- This is the guy that turns applications into A-normal form
-- ---------------------------------------------------------------------------
-coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], FreeVarsInfo, [Tickish Id])
+coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [Tickish Id])
coreToStgArgs []
- = return ([], emptyFVInfo, [])
+ = return ([], [])
coreToStgArgs (Type _ : args) = do -- Type argument
- (args', fvs, ts) <- coreToStgArgs args
- return (args', fvs, ts)
+ (args', ts) <- coreToStgArgs args
+ return (args', ts)
coreToStgArgs (Coercion _ : args) -- Coercion argument; replace with place holder
- = do { (args', fvs, ts) <- coreToStgArgs args
- ; return (StgVarArg coercionTokenId : args', fvs, ts) }
+ = do { (args', ts) <- coreToStgArgs args
+ ; return (StgVarArg coercionTokenId : args', ts) }
coreToStgArgs (Tick t e : args)
= ASSERT( not (tickishIsCode t) )
- do { (args', fvs, ts) <- coreToStgArgs (e : args)
- ; return (args', fvs, t:ts) }
+ do { (args', ts) <- coreToStgArgs (e : args)
+ ; return (args', t:ts) }
coreToStgArgs (arg : args) = do -- Non-type argument
- (stg_args, args_fvs, ticks) <- coreToStgArgs args
- (arg', arg_fvs) <- coreToStgExpr arg
+ (stg_args, ticks) <- coreToStgArgs args
+ arg' <- coreToStgExpr arg
let
- fvs = args_fvs `unionFVInfo` arg_fvs
-
(aticks, arg'') = stripStgTicksTop tickishFloatable arg'
stg_arg = case arg'' of
StgApp v [] -> StgVarArg v
@@ -646,7 +604,7 @@ coreToStgArgs (arg : args) = do -- Non-type argument
-- We also want to check if a pointer is cast to a non-ptr etc
WARN( bad_args, text "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" $$ ppr arg )
- return (stg_arg : stg_args, fvs, ticks ++ aticks)
+ return (stg_arg : stg_args, ticks ++ aticks)
-- ---------------------------------------------------------------------------
@@ -654,56 +612,43 @@ coreToStgArgs (arg : args) = do -- Non-type argument
-- ---------------------------------------------------------------------------
coreToStgLet
- :: CoreBind -- bindings
- -> CoreExpr -- body
- -> CtsM (StgExpr, -- new let
- FreeVarsInfo) -- variables free in the whole let
+ :: CoreBind -- bindings
+ -> CoreExpr -- body
+ -> CtsM StgExpr -- new let
coreToStgLet bind body = do
- (bind2, bind_fvs,
- body2, body_fvs)
+ (bind2, body2)
<- do
- ( bind2, bind_fvs, env_ext)
+ ( bind2, env_ext)
<- vars_bind bind
-- Do the body
extendVarEnvCts env_ext $ do
- (body2, body_fvs) <- coreToStgExpr body
+ body2 <- coreToStgExpr body
- return (bind2, bind_fvs,
- body2, body_fvs)
+ return (bind2, body2)
-- Compute the new let-expression
let
new_let | isJoinBind bind = StgLetNoEscape bind2 body2
| otherwise = StgLet bind2 body2
- free_in_whole_let
- = binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs)
-
- return (
- new_let,
- free_in_whole_let
- )
+ return new_let
where
- binders = bindersOf bind
-
mk_binding binder rhs
= (binder, LetBound NestedLet (manifestArity rhs))
vars_bind :: CoreBind
-> CtsM (StgBinding,
- FreeVarsInfo,
[(Id, HowBound)]) -- extension to environment
vars_bind (NonRec binder rhs) = do
- (rhs2, bind_fvs) <- coreToStgRhs (binder,rhs)
+ rhs2 <- coreToStgRhs (binder,rhs)
let
env_ext_item = mk_binding binder rhs
- return (StgNonRec binder rhs2,
- bind_fvs, [env_ext_item])
+ return (StgNonRec binder rhs2, [env_ext_item])
vars_bind (Rec pairs)
= let
@@ -712,32 +657,26 @@ coreToStgLet bind body = do
| (b,rhs) <- pairs ]
in
extendVarEnvCts env_ext $ do
- (rhss2, fvss)
- <- mapAndUnzipM coreToStgRhs pairs
- let
- bind_fvs = unionFVInfos fvss
-
- return (StgRec (binders `zip` rhss2),
- bind_fvs, env_ext)
+ rhss2 <- mapM coreToStgRhs pairs
+ return (StgRec (binders `zip` rhss2), env_ext)
coreToStgRhs :: (Id,CoreExpr)
- -> CtsM (StgRhs, FreeVarsInfo)
+ -> CtsM StgRhs
coreToStgRhs (bndr, rhs) = do
- (new_rhs, rhs_fvs) <- coreToStgExpr rhs
- return (mkStgRhs rhs_fvs bndr new_rhs, rhs_fvs)
+ new_rhs <- coreToStgExpr rhs
+ return (mkStgRhs bndr new_rhs)
-- Generate a top-level RHS. Any new cost centres generated for CAFs will be
-- appended to `CollectedCCs` argument.
mkTopStgRhs :: DynFlags -> Module -> CollectedCCs
- -> FreeVarsInfo -> Id -> StgExpr
- -> (StgRhs, CollectedCCs)
+ -> Id -> StgExpr -> (StgRhs, CollectedCCs)
-mkTopStgRhs dflags this_mod ccs rhs_fvs bndr rhs
+mkTopStgRhs dflags this_mod ccs bndr rhs
| StgLam bndrs body <- rhs
= -- StgLam can't have empty arguments, so not CAF
- ( StgRhsClosure dontCareCCS
- (getFVs rhs_fvs)
+ ( StgRhsClosure noExtSilent
+ dontCareCCS
ReEntrant
(toList bndrs) body
, ccs )
@@ -752,14 +691,14 @@ mkTopStgRhs dflags this_mod ccs rhs_fvs bndr rhs
-- Otherwise it's a CAF, see Note [Cost-centre initialization plan].
| gopt Opt_AutoSccsOnIndividualCafs dflags
- = ( StgRhsClosure caf_ccs
- (getFVs rhs_fvs)
+ = ( StgRhsClosure noExtSilent
+ caf_ccs
upd_flag [] rhs
, collectCC caf_cc caf_ccs ccs )
| otherwise
- = ( StgRhsClosure all_cafs_ccs
- (getFVs rhs_fvs)
+ = ( StgRhsClosure noExtSilent
+ all_cafs_ccs
upd_flag [] rhs
, ccs )
@@ -783,18 +722,18 @@ mkTopStgRhs dflags this_mod ccs rhs_fvs bndr rhs
-- Generate a non-top-level RHS. Cost-centre is always currentCCS,
-- see Note [Cost-centre initialzation plan].
-mkStgRhs :: FreeVarsInfo -> Id -> StgExpr -> StgRhs
-mkStgRhs rhs_fvs bndr rhs
+mkStgRhs :: Id -> StgExpr -> StgRhs
+mkStgRhs bndr rhs
| StgLam bndrs body <- rhs
- = StgRhsClosure currentCCS
- (getFVs rhs_fvs)
+ = StgRhsClosure noExtSilent
+ currentCCS
ReEntrant
(toList bndrs) body
| isJoinId bndr -- must be a nullary join point
= ASSERT(idJoinArity bndr == 0)
- StgRhsClosure currentCCS
- (getFVs rhs_fvs)
+ StgRhsClosure noExtSilent
+ currentCCS
ReEntrant -- ignored for LNE
[] rhs
@@ -802,8 +741,8 @@ mkStgRhs rhs_fvs bndr rhs
= StgRhsCon currentCCS con args
| otherwise
- = StgRhsClosure currentCCS
- (getFVs rhs_fvs)
+ = StgRhsClosure noExtSilent
+ currentCCS
upd_flag [] rhs
where
(_, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs
@@ -891,11 +830,6 @@ data LetInfo
| NestedLet
deriving (Eq)
-topLevelBound :: HowBound -> Bool
-topLevelBound ImportBound = True
-topLevelBound (LetBound TopLet _) = True
-topLevelBound _ = False
-
-- 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)
@@ -961,63 +895,6 @@ getAllCAFsCC this_mod =
in
(all_cafs_cc, all_cafs_ccs)
--- ---------------------------------------------------------------------------
--- Free variable information
--- ---------------------------------------------------------------------------
-
-type FreeVarsInfo = VarEnv (Var, HowBound)
- -- 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
-
-emptyFVInfo :: FreeVarsInfo
-emptyFVInfo = emptyVarEnv
-
-singletonFVInfo :: Id -> HowBound -> FreeVarsInfo
--- Don't record non-CAF imports at all, to keep free-var sets small
-singletonFVInfo id ImportBound
- | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, ImportBound)
- | otherwise = emptyVarEnv
-singletonFVInfo id how_bound = unitVarEnv id (id, how_bound)
-
-unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
-unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
-
-unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
-unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
-
-minusFVBinders :: [Id] -> FreeVarsInfo -> FreeVarsInfo
-minusFVBinders vs fv = foldr minusFVBinder fv vs
-
-minusFVBinder :: Id -> FreeVarsInfo -> FreeVarsInfo
-minusFVBinder v fv = fv `delVarEnv` v
- -- When removing a binder, remember to add its type variables
- -- c.f. CoreFVs.delBinderFV
-
-elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
-elementOfFVInfo id fvs = isJust (lookupVarEnv fvs id)
-
--- Non-top-level things only, both type variables and ids
-getFVs :: FreeVarsInfo -> [Var]
-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)
- -> (Var, HowBound)
- -> (Var, HowBound)
-plusFVInfo (id1,hb1) (id2,hb2)
- = ASSERT(id1 == id2 && hb1 == hb2)
- (id1, hb1)
-
-- Misc.
filterStgBinders :: [Var] -> [Var]
diff --git a/compiler/stgSyn/StgFVs.hs b/compiler/stgSyn/StgFVs.hs
new file mode 100644
index 0000000000..80ce33ff7a
--- /dev/null
+++ b/compiler/stgSyn/StgFVs.hs
@@ -0,0 +1,125 @@
+-- | Free variable analysis on STG terms.
+module StgFVs (
+ annTopBindingsFreeVars
+ ) where
+
+import GhcPrelude
+
+import StgSyn
+import Id
+import VarSet
+import CoreSyn ( Tickish(Breakpoint) )
+import Outputable
+import Util
+
+import Data.Maybe ( mapMaybe )
+
+newtype Env
+ = Env
+ { locals :: IdSet
+ }
+
+emptyEnv :: Env
+emptyEnv = Env emptyVarSet
+
+addLocals :: [Id] -> Env -> Env
+addLocals bndrs env
+ = env { locals = extendVarSetList (locals env) bndrs }
+
+-- | Annotates a top-level STG binding with its free variables.
+annTopBindingsFreeVars :: [StgTopBinding] -> [CgStgTopBinding]
+annTopBindingsFreeVars = map go
+ where
+ go (StgTopStringLit id bs) = StgTopStringLit id bs
+ go (StgTopLifted bind)
+ = StgTopLifted (fst (binding emptyEnv emptyVarSet bind))
+
+boundIds :: StgBinding -> [Id]
+boundIds (StgNonRec b _) = [b]
+boundIds (StgRec pairs) = map fst pairs
+
+-- Note [Tracking local binders]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- 'locals' contains non-toplevel, non-imported binders.
+-- We maintain the set in 'expr', 'alt' and 'rhs', which are the only
+-- places where new local binders are introduced.
+-- Why do it there rather than in 'binding'? Two reasons:
+--
+-- 1. We call 'binding' from 'annTopBindingsFreeVars', which would
+-- add top-level bindings to the 'locals' set.
+-- 2. In the let(-no-escape) case, we need to extend the environment
+-- prior to analysing the body, but we also need the fvs from the
+-- body to analyse the RHSs. No way to do this without some
+-- knot-tying.
+
+-- | This makes sure that only local, non-global free vars make it into the set.
+mkFreeVarSet :: Env -> [Id] -> IdSet
+mkFreeVarSet env = mkVarSet . filter (`elemVarSet` locals env)
+
+args :: Env -> [StgArg] -> IdSet
+args env = mkFreeVarSet env . mapMaybe f
+ where
+ f (StgVarArg occ) = Just occ
+ f _ = Nothing
+
+binding :: Env -> IdSet -> StgBinding -> (CgStgBinding, IdSet)
+binding env body_fv (StgNonRec bndr r) = (StgNonRec bndr r', fvs)
+ where
+ -- See Note [Tacking local binders]
+ (r', rhs_fvs) = rhs env r
+ fvs = delVarSet body_fv bndr `unionVarSet` rhs_fvs
+binding env body_fv (StgRec pairs) = (StgRec pairs', fvs)
+ where
+ -- See Note [Tacking local binders]
+ bndrs = map fst pairs
+ (rhss, rhs_fvss) = mapAndUnzip (rhs env . snd) pairs
+ pairs' = zip bndrs rhss
+ fvs = delVarSetList (unionVarSets (body_fv:rhs_fvss)) bndrs
+
+expr :: Env -> StgExpr -> (CgStgExpr, IdSet)
+expr env = go
+ where
+ go (StgApp occ as)
+ = (StgApp occ as, unionVarSet (args env as) (mkFreeVarSet env [occ]))
+ go (StgLit lit) = (StgLit lit, emptyVarSet)
+ go (StgConApp dc as tys) = (StgConApp dc as tys, args env as)
+ go (StgOpApp op as ty) = (StgOpApp op as ty, args env as)
+ go StgLam{} = pprPanic "StgFVs: StgLam" empty
+ go (StgCase scrut bndr ty alts) = (StgCase scrut' bndr ty alts', fvs)
+ where
+ (scrut', scrut_fvs) = go scrut
+ -- See Note [Tacking local binders]
+ (alts', alt_fvss) = mapAndUnzip (alt (addLocals [bndr] env)) alts
+ alt_fvs = unionVarSets alt_fvss
+ fvs = delVarSet (unionVarSet scrut_fvs alt_fvs) bndr
+ go (StgLet bind body) = go_bind StgLet bind body
+ go (StgLetNoEscape bind body) = go_bind StgLetNoEscape bind body
+ go (StgTick tick e) = (StgTick tick e', fvs')
+ where
+ (e', fvs) = go e
+ fvs' = unionVarSet (tickish tick) fvs
+ tickish (Breakpoint _ ids) = mkVarSet ids
+ tickish _ = emptyVarSet
+
+ go_bind dc bind body = (dc bind' body', fvs)
+ where
+ -- See Note [Tacking local binders]
+ env' = addLocals (boundIds bind) env
+ (body', body_fvs) = expr env' body
+ (bind', fvs) = binding env' body_fvs bind
+
+rhs :: Env -> StgRhs -> (CgStgRhs, IdSet)
+rhs env (StgRhsClosure _ ccs uf bndrs body)
+ = (StgRhsClosure fvs ccs uf bndrs body', fvs)
+ where
+ -- See Note [Tacking local binders]
+ (body', body_fvs) = expr (addLocals bndrs env) body
+ fvs = delVarSetList body_fvs bndrs
+rhs env (StgRhsCon ccs dc as) = (StgRhsCon ccs dc as, args env as)
+
+alt :: Env -> StgAlt -> (CgStgAlt, IdSet)
+alt env (con, bndrs, e) = ((con, bndrs, e'), fvs)
+ where
+ -- See Note [Tacking local binders]
+ (e', rhs_fvs) = expr (addLocals bndrs env) e
+ fvs = delVarSetList rhs_fvs bndrs
diff --git a/compiler/stgSyn/StgSyn.hs b/compiler/stgSyn/StgSyn.hs
index 7d347f4865..145c001046 100644
--- a/compiler/stgSyn/StgSyn.hs
+++ b/compiler/stgSyn/StgSyn.hs
@@ -10,19 +10,29 @@ generation.
-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
module StgSyn (
- GenStgArg(..),
+ StgArg(..),
GenStgTopBinding(..), GenStgBinding(..), GenStgExpr(..), GenStgRhs(..),
GenStgAlt, AltType(..),
+ StgPass(..), XRhsClosure, NoExtSilent, noExtSilent,
+
UpdateFlag(..), isUpdatable,
- -- a set of synonyms for the most common (only :-) parameterisation
- StgArg,
+ -- a set of synonyms for the vanilla parameterisation
StgTopBinding, StgBinding, StgExpr, StgRhs, StgAlt,
+ -- a set of synonyms for the code gen parameterisation
+ CgStgTopBinding, CgStgBinding, CgStgExpr, CgStgRhs, CgStgAlt,
+
-- a set of synonyms to distinguish in- and out variants
InStgArg, InStgTopBinding, InStgBinding, InStgExpr, InStgRhs, InStgAlt,
OutStgArg, OutStgTopBinding, OutStgBinding, OutStgExpr, OutStgRhs, OutStgAlt,
@@ -47,6 +57,7 @@ import GhcPrelude
import CoreSyn ( AltCon, Tickish )
import CostCentre ( CostCentreStack )
import Data.ByteString ( ByteString )
+import Data.Data ( Data )
import Data.List ( intersperse )
import DataCon
import DynFlags
@@ -54,6 +65,7 @@ import FastString
import ForeignCall ( ForeignCall )
import Id
import IdInfo ( mayHaveCafRefs )
+import VarSet
import Literal ( Literal, literalType )
import Module ( Module )
import Outputable
@@ -83,25 +95,25 @@ with respect to binder and occurrence information (just as in
-}
-- | A top-level binding.
-data GenStgTopBinding bndr occ
+data GenStgTopBinding pass
-- See Note [CoreSyn top-level string literals]
- = StgTopLifted (GenStgBinding bndr occ)
- | StgTopStringLit bndr ByteString
+ = StgTopLifted (GenStgBinding pass)
+ | StgTopStringLit Id ByteString
-data GenStgBinding bndr occ
- = StgNonRec bndr (GenStgRhs bndr occ)
- | StgRec [(bndr, GenStgRhs bndr occ)]
+data GenStgBinding pass
+ = StgNonRec Id (GenStgRhs pass)
+ | StgRec [(Id, GenStgRhs pass)]
{-
************************************************************************
* *
-\subsection{@GenStgArg@}
+\subsection{@StgArg@}
* *
************************************************************************
-}
-data GenStgArg occ
- = StgVarArg occ
+data StgArg
+ = StgVarArg Id
| StgLitArg Literal
-- | Does this constructor application refer to
@@ -147,7 +159,7 @@ stgArgType (StgLitArg lit) = literalType lit
-- | Strip ticks of a given type from an STG expression
-stripStgTicksTop :: (Tickish Id -> Bool) -> StgExpr -> ([Tickish Id], StgExpr)
+stripStgTicksTop :: (Tickish Id -> Bool) -> GenStgExpr p -> ([Tickish Id], GenStgExpr p)
stripStgTicksTop p = go []
where go ts (StgTick t e) | p t = go (t:ts) e
go ts other = (reverse ts, other)
@@ -190,10 +202,10 @@ There is no constructor for a lone variable; it would appear as
@StgApp var []@.
-}
-data GenStgExpr bndr occ
+data GenStgExpr pass
= StgApp
- occ -- function
- [GenStgArg occ] -- arguments; may be empty
+ Id -- function
+ [StgArg] -- arguments; may be empty
{-
************************************************************************
@@ -211,14 +223,14 @@ primitives, and literals.
-- StgConApp is vital for returning unboxed tuples or sums
-- which can't be let-bound first
| StgConApp DataCon
- [GenStgArg occ] -- Saturated
- [Type] -- See Note [Types in StgConApp] in UnariseStg
+ [StgArg] -- Saturated
+ [Type] -- See Note [Types in StgConApp] in UnariseStg
- | StgOpApp StgOp -- Primitive op or foreign call
- [GenStgArg occ] -- Saturated.
- Type -- Result type
- -- We need to know this so that we can
- -- assign result registers
+ | StgOpApp StgOp -- Primitive op or foreign call
+ [StgArg] -- Saturated.
+ Type -- Result type
+ -- We need to know this so that we can
+ -- assign result registers
{-
************************************************************************
@@ -229,10 +241,11 @@ primitives, and literals.
StgLam is used *only* during CoreToStg's work. Before CoreToStg has
finished it encodes (\x -> e) as (let f = \x -> e in f)
+TODO: Encode this via an extension to GenStgExpr à la TTG.
-}
| StgLam
- (NonEmpty bndr)
+ (NonEmpty Id)
StgExpr -- Body of lambda
{-
@@ -246,14 +259,14 @@ This has the same boxed/unboxed business as Core case expressions.
-}
| StgCase
- (GenStgExpr bndr occ)
+ (GenStgExpr pass)
-- the thing to examine
- bndr -- binds the result of evaluating the scrutinee
+ Id -- binds the result of evaluating the scrutinee
AltType
- [GenStgAlt bndr occ]
+ [GenStgAlt pass]
-- The DEFAULT case is always *first*
-- if it is there at all
@@ -352,12 +365,12 @@ And so the code for let(rec)-things:
-}
| StgLet
- (GenStgBinding bndr occ) -- right hand sides (see below)
- (GenStgExpr bndr occ) -- body
+ (GenStgBinding pass) -- right hand sides (see below)
+ (GenStgExpr pass) -- body
| StgLetNoEscape
- (GenStgBinding bndr occ) -- right hand sides (see below)
- (GenStgExpr bndr occ) -- body
+ (GenStgBinding pass) -- right hand sides (see below)
+ (GenStgExpr pass) -- body
{-
%************************************************************************
@@ -370,8 +383,8 @@ Finally for @hpc@ expressions we introduce a new STG construct.
-}
| StgTick
- (Tickish bndr)
- (GenStgExpr bndr occ) -- sub expression
+ (Tickish Id)
+ (GenStgExpr pass) -- sub expression
-- END of GenStgExpr
@@ -386,15 +399,15 @@ Here's the rest of the interesting stuff for @StgLet@s; the first
flavour is for closures:
-}
-data GenStgRhs bndr occ
+data GenStgRhs pass
= StgRhsClosure
- CostCentreStack -- CCS to be attached (default is CurrentCCS)
- [occ] -- non-global free vars; a list, rather than
- -- a set, because order is important
- !UpdateFlag -- ReEntrant | Updatable | SingleEntry
- [bndr] -- arguments; if empty, then not a function;
- -- as above, order is important.
- (GenStgExpr bndr occ) -- body
+ (XRhsClosure pass) -- ^ Extension point for non-global free var
+ -- list just before 'CodeGen'.
+ CostCentreStack -- ^ CCS to be attached (default is CurrentCCS)
+ !UpdateFlag -- ^ 'ReEntrant' | 'Updatable' | 'SingleEntry'
+ [Id] -- ^ arguments; if empty, then not a function;
+ -- as above, order is important.
+ (GenStgExpr pass) -- ^ body
{-
An example may be in order. Consider:
@@ -413,14 +426,38 @@ The second flavour of right-hand-side is for constructors (simple but important)
-}
| StgRhsCon
- CostCentreStack -- CCS to be attached (default is CurrentCCS).
- -- Top-level (static) ones will end up with
- -- DontCareCCS, because we don't count static
- -- data in heap profiles, and we don't set CCCS
- -- from static closure.
- DataCon -- Constructor. Never an unboxed tuple or sum, as those
- -- are not allocated.
- [GenStgArg occ] -- Args
+ CostCentreStack -- CCS to be attached (default is CurrentCCS).
+ -- Top-level (static) ones will end up with
+ -- DontCareCCS, because we don't count static
+ -- data in heap profiles, and we don't set CCCS
+ -- from static closure.
+ DataCon -- Constructor. Never an unboxed tuple or sum, as those
+ -- are not allocated.
+ [StgArg] -- Args
+
+-- | Used as a data type index for the stgSyn AST
+data StgPass
+ = CodeGen
+ | Vanilla
+
+-- | Like 'HsExpression.NoExt', but with an 'Outputable' instance that returns
+-- 'empty'.
+data NoExtSilent = NoExtSilent
+ deriving (Data, Eq, Ord)
+
+instance Outputable NoExtSilent where
+ ppr _ = empty
+
+-- | Used when constructing a term with an unused extension point that should
+-- not appear in pretty-printed output at all.
+noExtSilent :: NoExtSilent
+noExtSilent = NoExtSilent
+-- TODO: Maybe move this to HsExtensions? I'm not sure about the implications
+-- on build time...
+
+type family XRhsClosure (pass :: StgPass) where
+ XRhsClosure 'CodeGen = IdSet -- code gen needs to track non-global free vars
+ XRhsClosure 'Vanilla = NoExtSilent
stgRhsArity :: StgRhs -> Int
stgRhsArity (StgRhsClosure _ _ _ bndrs _)
@@ -441,7 +478,7 @@ stgRhsArity (StgRhsCon _ _ _) = 0
-- is that `TidyPgm` computed the CAF info on the `Id` but some transformations
-- have taken place since then.
-topStgBindHasCafRefs :: GenStgTopBinding bndr Id -> Bool
+topStgBindHasCafRefs :: GenStgTopBinding pass -> Bool
topStgBindHasCafRefs (StgTopLifted (StgNonRec _ rhs))
= topRhsHasCafRefs rhs
topStgBindHasCafRefs (StgTopLifted (StgRec binds))
@@ -449,14 +486,14 @@ topStgBindHasCafRefs (StgTopLifted (StgRec binds))
topStgBindHasCafRefs StgTopStringLit{}
= False
-topRhsHasCafRefs :: GenStgRhs bndr Id -> Bool
+topRhsHasCafRefs :: GenStgRhs pass -> 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 :: GenStgExpr pass -> Bool
exprHasCafRefs (StgApp f args)
= stgIdHasCafRefs f || any stgArgHasCafRefs args
exprHasCafRefs StgLit{}
@@ -476,22 +513,22 @@ exprHasCafRefs (StgLetNoEscape bind body)
exprHasCafRefs (StgTick _ expr)
= exprHasCafRefs expr
-bindHasCafRefs :: GenStgBinding bndr Id -> Bool
+bindHasCafRefs :: GenStgBinding pass -> Bool
bindHasCafRefs (StgNonRec _ rhs)
= rhsHasCafRefs rhs
bindHasCafRefs (StgRec binds)
= any rhsHasCafRefs (map snd binds)
-rhsHasCafRefs :: GenStgRhs bndr Id -> Bool
+rhsHasCafRefs :: GenStgRhs pass -> Bool
rhsHasCafRefs (StgRhsClosure _ _ _ _ body)
= exprHasCafRefs body
rhsHasCafRefs (StgRhsCon _ _ args)
= any stgArgHasCafRefs args
-altHasCafRefs :: GenStgAlt bndr Id -> Bool
+altHasCafRefs :: GenStgAlt pass -> Bool
altHasCafRefs (_, _, rhs) = exprHasCafRefs rhs
-stgArgHasCafRefs :: GenStgArg Id -> Bool
+stgArgHasCafRefs :: StgArg -> Bool
stgArgHasCafRefs (StgVarArg id)
= stgIdHasCafRefs id
stgArgHasCafRefs _
@@ -523,10 +560,10 @@ constructors or literals (which are guaranteed to have the Real McCoy)
rather than from the scrutinee type.
-}
-type GenStgAlt bndr occ
- = (AltCon, -- alts: data constructor,
- [bndr], -- constructor's parameters,
- GenStgExpr bndr occ) -- ...right-hand side.
+type GenStgAlt pass
+ = (AltCon, -- alts: data constructor,
+ [Id], -- constructor's parameters,
+ GenStgExpr pass) -- ...right-hand side.
data AltType
= PolyAlt -- Polymorphic (a lifted type variable)
@@ -546,12 +583,17 @@ data AltType
This happens to be the only one we use at the moment.
-}
-type StgTopBinding = GenStgTopBinding Id Id
-type StgBinding = GenStgBinding Id Id
-type StgArg = GenStgArg Id
-type StgExpr = GenStgExpr Id Id
-type StgRhs = GenStgRhs Id Id
-type StgAlt = GenStgAlt Id Id
+type StgTopBinding = GenStgTopBinding 'Vanilla
+type StgBinding = GenStgBinding 'Vanilla
+type StgExpr = GenStgExpr 'Vanilla
+type StgRhs = GenStgRhs 'Vanilla
+type StgAlt = GenStgAlt 'Vanilla
+
+type CgStgTopBinding = GenStgTopBinding 'CodeGen
+type CgStgBinding = GenStgBinding 'CodeGen
+type CgStgExpr = GenStgExpr 'CodeGen
+type CgStgRhs = GenStgRhs 'CodeGen
+type CgStgAlt = GenStgAlt 'CodeGen
{- Many passes apply a substitution, and it's very handy to have type
synonyms to remind us whether or not the substitution has been applied.
@@ -634,17 +676,16 @@ Robin Popplestone asked for semi-colon separators on STG binds; here's
hoping he likes terminators instead... Ditto for case alternatives.
-}
-pprGenStgTopBinding :: (OutputableBndr bndr, Outputable bdee, Ord bdee)
- => GenStgTopBinding bndr bdee -> SDoc
-
+pprGenStgTopBinding
+ :: Outputable (XRhsClosure pass) => GenStgTopBinding pass -> SDoc
pprGenStgTopBinding (StgTopStringLit bndr str)
= hang (hsep [pprBndr LetBind bndr, equals])
4 (pprHsBytes str <> semi)
pprGenStgTopBinding (StgTopLifted bind)
= pprGenStgBinding bind
-pprGenStgBinding :: (OutputableBndr bndr, Outputable bdee, Ord bdee)
- => GenStgBinding bndr bdee -> SDoc
+pprGenStgBinding
+ :: (Outputable (XRhsClosure pass)) => GenStgBinding pass -> SDoc
pprGenStgBinding (StgNonRec bndr rhs)
= hang (hsep [pprBndr LetBind bndr, equals])
@@ -665,31 +706,30 @@ pprStgTopBindings :: [StgTopBinding] -> SDoc
pprStgTopBindings binds
= vcat $ intersperse blankLine (map pprGenStgTopBinding binds)
-instance (Outputable bdee) => Outputable (GenStgArg bdee) where
+instance Outputable StgArg where
ppr = pprStgArg
-instance (OutputableBndr bndr, Outputable bdee, Ord bdee)
- => Outputable (GenStgTopBinding bndr bdee) where
+instance (Outputable (XRhsClosure pass))
+ => Outputable (GenStgTopBinding pass) where
ppr = pprGenStgTopBinding
-instance (OutputableBndr bndr, Outputable bdee, Ord bdee)
- => Outputable (GenStgBinding bndr bdee) where
+instance (Outputable (XRhsClosure pass))
+ => Outputable (GenStgBinding pass) where
ppr = pprGenStgBinding
-instance (OutputableBndr bndr, Outputable bdee, Ord bdee)
- => Outputable (GenStgExpr bndr bdee) where
+instance (Outputable (XRhsClosure pass))
+ => Outputable (GenStgExpr pass) where
ppr = pprStgExpr
-instance (OutputableBndr bndr, Outputable bdee, Ord bdee)
- => Outputable (GenStgRhs bndr bdee) where
+instance (Outputable (XRhsClosure pass))
+ => Outputable (GenStgRhs pass) where
ppr rhs = pprStgRhs rhs
-pprStgArg :: (Outputable bdee) => GenStgArg bdee -> SDoc
+pprStgArg :: StgArg -> SDoc
pprStgArg (StgVarArg var) = ppr var
pprStgArg (StgLitArg con) = ppr con
-pprStgExpr :: (OutputableBndr bndr, Outputable bdee, Ord bdee)
- => GenStgExpr bndr bdee -> SDoc
+pprStgExpr :: (Outputable (XRhsClosure pass)) => GenStgExpr pass -> SDoc
-- special case
pprStgExpr (StgLit lit) = ppr lit
@@ -765,8 +805,7 @@ pprStgExpr (StgCase expr bndr alt_type alts)
nest 2 (vcat (map pprStgAlt alts)),
char '}']
-pprStgAlt :: (OutputableBndr bndr, Outputable occ, Ord occ)
- => GenStgAlt bndr occ -> SDoc
+pprStgAlt :: (Outputable (XRhsClosure pass)) => GenStgAlt pass -> SDoc
pprStgAlt (con, params, expr)
= hang (hsep [ppr con, sep (map (pprBndr CasePatBind) params), text "->"])
4 (ppr expr <> semi)
@@ -782,23 +821,22 @@ instance Outputable AltType where
ppr (AlgAlt tc) = text "Alg" <+> ppr tc
ppr (PrimAlt tc) = text "Prim" <+> ppr tc
-pprStgRhs :: (OutputableBndr bndr, Outputable bdee, Ord bdee)
- => GenStgRhs bndr bdee -> SDoc
+pprStgRhs :: (Outputable (XRhsClosure pass)) => GenStgRhs pass -> SDoc
-- special case
-pprStgRhs (StgRhsClosure cc [free_var] upd_flag [{-no args-}] (StgApp func []))
+pprStgRhs (StgRhsClosure ext cc upd_flag [{-no args-}] (StgApp func []))
= sdocWithDynFlags $ \dflags ->
hsep [ ppr cc,
- if not $ gopt Opt_SuppressStgFreeVars dflags
- then brackets (ppr free_var) else empty,
+ if not $ gopt Opt_SuppressStgExts dflags
+ then ppr ext else empty,
text " \\", ppr upd_flag, ptext (sLit " [] "), ppr func ]
-- general case
-pprStgRhs (StgRhsClosure cc free_vars upd_flag args body)
+pprStgRhs (StgRhsClosure ext cc upd_flag args body)
= sdocWithDynFlags $ \dflags ->
hang (hsep [if gopt Opt_SccProfilingOn dflags then ppr cc else empty,
- if not $ gopt Opt_SuppressStgFreeVars dflags
- then brackets (interppSP free_vars) else empty,
+ if not $ gopt Opt_SuppressStgExts dflags
+ then ppr ext else empty,
char '\\' <> ppr upd_flag, brackets (interppSP args)])
4 (ppr body)
diff --git a/compiler/utils/UniqDSet.hs b/compiler/utils/UniqDSet.hs
index 92d924ee37..c2ace5787f 100644
--- a/compiler/utils/UniqDSet.hs
+++ b/compiler/utils/UniqDSet.hs
@@ -33,7 +33,8 @@ module UniqDSet (
isEmptyUniqDSet,
lookupUniqDSet,
uniqDSetToList,
- partitionUniqDSet
+ partitionUniqDSet,
+ mapUniqDSet
) where
import GhcPrelude
@@ -121,6 +122,10 @@ uniqDSetToList = eltsUDFM . getUniqDSet
partitionUniqDSet :: (a -> Bool) -> UniqDSet a -> (UniqDSet a, UniqDSet a)
partitionUniqDSet p = coerce . partitionUDFM p . getUniqDSet
+-- See Note [UniqSet invariant] in UniqSet.hs
+mapUniqDSet :: Uniquable b => (a -> b) -> UniqDSet a -> UniqDSet b
+mapUniqDSet f = mkUniqDSet . map f . uniqDSetToList
+
-- Two 'UniqDSet's are considered equal if they contain the same
-- uniques.
instance Eq (UniqDSet a) where
diff --git a/testsuite/tests/simplCore/should_compile/noinline01.stderr b/testsuite/tests/simplCore/should_compile/noinline01.stderr
index ce01fcc863..21c94d0eb3 100644
--- a/testsuite/tests/simplCore/should_compile/noinline01.stderr
+++ b/testsuite/tests/simplCore/should_compile/noinline01.stderr
@@ -3,11 +3,11 @@
Noinline01.f [InlPrag=INLINE (sat-args=1)]
:: forall p. p -> GHC.Types.Bool
[GblId, Arity=1, Caf=NoCafRefs, Str=<L,A>, Unf=OtherCon []] =
- [] \r [eta] GHC.Types.True [];
+ \r [eta] GHC.Types.True [];
Noinline01.g :: GHC.Types.Bool
[GblId] =
- [] \u [] Noinline01.f GHC.Types.False;
+ \u [] Noinline01.f GHC.Types.False;
Noinline01.$trModule4 :: GHC.Prim.Addr#
[GblId, Caf=NoCafRefs, Unf=OtherCon []] =
@@ -36,11 +36,11 @@ Noinline01.$trModule :: GHC.Types.Module
Noinline01.f [InlPrag=INLINE (sat-args=1)]
:: forall p. p -> GHC.Types.Bool
[GblId, Arity=1, Caf=NoCafRefs, Str=<L,A>, Unf=OtherCon []] =
- [] \r [eta] GHC.Types.True [];
+ \r [eta] GHC.Types.True [];
Noinline01.g :: GHC.Types.Bool
[GblId] =
- [] \u [] Noinline01.f GHC.Types.False;
+ \u [] Noinline01.f GHC.Types.False;
Noinline01.$trModule4 :: GHC.Prim.Addr#
[GblId, Caf=NoCafRefs, Unf=OtherCon []] =
View Lorry Controller Status