Commit 47bbc709 authored by Sebastian Graf's avatar Sebastian Graf

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
parent cc615c69
......@@ -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
......
{-# 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
......
......@@ -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)
......
module StgCmmBind where
import StgCmmMonad( FCode )
import StgSyn( StgBinding )
import StgSyn( CgStgBinding )
cgBind :: StgBinding -> FCode ()
cgBind :: CgStgBinding -> FCode ()
......@@ -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 $
......
......@@ -441,6 +441,7 @@ Library
CoreToStg
StgLint
StgSyn
StgFVs
CallArity
DmdAnal
Exitify
......
......@@ -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,
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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]
......
This diff is collapsed.
-- | 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
This diff is collapsed.
......@@ -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
......
......@@ -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 []] =
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment