{-# LANGUAGE TypeFamilies #-}

{- |
Non-global free variable analysis on STG terms. This pass annotates
non-top-level closure bindings with captured variables. Global variables are not
captured. For example, in a top-level binding like (pseudo-STG)

    f = \[x,y] .
      let g = \[p] . reverse (x ++ p)
      in g y

In g, `reverse` and `(++)` are global variables so they're not considered free.
`p` is an argument, so `x` is the only actual free variable here. The annotated
version is thus:

    f = \[x,y] .
      let g = [x] \[p] . reverse (x ++ p)
      in g y

Note that non-top-level recursive bindings are also considered free within the
group:

    map = {} \r [f xs0]
      let {
        Rec {
          go = {f, go} \r [xs1]
            case xs1 of {
              [] -> [] [];
              : x xs2 ->
                  let { xs' = {go, xs2} \u [] go xs2; } in
                  let { x' = {f, x} \u [] f x; } in
                  : [x' xs'];
            };
        end Rec }
      } in go xs0;

Here go is free in its RHS.

Top-level closure bindings never capture variables as all of their free
variables are global.
-}
module GHC.Stg.FVs (
    depSortWithAnnotStgPgm,
    annBindingFreeVars
  ) where

import GHC.Prelude hiding (mod)

import GHC.Stg.Syntax
import GHC.Stg.Utils (bindersOf)
import GHC.Types.Id
import GHC.Types.Name (Name, nameIsLocalOrFrom)
import GHC.Types.Tickish ( GenTickish(Breakpoint) )
import GHC.Types.Unique.Set (nonDetEltsUniqSet)
import GHC.Types.Var.Set
import GHC.Unit.Module (Module)
import GHC.Utils.Misc

import Data.Graph (SCC (..))
import GHC.Data.Graph.Directed( Node(..), stronglyConnCompFromEdgedVerticesUniq )

{- Note [Why do we need dependency analysis?]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The program needs to be in dependency order for the SRT algorithm to
work (see CmmBuildInfoTables, which also includes a detailed
description of the algorithm).

But isn't it in correct dependency order already?  No:

* The simplifier does not guarantee to produce programs in dependency
  order (see #16192 and Note [Glomming] in GHC.Core.Opt.OccurAnal).
  This could be solved by a final run of the occurrence analyser, but
  that's more work

* We also don't guarantee that StgLiftLams will preserve the order or
  only create minimal recursive groups.
-}

--------------------------------------------------------------------------------
-- | Dependency sort a STG program, and annotate it with free variables
-- The returned bindings:
--   * Are in dependency order
--   * Each StgRhsClosure is correctly annotated (in its extension field)
--     with the free variables needed in the closure
--   * Each StgCase is correctly annotated (in its extension field) with
--     the variables that must be saved across the case
depSortWithAnnotStgPgm :: Module -> [StgTopBinding] -> [CgStgTopBinding]
depSortWithAnnotStgPgm :: Module -> [StgTopBinding] -> [CgStgTopBinding]
depSortWithAnnotStgPgm Module
this_mod [StgTopBinding]
binds
  = {-# SCC "STG.depSortWithAnnotStgPgm" #-}
    [CgStgTopBinding]
lit_binds [CgStgTopBinding] -> [CgStgTopBinding] -> [CgStgTopBinding]
forall a. [a] -> [a] -> [a]
++ (SCC (Id, CgStgRhs) -> CgStgTopBinding)
-> [SCC (Id, CgStgRhs)] -> [CgStgTopBinding]
forall a b. (a -> b) -> [a] -> [b]
map SCC (Id, CgStgRhs) -> CgStgTopBinding
SCC (BinderP 'CodeGen, CgStgRhs) -> CgStgTopBinding
forall {pass :: StgPass}.
SCC (BinderP pass, GenStgRhs pass) -> GenStgTopBinding pass
from_scc [SCC (Id, CgStgRhs)]
sccs
  where
    lit_binds :: [CgStgTopBinding]
    pairs     :: [(Id, StgRhs)]
    ([CgStgTopBinding]
lit_binds, [(Id, StgRhs)]
pairs) = [StgTopBinding] -> ([CgStgTopBinding], [(Id, StgRhs)])
flattenTopStgBindings [StgTopBinding]
binds

    nodes :: [Node Name (Id, CgStgRhs)]
    nodes :: [Node Name (Id, CgStgRhs)]
nodes = ((Id, StgRhs) -> Node Name (Id, CgStgRhs))
-> [(Id, StgRhs)] -> [Node Name (Id, CgStgRhs)]
forall a b. (a -> b) -> [a] -> [b]
map (Env -> (Id, StgRhs) -> Node Name (Id, CgStgRhs)
annotateTopPair Env
env0) [(Id, StgRhs)]
pairs
    env0 :: Env
env0 = Env { locals :: IdSet
locals = IdSet
emptyVarSet, mod :: Module
mod = Module
this_mod }

    -- Do strongly connected component analysis.  Why?
    -- See Note [Why do we need dependency analysis?]
    sccs :: [SCC (Id,CgStgRhs)]
    sccs :: [SCC (Id, CgStgRhs)]
sccs  = [Node Name (Id, CgStgRhs)] -> [SCC (Id, CgStgRhs)]
forall key payload.
Uniquable key =>
[Node key payload] -> [SCC payload]
stronglyConnCompFromEdgedVerticesUniq [Node Name (Id, CgStgRhs)]
nodes

    from_scc :: SCC (BinderP pass, GenStgRhs pass) -> GenStgTopBinding pass
from_scc (CyclicSCC [(BinderP pass, GenStgRhs pass)]
pairs)       = GenStgBinding pass -> GenStgTopBinding pass
forall (pass :: StgPass).
GenStgBinding pass -> GenStgTopBinding pass
StgTopLifted ([(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass
forall (pass :: StgPass).
[(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass
StgRec [(BinderP pass, GenStgRhs pass)]
pairs)
    from_scc (AcyclicSCC (BinderP pass
bndr,GenStgRhs pass
rhs)) = GenStgBinding pass -> GenStgTopBinding pass
forall (pass :: StgPass).
GenStgBinding pass -> GenStgTopBinding pass
StgTopLifted (BinderP pass -> GenStgRhs pass -> GenStgBinding pass
forall (pass :: StgPass).
BinderP pass -> GenStgRhs pass -> GenStgBinding pass
StgNonRec BinderP pass
bndr GenStgRhs pass
rhs)


flattenTopStgBindings :: [StgTopBinding] -> ([CgStgTopBinding], [(Id,StgRhs)])
flattenTopStgBindings :: [StgTopBinding] -> ([CgStgTopBinding], [(Id, StgRhs)])
flattenTopStgBindings [StgTopBinding]
binds
  = [CgStgTopBinding]
-> [(BinderP 'Vanilla, StgRhs)]
-> [StgTopBinding]
-> ([CgStgTopBinding], [(BinderP 'Vanilla, StgRhs)])
forall {pass :: StgPass} {pass :: StgPass}.
[GenStgTopBinding pass]
-> [(BinderP pass, GenStgRhs pass)]
-> [GenStgTopBinding pass]
-> ([GenStgTopBinding pass], [(BinderP pass, GenStgRhs pass)])
go [] [] [StgTopBinding]
binds
  where
    go :: [GenStgTopBinding pass]
-> [(BinderP pass, GenStgRhs pass)]
-> [GenStgTopBinding pass]
-> ([GenStgTopBinding pass], [(BinderP pass, GenStgRhs pass)])
go [GenStgTopBinding pass]
lits [(BinderP pass, GenStgRhs pass)]
pairs [] = ([GenStgTopBinding pass]
lits, [(BinderP pass, GenStgRhs pass)]
pairs)
    go [GenStgTopBinding pass]
lits [(BinderP pass, GenStgRhs pass)]
pairs (GenStgTopBinding pass
bind:[GenStgTopBinding pass]
binds)
      = case GenStgTopBinding pass
bind of
          StgTopStringLit Id
bndr ByteString
rhs -> [GenStgTopBinding pass]
-> [(BinderP pass, GenStgRhs pass)]
-> [GenStgTopBinding pass]
-> ([GenStgTopBinding pass], [(BinderP pass, GenStgRhs pass)])
go (Id -> ByteString -> GenStgTopBinding pass
forall (pass :: StgPass). Id -> ByteString -> GenStgTopBinding pass
StgTopStringLit Id
bndr ByteString
rhsGenStgTopBinding pass
-> [GenStgTopBinding pass] -> [GenStgTopBinding pass]
forall a. a -> [a] -> [a]
:[GenStgTopBinding pass]
lits) [(BinderP pass, GenStgRhs pass)]
pairs [GenStgTopBinding pass]
binds
          StgTopLifted GenStgBinding pass
stg_bind -> [GenStgTopBinding pass]
-> [(BinderP pass, GenStgRhs pass)]
-> [GenStgTopBinding pass]
-> ([GenStgTopBinding pass], [(BinderP pass, GenStgRhs pass)])
go [GenStgTopBinding pass]
lits (GenStgBinding pass -> [(BinderP pass, GenStgRhs pass)]
forall {pass :: StgPass}.
GenStgBinding pass -> [(BinderP pass, GenStgRhs pass)]
flatten_one GenStgBinding pass
stg_bind [(BinderP pass, GenStgRhs pass)]
-> [(BinderP pass, GenStgRhs pass)]
-> [(BinderP pass, GenStgRhs pass)]
forall a. [a] -> [a] -> [a]
++ [(BinderP pass, GenStgRhs pass)]
pairs) [GenStgTopBinding pass]
binds

    flatten_one :: GenStgBinding pass -> [(BinderP pass, GenStgRhs pass)]
flatten_one (StgNonRec BinderP pass
b GenStgRhs pass
r) = [(BinderP pass
b,GenStgRhs pass
r)]
    flatten_one (StgRec [(BinderP pass, GenStgRhs pass)]
pairs)  = [(BinderP pass, GenStgRhs pass)]
pairs

annotateTopPair :: Env -> (Id, StgRhs) -> Node Name (Id, CgStgRhs)
annotateTopPair :: Env -> (Id, StgRhs) -> Node Name (Id, CgStgRhs)
annotateTopPair Env
env0 (Id
bndr, StgRhs
rhs)
  = DigraphNode { node_key :: Name
node_key          = Id -> Name
idName Id
bndr
                , node_payload :: (Id, CgStgRhs)
node_payload      = (Id
bndr, CgStgRhs
rhs')
                , node_dependencies :: [Name]
node_dependencies = (Id -> Name) -> [Id] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Name
idName (IdSet -> [Id]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet IdSet
top_fvs) }
  where
    (CgStgRhs
rhs', IdSet
top_fvs, LocalFVs
_) = Env -> StgRhs -> (CgStgRhs, IdSet, LocalFVs)
rhsFVs Env
env0 StgRhs
rhs

--------------------------------------------------------------------------------
-- * Non-global free variable analysis

data Env
  = Env
  { -- | Set of locally-bound, not-top-level binders in scope.
    -- That is, variables bound by a let (but not let-no-escape), a lambda
    -- (in a StgRhsClsoure), a case binder, or a case alternative.  These
    -- are the variables that must be captured in a function closure, if they
    -- are free in the RHS. Example
    --   f = \x. let g = \y. x+1
    --           let h = \z. g z + 1
    --           in h x
    -- In the body of h we have locals = {x, g, z}.  Note that f is top level
    -- and does not appear in locals.
    Env -> IdSet
locals :: IdSet
  , Env -> Module
mod    :: Module
  }

addLocals :: [Id] -> Env -> Env
addLocals :: [Id] -> Env -> Env
addLocals [Id]
bndrs Env
env
  = Env
env { locals = extendVarSetList (locals env) bndrs }

--------------------------------------------------------------------------------
-- | TopFVs: set of variables that are:
--    (a) bound at the top level of this module, and
--    (b) appear free in the expression
-- It is a /non-deterministic/ set because we use it only to perform dependency
-- analysis on the top-level bindings.
type TopFVs   = IdSet

-- | LocalFVs: set of variable that are:
--     (a) bound locally (by a lambda, non-top-level let, or case); that is,
--         it appears in the 'locals' field of 'Env'
--     (b) appear free in the expression
-- It is a /deterministic/ set because it is used to annotate closures with
-- their free variables, and we want closure layout to be deterministic.
--
-- Invariant: the LocalFVs returned is a subset of the 'locals' field of Env
type LocalFVs = DIdSet

-- | Dependency analysis on STG terms.
--
-- Dependencies of a binding are just free variables in the binding. This
-- includes imported ids and ids in the current module. For recursive groups we
-- just return one set of free variables which is just the union of dependencies
-- of all bindings in the group.
--
-- Implementation: pass bound variables (NestedIds) to recursive calls, get free
-- variables (TopFVs) back. We ignore imported TopFVs as they do not change the
-- ordering but it improves performance (see `nameIsExternalFrom` call in `vars_fvs`).
--

annBindingFreeVars :: Module -> StgBinding -> CgStgBinding
annBindingFreeVars :: Module -> StgBinding -> CgStgBinding
annBindingFreeVars Module
this_mod = (CgStgBinding, IdSet, LocalFVs) -> CgStgBinding
forall a b c. (a, b, c) -> a
fstOf3 ((CgStgBinding, IdSet, LocalFVs) -> CgStgBinding)
-> (StgBinding -> (CgStgBinding, IdSet, LocalFVs))
-> StgBinding
-> CgStgBinding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> LocalFVs -> StgBinding -> (CgStgBinding, IdSet, LocalFVs)
bindingFVs (IdSet -> Module -> Env
Env IdSet
emptyVarSet Module
this_mod) LocalFVs
emptyDVarSet

bindingFVs :: Env -> LocalFVs -> StgBinding -> (CgStgBinding, TopFVs, LocalFVs)
bindingFVs :: Env -> LocalFVs -> StgBinding -> (CgStgBinding, IdSet, LocalFVs)
bindingFVs Env
env LocalFVs
body_fv StgBinding
b =
  case StgBinding
b of
    StgNonRec BinderP 'Vanilla
bndr StgRhs
r -> (BinderP 'CodeGen -> CgStgRhs -> CgStgBinding
forall (pass :: StgPass).
BinderP pass -> GenStgRhs pass -> GenStgBinding pass
StgNonRec BinderP 'Vanilla
BinderP 'CodeGen
bndr CgStgRhs
r', IdSet
fvs, LocalFVs
lcl_fvs)
      where
        (CgStgRhs
r', IdSet
fvs, LocalFVs
rhs_lcl_fvs) = Env -> StgRhs -> (CgStgRhs, IdSet, LocalFVs)
rhsFVs Env
env StgRhs
r
        lcl_fvs :: LocalFVs
lcl_fvs = LocalFVs -> Id -> LocalFVs
delDVarSet LocalFVs
body_fv Id
BinderP 'Vanilla
bndr LocalFVs -> LocalFVs -> LocalFVs
`unionDVarSet` LocalFVs
rhs_lcl_fvs

    StgRec [(BinderP 'Vanilla, StgRhs)]
pairs -> ([(BinderP 'CodeGen, CgStgRhs)] -> CgStgBinding
forall (pass :: StgPass).
[(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass
StgRec [(Id, CgStgRhs)]
[(BinderP 'CodeGen, CgStgRhs)]
pairs', IdSet
fvs, LocalFVs
lcl_fvss)
      where
        bndrs :: [Id]
bndrs = ((Id, StgRhs) -> Id) -> [(Id, StgRhs)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, StgRhs) -> Id
forall a b. (a, b) -> a
fst [(Id, StgRhs)]
[(BinderP 'Vanilla, StgRhs)]
pairs
        env' :: Env
env' = [Id] -> Env -> Env
addLocals [Id]
bndrs Env
env
        ([CgStgRhs]
rhss, [IdSet]
rhs_fvss, [LocalFVs]
rhs_lcl_fvss) = ((Id, StgRhs) -> (CgStgRhs, IdSet, LocalFVs))
-> [(Id, StgRhs)] -> ([CgStgRhs], [IdSet], [LocalFVs])
forall a b c d. (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
mapAndUnzip3 (Env -> StgRhs -> (CgStgRhs, IdSet, LocalFVs)
rhsFVs Env
env' (StgRhs -> (CgStgRhs, IdSet, LocalFVs))
-> ((Id, StgRhs) -> StgRhs)
-> (Id, StgRhs)
-> (CgStgRhs, IdSet, LocalFVs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id, StgRhs) -> StgRhs
forall a b. (a, b) -> b
snd) [(Id, StgRhs)]
[(BinderP 'Vanilla, StgRhs)]
pairs
        fvs :: IdSet
fvs = [IdSet] -> IdSet
unionVarSets [IdSet]
rhs_fvss
        pairs' :: [(Id, CgStgRhs)]
pairs' = [Id] -> [CgStgRhs] -> [(Id, CgStgRhs)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
bndrs [CgStgRhs]
rhss
        lcl_fvss :: LocalFVs
lcl_fvss = LocalFVs -> [Id] -> LocalFVs
delDVarSetList ([LocalFVs] -> LocalFVs
unionDVarSets (LocalFVs
body_fvLocalFVs -> [LocalFVs] -> [LocalFVs]
forall a. a -> [a] -> [a]
:[LocalFVs]
rhs_lcl_fvss)) [Id]
bndrs

varFVs :: Env -> Id -> (TopFVs, LocalFVs) -> (TopFVs, LocalFVs)
varFVs :: Env -> Id -> (IdSet, LocalFVs) -> (IdSet, LocalFVs)
varFVs Env
env Id
v (IdSet
top_fvs, LocalFVs
lcl_fvs)
  | Id
v Id -> IdSet -> Bool
`elemVarSet` Env -> IdSet
locals Env
env                -- v is locally bound
  = (IdSet
top_fvs, LocalFVs
lcl_fvs LocalFVs -> Id -> LocalFVs
`extendDVarSet` Id
v)
  | Module -> Name -> Bool
nameIsLocalOrFrom (Env -> Module
mod Env
env) (Id -> Name
idName Id
v)   -- v is bound at top level
  = (IdSet
top_fvs IdSet -> Id -> IdSet
`extendVarSet` Id
v, LocalFVs
lcl_fvs)
  | Bool
otherwise                                -- v is imported
  = (IdSet
top_fvs, LocalFVs
lcl_fvs)

exprFVs :: Env -> StgExpr -> (CgStgExpr, TopFVs, LocalFVs)
exprFVs :: Env -> StgExpr -> (CgStgExpr, IdSet, LocalFVs)
exprFVs Env
env = StgExpr -> (CgStgExpr, IdSet, LocalFVs)
go
  where
    go :: StgExpr -> (CgStgExpr, IdSet, LocalFVs)
go (StgApp Id
f [StgArg]
as)
      | (IdSet
top_fvs, LocalFVs
lcl_fvs) <- Env -> Id -> (IdSet, LocalFVs) -> (IdSet, LocalFVs)
varFVs Env
env Id
f (Env -> [StgArg] -> (IdSet, LocalFVs)
argsFVs Env
env [StgArg]
as)
      = (Id -> [StgArg] -> CgStgExpr
forall (pass :: StgPass). Id -> [StgArg] -> GenStgExpr pass
StgApp Id
f [StgArg]
as, IdSet
top_fvs, LocalFVs
lcl_fvs)

    go (StgLit Literal
lit) = (Literal -> CgStgExpr
forall (pass :: StgPass). Literal -> GenStgExpr pass
StgLit Literal
lit, IdSet
emptyVarSet, LocalFVs
emptyDVarSet)

    go (StgConApp DataCon
dc ConstructorNumber
n [StgArg]
as [Type]
tys)
      | (IdSet
top_fvs, LocalFVs
lcl_fvs) <- Env -> [StgArg] -> (IdSet, LocalFVs)
argsFVs Env
env [StgArg]
as
      = (DataCon -> ConstructorNumber -> [StgArg] -> [Type] -> CgStgExpr
forall (pass :: StgPass).
DataCon
-> ConstructorNumber -> [StgArg] -> [Type] -> GenStgExpr pass
StgConApp DataCon
dc ConstructorNumber
n [StgArg]
as [Type]
tys, IdSet
top_fvs, LocalFVs
lcl_fvs)

    go (StgOpApp StgOp
op [StgArg]
as Type
ty)
      | (IdSet
top_fvs, LocalFVs
lcl_fvs) <- Env -> [StgArg] -> (IdSet, LocalFVs)
argsFVs Env
env [StgArg]
as
      = (StgOp -> [StgArg] -> Type -> CgStgExpr
forall (pass :: StgPass).
StgOp -> [StgArg] -> Type -> GenStgExpr pass
StgOpApp StgOp
op [StgArg]
as Type
ty, IdSet
top_fvs, LocalFVs
lcl_fvs)

    go (StgCase StgExpr
scrut BinderP 'Vanilla
bndr AltType
ty [GenStgAlt 'Vanilla]
alts)
      | (CgStgExpr
scrut',IdSet
scrut_top_fvs,LocalFVs
scrut_lcl_fvs) <- Env -> StgExpr -> (CgStgExpr, IdSet, LocalFVs)
exprFVs Env
env StgExpr
scrut
      , ([CgStgAlt]
alts',[IdSet]
alts_top_fvss,[LocalFVs]
alts_lcl_fvss)
          <- (GenStgAlt 'Vanilla -> (CgStgAlt, IdSet, LocalFVs))
-> [GenStgAlt 'Vanilla] -> ([CgStgAlt], [IdSet], [LocalFVs])
forall a b c d. (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
mapAndUnzip3 (Env -> GenStgAlt 'Vanilla -> (CgStgAlt, IdSet, LocalFVs)
altFVs ([Id] -> Env -> Env
addLocals [Id
BinderP 'Vanilla
bndr] Env
env)) [GenStgAlt 'Vanilla]
alts
      , let top_fvs :: IdSet
top_fvs = IdSet
scrut_top_fvs IdSet -> IdSet -> IdSet
`unionVarSet` [IdSet] -> IdSet
unionVarSets [IdSet]
alts_top_fvss
            alts_lcl_fvs :: LocalFVs
alts_lcl_fvs = [LocalFVs] -> LocalFVs
unionDVarSets [LocalFVs]
alts_lcl_fvss
            lcl_fvs :: LocalFVs
lcl_fvs = LocalFVs -> Id -> LocalFVs
delDVarSet (LocalFVs -> LocalFVs -> LocalFVs
unionDVarSet LocalFVs
scrut_lcl_fvs LocalFVs
alts_lcl_fvs) Id
BinderP 'Vanilla
bndr
      = (CgStgExpr -> BinderP 'CodeGen -> AltType -> [CgStgAlt] -> CgStgExpr
forall (pass :: StgPass).
GenStgExpr pass
-> BinderP pass -> AltType -> [GenStgAlt pass] -> GenStgExpr pass
StgCase CgStgExpr
scrut' BinderP 'Vanilla
BinderP 'CodeGen
bndr AltType
ty [CgStgAlt]
alts', IdSet
top_fvs,LocalFVs
lcl_fvs)

    go (StgLet XLet 'Vanilla
ext         StgBinding
bind StgExpr
body) = (CgStgBinding -> CgStgExpr -> CgStgExpr)
-> StgBinding -> StgExpr -> (CgStgExpr, IdSet, LocalFVs)
go_bind (XLet 'CodeGen -> CgStgBinding -> CgStgExpr -> CgStgExpr
forall (pass :: StgPass).
XLet pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLet XLet 'Vanilla
XLet 'CodeGen
ext) StgBinding
bind StgExpr
body
    go (StgLetNoEscape XLetNoEscape 'Vanilla
ext StgBinding
bind StgExpr
body) = (CgStgBinding -> CgStgExpr -> CgStgExpr)
-> StgBinding -> StgExpr -> (CgStgExpr, IdSet, LocalFVs)
go_bind (XLetNoEscape 'CodeGen -> CgStgBinding -> CgStgExpr -> CgStgExpr
forall (pass :: StgPass).
XLetNoEscape pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLetNoEscape XLetNoEscape 'Vanilla
XLetNoEscape 'CodeGen
ext) StgBinding
bind StgExpr
body

    go (StgTick StgTickish
tick StgExpr
e)
      | (CgStgExpr
e', IdSet
top_fvs, LocalFVs
lcl_fvs) <- Env -> StgExpr -> (CgStgExpr, IdSet, LocalFVs)
exprFVs Env
env StgExpr
e
      , let lcl_fvs' :: LocalFVs
lcl_fvs' = LocalFVs -> LocalFVs -> LocalFVs
unionDVarSet (StgTickish -> LocalFVs
forall {pass :: TickishPass}.
(XTickishId pass ~ Id) =>
GenTickish pass -> LocalFVs
tickish StgTickish
tick) LocalFVs
lcl_fvs
      = (StgTickish -> CgStgExpr -> CgStgExpr
forall (pass :: StgPass).
StgTickish -> GenStgExpr pass -> GenStgExpr pass
StgTick StgTickish
tick CgStgExpr
e', IdSet
top_fvs, LocalFVs
lcl_fvs')
        where
          tickish :: GenTickish pass -> LocalFVs
tickish (Breakpoint XBreakpoint pass
_ Int
_ [XTickishId pass]
ids) = [Id] -> LocalFVs
mkDVarSet [Id]
[XTickishId pass]
ids
          tickish GenTickish pass
_                    = LocalFVs
emptyDVarSet

    go_bind :: (CgStgBinding -> CgStgExpr -> CgStgExpr)
-> StgBinding -> StgExpr -> (CgStgExpr, IdSet, LocalFVs)
go_bind CgStgBinding -> CgStgExpr -> CgStgExpr
dc StgBinding
bind StgExpr
body = (CgStgBinding -> CgStgExpr -> CgStgExpr
dc CgStgBinding
bind' CgStgExpr
body', IdSet
top_fvs, LocalFVs
lcl_fvs)
      where
        env' :: Env
env' = [Id] -> Env -> Env
addLocals (StgBinding -> [Id]
forall (a :: StgPass). (BinderP a ~ Id) => GenStgBinding a -> [Id]
bindersOf StgBinding
bind) Env
env
        (CgStgExpr
body', IdSet
body_top_fvs, LocalFVs
body_lcl_fvs) = Env -> StgExpr -> (CgStgExpr, IdSet, LocalFVs)
exprFVs Env
env' StgExpr
body
        (CgStgBinding
bind', IdSet
bind_top_fvs, LocalFVs
lcl_fvs)      = Env -> LocalFVs -> StgBinding -> (CgStgBinding, IdSet, LocalFVs)
bindingFVs Env
env' LocalFVs
body_lcl_fvs StgBinding
bind
        top_fvs :: IdSet
top_fvs = IdSet
bind_top_fvs IdSet -> IdSet -> IdSet
`unionVarSet` IdSet
body_top_fvs


rhsFVs :: Env -> StgRhs -> (CgStgRhs, TopFVs, LocalFVs)
rhsFVs :: Env -> StgRhs -> (CgStgRhs, IdSet, LocalFVs)
rhsFVs Env
env (StgRhsClosure XRhsClosure 'Vanilla
_ CostCentreStack
ccs UpdateFlag
uf [BinderP 'Vanilla]
bs StgExpr
body)
  | (CgStgExpr
body', IdSet
top_fvs, LocalFVs
lcl_fvs) <- Env -> StgExpr -> (CgStgExpr, IdSet, LocalFVs)
exprFVs ([Id] -> Env -> Env
addLocals [Id]
[BinderP 'Vanilla]
bs Env
env) StgExpr
body
  , let lcl_fvs' :: LocalFVs
lcl_fvs' = LocalFVs -> [Id] -> LocalFVs
delDVarSetList LocalFVs
lcl_fvs [Id]
[BinderP 'Vanilla]
bs
  = (XRhsClosure 'CodeGen
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'CodeGen]
-> CgStgExpr
-> CgStgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure LocalFVs
XRhsClosure 'CodeGen
lcl_fvs' CostCentreStack
ccs UpdateFlag
uf [BinderP 'Vanilla]
[BinderP 'CodeGen]
bs CgStgExpr
body', IdSet
top_fvs, LocalFVs
lcl_fvs')
rhsFVs Env
env (StgRhsCon CostCentreStack
ccs DataCon
dc ConstructorNumber
mu [StgTickish]
ts [StgArg]
bs)
  | (IdSet
top_fvs, LocalFVs
lcl_fvs) <- Env -> [StgArg] -> (IdSet, LocalFVs)
argsFVs Env
env [StgArg]
bs
  = (CostCentreStack
-> DataCon
-> ConstructorNumber
-> [StgTickish]
-> [StgArg]
-> CgStgRhs
forall (pass :: StgPass).
CostCentreStack
-> DataCon
-> ConstructorNumber
-> [StgTickish]
-> [StgArg]
-> GenStgRhs pass
StgRhsCon CostCentreStack
ccs DataCon
dc ConstructorNumber
mu [StgTickish]
ts [StgArg]
bs, IdSet
top_fvs, LocalFVs
lcl_fvs)

argsFVs :: Env -> [StgArg] -> (TopFVs, LocalFVs)
argsFVs :: Env -> [StgArg] -> (IdSet, LocalFVs)
argsFVs Env
env = ((IdSet, LocalFVs) -> StgArg -> (IdSet, LocalFVs))
-> (IdSet, LocalFVs) -> [StgArg] -> (IdSet, LocalFVs)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (IdSet, LocalFVs) -> StgArg -> (IdSet, LocalFVs)
f (IdSet
emptyVarSet, LocalFVs
emptyDVarSet)
  where
    f :: (IdSet, LocalFVs) -> StgArg -> (IdSet, LocalFVs)
f (IdSet
fvs,LocalFVs
ids) StgLitArg{}   = (IdSet
fvs, LocalFVs
ids)
    f (IdSet
fvs,LocalFVs
ids) (StgVarArg Id
v) = Env -> Id -> (IdSet, LocalFVs) -> (IdSet, LocalFVs)
varFVs Env
env Id
v (IdSet
fvs, LocalFVs
ids)

altFVs :: Env -> StgAlt -> (CgStgAlt, TopFVs, LocalFVs)
altFVs :: Env -> GenStgAlt 'Vanilla -> (CgStgAlt, IdSet, LocalFVs)
altFVs Env
env GenStgAlt{alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con=AltCon
con, alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs=[BinderP 'Vanilla]
bndrs, alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs=StgExpr
e}
  | (CgStgExpr
e', IdSet
top_fvs, LocalFVs
lcl_fvs) <- Env -> StgExpr -> (CgStgExpr, IdSet, LocalFVs)
exprFVs ([Id] -> Env -> Env
addLocals [Id]
[BinderP 'Vanilla]
bndrs Env
env) StgExpr
e
  , let lcl_fvs' :: LocalFVs
lcl_fvs' = LocalFVs -> [Id] -> LocalFVs
delDVarSetList LocalFVs
lcl_fvs [Id]
[BinderP 'Vanilla]
bndrs
  , let newAlt :: CgStgAlt
newAlt   = GenStgAlt{alt_con :: AltCon
alt_con=AltCon
con, alt_bndrs :: [BinderP 'CodeGen]
alt_bndrs=[BinderP 'Vanilla]
[BinderP 'CodeGen]
bndrs, alt_rhs :: CgStgExpr
alt_rhs=CgStgExpr
e'}
  = (CgStgAlt
newAlt, IdSet
top_fvs, LocalFVs
lcl_fvs')