{-# LANGUAGE LambdaCase #-}

module GHC.StgToJS.StgUtils
  ( bindingRefs
  , hasExport
  , collectTopIds
  , collectIds
  , removeTick
  , isUpdatableRhs
  , isInlineExpr
  , exprRefs
  -- * Live vars
  , LiveVars
  , liveVars
  , liveStatic
  , stgRhsLive
  , stgExprLive
  , stgTopBindLive
  , stgLetNoEscapeLive
  , stgLneLiveExpr
  , stgLneLive
  , stgLneLive'
  )
where

import GHC.Prelude

import GHC.Stg.Syntax
import GHC.Core.DataCon
import GHC.Core.Type
import GHC.Core.TyCon

import GHC.Types.Unique.FM
import GHC.Types.Unique.Set
import GHC.Types.Unique
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.ForeignCall
import GHC.Types.TyThing
import GHC.Types.Name
import GHC.Types.Var.Set

import GHC.Builtin.Names
import GHC.Builtin.PrimOps (PrimOp(SeqOp), primOpIsReallyInline)
import GHC.Utils.Misc (seqList)
import GHC.Utils.Panic

import qualified Data.Foldable as F
import qualified Data.Set      as S
import qualified Data.List     as L
import Data.Set (Set)
import Data.Monoid

s :: a -> Set a
s :: forall a. a -> Set a
s = a -> Set a
forall a. a -> Set a
S.singleton

l :: (a -> Set Id) -> [a] -> Set Id
l :: forall a. (a -> Set Id) -> [a] -> Set Id
l = (a -> Set Id) -> [a] -> Set Id
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap

-- | collect Ids that this binding refers to
--   (does not include the bindees themselves)
-- first argument is Id -> StgExpr map for unfloated arguments
bindingRefs :: UniqFM Id CgStgExpr -> CgStgBinding -> Set Id
bindingRefs :: UniqFM Id CgStgExpr -> CgStgBinding -> Set Id
bindingRefs UniqFM Id CgStgExpr
u = \case
  StgNonRec BinderP 'CodeGen
_ GenStgRhs 'CodeGen
rhs -> UniqFM Id CgStgExpr -> GenStgRhs 'CodeGen -> Set Id
rhsRefs UniqFM Id CgStgExpr
u GenStgRhs 'CodeGen
rhs
  StgRec [(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs       -> ((Id, GenStgRhs 'CodeGen) -> Set Id)
-> [(Id, GenStgRhs 'CodeGen)] -> Set Id
forall a. (a -> Set Id) -> [a] -> Set Id
l (UniqFM Id CgStgExpr -> GenStgRhs 'CodeGen -> Set Id
rhsRefs UniqFM Id CgStgExpr
u (GenStgRhs 'CodeGen -> Set Id)
-> ((Id, GenStgRhs 'CodeGen) -> GenStgRhs 'CodeGen)
-> (Id, GenStgRhs 'CodeGen)
-> Set Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id, GenStgRhs 'CodeGen) -> GenStgRhs 'CodeGen
forall a b. (a, b) -> b
snd) [(Id, GenStgRhs 'CodeGen)]
[(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs

rhsRefs :: UniqFM Id CgStgExpr -> CgStgRhs -> Set Id
rhsRefs :: UniqFM Id CgStgExpr -> GenStgRhs 'CodeGen -> Set Id
rhsRefs UniqFM Id CgStgExpr
u = \case
  StgRhsClosure XRhsClosure 'CodeGen
_ CostCentreStack
_ UpdateFlag
_ [BinderP 'CodeGen]
_ CgStgExpr
body       -> UniqFM Id CgStgExpr -> CgStgExpr -> Set Id
exprRefs UniqFM Id CgStgExpr
u CgStgExpr
body
  StgRhsCon CostCentreStack
_ccs DataCon
d ConstructorNumber
_mu [StgTickish]
_ticks [StgArg]
args -> (Id -> Set Id) -> [Id] -> Set Id
forall a. (a -> Set Id) -> [a] -> Set Id
l Id -> Set Id
forall a. a -> Set a
s [ Id
i | AnId Id
i <- DataCon -> [TyThing]
dataConImplicitTyThings DataCon
d] Set Id -> Set Id -> Set Id
forall a. Semigroup a => a -> a -> a
<> (StgArg -> Set Id) -> [StgArg] -> Set Id
forall a. (a -> Set Id) -> [a] -> Set Id
l (UniqFM Id CgStgExpr -> StgArg -> Set Id
argRefs UniqFM Id CgStgExpr
u) [StgArg]
args

exprRefs :: UniqFM Id CgStgExpr -> CgStgExpr -> Set Id
exprRefs :: UniqFM Id CgStgExpr -> CgStgExpr -> Set Id
exprRefs UniqFM Id CgStgExpr
u = \case
  StgApp Id
f [StgArg]
args             -> Id -> Set Id
forall a. a -> Set a
s Id
f Set Id -> Set Id -> Set Id
forall a. Semigroup a => a -> a -> a
<> (StgArg -> Set Id) -> [StgArg] -> Set Id
forall a. (a -> Set Id) -> [a] -> Set Id
l (UniqFM Id CgStgExpr -> StgArg -> Set Id
argRefs UniqFM Id CgStgExpr
u) [StgArg]
args
  StgConApp DataCon
d ConstructorNumber
_n [StgArg]
args [Type]
_     -> (Id -> Set Id) -> [Id] -> Set Id
forall a. (a -> Set Id) -> [a] -> Set Id
l Id -> Set Id
forall a. a -> Set a
s [ Id
i | AnId Id
i <- DataCon -> [TyThing]
dataConImplicitTyThings DataCon
d] Set Id -> Set Id -> Set Id
forall a. Semigroup a => a -> a -> a
<> (StgArg -> Set Id) -> [StgArg] -> Set Id
forall a. (a -> Set Id) -> [a] -> Set Id
l (UniqFM Id CgStgExpr -> StgArg -> Set Id
argRefs UniqFM Id CgStgExpr
u) [StgArg]
args
  StgOpApp StgOp
_ [StgArg]
args Type
_         -> (StgArg -> Set Id) -> [StgArg] -> Set Id
forall a. (a -> Set Id) -> [a] -> Set Id
l (UniqFM Id CgStgExpr -> StgArg -> Set Id
argRefs UniqFM Id CgStgExpr
u) [StgArg]
args
  StgLit {}                 -> Set Id
forall a. Monoid a => a
mempty
  StgCase CgStgExpr
expr BinderP 'CodeGen
_ AltType
_ [GenStgAlt 'CodeGen]
alts     -> UniqFM Id CgStgExpr -> CgStgExpr -> Set Id
exprRefs UniqFM Id CgStgExpr
u CgStgExpr
expr Set Id -> Set Id -> Set Id
forall a. Semigroup a => a -> a -> a
<> [Set Id] -> Set Id
forall a. Monoid a => [a] -> a
mconcat ((GenStgAlt 'CodeGen -> Set Id) -> [GenStgAlt 'CodeGen] -> [Set Id]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (UniqFM Id CgStgExpr -> GenStgAlt 'CodeGen -> Set Id
altRefs UniqFM Id CgStgExpr
u) [GenStgAlt 'CodeGen]
alts)
  StgLet XLet 'CodeGen
_ CgStgBinding
bnd CgStgExpr
expr         -> UniqFM Id CgStgExpr -> CgStgBinding -> Set Id
bindingRefs UniqFM Id CgStgExpr
u CgStgBinding
bnd Set Id -> Set Id -> Set Id
forall a. Semigroup a => a -> a -> a
<> UniqFM Id CgStgExpr -> CgStgExpr -> Set Id
exprRefs UniqFM Id CgStgExpr
u CgStgExpr
expr
  StgLetNoEscape XLetNoEscape 'CodeGen
_ CgStgBinding
bnd CgStgExpr
expr -> UniqFM Id CgStgExpr -> CgStgBinding -> Set Id
bindingRefs UniqFM Id CgStgExpr
u CgStgBinding
bnd Set Id -> Set Id -> Set Id
forall a. Semigroup a => a -> a -> a
<> UniqFM Id CgStgExpr -> CgStgExpr -> Set Id
exprRefs UniqFM Id CgStgExpr
u CgStgExpr
expr
  StgTick StgTickish
_ CgStgExpr
expr            -> UniqFM Id CgStgExpr -> CgStgExpr -> Set Id
exprRefs UniqFM Id CgStgExpr
u CgStgExpr
expr

altRefs :: UniqFM Id CgStgExpr -> CgStgAlt -> Set Id
altRefs :: UniqFM Id CgStgExpr -> GenStgAlt 'CodeGen -> Set Id
altRefs UniqFM Id CgStgExpr
u GenStgAlt 'CodeGen
alt = UniqFM Id CgStgExpr -> CgStgExpr -> Set Id
exprRefs UniqFM Id CgStgExpr
u (GenStgAlt 'CodeGen -> CgStgExpr
forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs GenStgAlt 'CodeGen
alt)

argRefs :: UniqFM Id CgStgExpr -> StgArg -> Set Id
argRefs :: UniqFM Id CgStgExpr -> StgArg -> Set Id
argRefs UniqFM Id CgStgExpr
u = \case
  StgVarArg Id
id
    | Just CgStgExpr
e <- UniqFM Id CgStgExpr -> Id -> Maybe CgStgExpr
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM Id CgStgExpr
u Id
id -> UniqFM Id CgStgExpr -> CgStgExpr -> Set Id
exprRefs UniqFM Id CgStgExpr
u CgStgExpr
e
    | Bool
otherwise                -> Id -> Set Id
forall a. a -> Set a
s Id
id
  StgArg
_ -> Set Id
forall a. Monoid a => a
mempty

hasExport :: CgStgBinding -> Bool
hasExport :: CgStgBinding -> Bool
hasExport CgStgBinding
bnd =
  case CgStgBinding
bnd of
    StgNonRec BinderP 'CodeGen
b GenStgRhs 'CodeGen
e -> Id -> GenStgRhs 'CodeGen -> Bool
forall {p} {pass :: StgPass}. p -> GenStgRhs pass -> Bool
isExportedBind Id
BinderP 'CodeGen
b GenStgRhs 'CodeGen
e
    StgRec [(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs     -> ((Id, GenStgRhs 'CodeGen) -> Bool)
-> [(Id, GenStgRhs 'CodeGen)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Id -> GenStgRhs 'CodeGen -> Bool)
-> (Id, GenStgRhs 'CodeGen) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Id -> GenStgRhs 'CodeGen -> Bool
forall {p} {pass :: StgPass}. p -> GenStgRhs pass -> Bool
isExportedBind) [(Id, GenStgRhs 'CodeGen)]
[(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs
  where
    isExportedBind :: p -> GenStgRhs pass -> Bool
isExportedBind p
_i (StgRhsCon CostCentreStack
_cc DataCon
con ConstructorNumber
_ [StgTickish]
_ [StgArg]
_) =
      DataCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique DataCon
con Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
staticPtrDataConKey
    isExportedBind p
_ GenStgRhs pass
_ = Bool
False

collectTopIds :: CgStgBinding -> [Id]
collectTopIds :: CgStgBinding -> [Id]
collectTopIds (StgNonRec BinderP 'CodeGen
b GenStgRhs 'CodeGen
_) = [Id
BinderP 'CodeGen
b]
collectTopIds (StgRec [(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs) = let xs :: [Id]
xs = ((Id, GenStgRhs 'CodeGen) -> Id)
-> [(Id, GenStgRhs 'CodeGen)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id -> Id
zapFragileIdInfo (Id -> Id)
-> ((Id, GenStgRhs 'CodeGen) -> Id)
-> (Id, GenStgRhs 'CodeGen)
-> Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id, GenStgRhs 'CodeGen) -> Id
forall a b. (a, b) -> a
fst) [(Id, GenStgRhs 'CodeGen)]
[(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs
                            in  [Id] -> Any -> Any
forall a b. [a] -> b -> b
seqList [Id]
xs (Any -> Any) -> [Id] -> [Id]
forall a b. a -> b -> b
`seq` [Id]
xs

collectIds :: UniqFM Id CgStgExpr -> CgStgBinding -> [Id]
collectIds :: UniqFM Id CgStgExpr -> CgStgBinding -> [Id]
collectIds UniqFM Id CgStgExpr
unfloated CgStgBinding
b =
  let xs :: [Id]
xs = (Id -> Id) -> [Id] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Id
zapFragileIdInfo ([Id] -> [Id]) -> ([Id] -> [Id]) -> [Id] -> [Id]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
           (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filter Id -> Bool
forall {p}. NamedThing p => p -> Bool
acceptId ([Id] -> [Id]) -> [Id] -> [Id]
forall a b. (a -> b) -> a -> b
$ Set Id -> [Id]
forall a. Set a -> [a]
S.toList (UniqFM Id CgStgExpr -> CgStgBinding -> Set Id
bindingRefs UniqFM Id CgStgExpr
unfloated CgStgBinding
b)
  in  [Id] -> Any -> Any
forall a b. [a] -> b -> b
seqList [Id]
xs (Any -> Any) -> [Id] -> [Id]
forall a b. a -> b -> b
`seq` [Id]
xs
  where
    acceptId :: p -> Bool
acceptId p
i = ((p -> Bool) -> Bool) -> [p -> Bool] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((p -> Bool) -> p -> Bool
forall a b. (a -> b) -> a -> b
$ p
i) [Bool -> Bool
not (Bool -> Bool) -> (p -> Bool) -> p -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p -> Bool
forall {p}. NamedThing p => p -> Bool
isForbidden] -- fixme test this: [isExported[isGlobalId, not.isForbidden]
    -- the GHC.Prim module has no js source file
    isForbidden :: a -> Bool
isForbidden a
i
      | Just Module
m <- Name -> Maybe Module
nameModule_maybe (a -> Name
forall a. NamedThing a => a -> Name
getName a
i) = Module
m Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== Module
gHC_PRIM
      | Bool
otherwise = Bool
False

removeTick :: CgStgExpr -> CgStgExpr
removeTick :: CgStgExpr -> CgStgExpr
removeTick (StgTick StgTickish
_ CgStgExpr
e) = CgStgExpr
e
removeTick CgStgExpr
e             = CgStgExpr
e

-----------------------------------------------------
-- Live vars
--
-- TODO: should probably be moved into GHC.Stg.LiveVars

type LiveVars = DVarSet

liveStatic :: LiveVars -> LiveVars
liveStatic :: LiveVars -> LiveVars
liveStatic = (Id -> Bool) -> LiveVars -> LiveVars
filterDVarSet Id -> Bool
isGlobalId

liveVars :: LiveVars -> LiveVars
liveVars :: LiveVars -> LiveVars
liveVars = (Id -> Bool) -> LiveVars -> LiveVars
filterDVarSet (Bool -> Bool
not (Bool -> Bool) -> (Id -> Bool) -> Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Bool
isGlobalId)

stgTopBindLive :: CgStgTopBinding -> [(Id, LiveVars)]
stgTopBindLive :: CgStgTopBinding -> [(Id, LiveVars)]
stgTopBindLive = \case
  StgTopLifted CgStgBinding
b     -> CgStgBinding -> [(Id, LiveVars)]
stgBindLive CgStgBinding
b
  StgTopStringLit {} -> []

stgBindLive :: CgStgBinding -> [(Id, LiveVars)]
stgBindLive :: CgStgBinding -> [(Id, LiveVars)]
stgBindLive = \case
  StgNonRec BinderP 'CodeGen
b GenStgRhs 'CodeGen
rhs -> [(Id
BinderP 'CodeGen
b, GenStgRhs 'CodeGen -> LiveVars
stgRhsLive GenStgRhs 'CodeGen
rhs)]
  StgRec [(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs       -> ((Id, GenStgRhs 'CodeGen) -> (Id, LiveVars))
-> [(Id, GenStgRhs 'CodeGen)] -> [(Id, LiveVars)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Id
b,GenStgRhs 'CodeGen
rhs) -> (Id
b, GenStgRhs 'CodeGen -> LiveVars
stgRhsLive GenStgRhs 'CodeGen
rhs)) [(Id, GenStgRhs 'CodeGen)]
[(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs

stgBindRhsLive :: CgStgBinding -> LiveVars
stgBindRhsLive :: CgStgBinding -> LiveVars
stgBindRhsLive CgStgBinding
b =
  let ([Id]
bs, [LiveVars]
ls) = [(Id, LiveVars)] -> ([Id], [LiveVars])
forall a b. [(a, b)] -> ([a], [b])
unzip (CgStgBinding -> [(Id, LiveVars)]
stgBindLive CgStgBinding
b)
  in  LiveVars -> [Id] -> LiveVars
delDVarSetList ([LiveVars] -> LiveVars
unionDVarSets [LiveVars]
ls) [Id]
bs

stgRhsLive :: CgStgRhs -> LiveVars
stgRhsLive :: GenStgRhs 'CodeGen -> LiveVars
stgRhsLive = \case
  StgRhsClosure XRhsClosure 'CodeGen
_ CostCentreStack
_ UpdateFlag
_ [BinderP 'CodeGen]
args CgStgExpr
e -> LiveVars -> [Id] -> LiveVars
delDVarSetList (Bool -> CgStgExpr -> LiveVars
stgExprLive Bool
True CgStgExpr
e) [Id]
[BinderP 'CodeGen]
args
  StgRhsCon CostCentreStack
_ DataCon
_ ConstructorNumber
_ [StgTickish]
_ [StgArg]
args     -> [LiveVars] -> LiveVars
unionDVarSets ((StgArg -> LiveVars) -> [StgArg] -> [LiveVars]
forall a b. (a -> b) -> [a] -> [b]
map StgArg -> LiveVars
stgArgLive [StgArg]
args)

stgArgLive :: StgArg -> LiveVars
stgArgLive :: StgArg -> LiveVars
stgArgLive = \case
  StgVarArg Id
occ -> Id -> LiveVars
unitDVarSet Id
occ
  StgLitArg {}  -> LiveVars
emptyDVarSet

stgExprLive :: Bool -> CgStgExpr -> LiveVars
stgExprLive :: Bool -> CgStgExpr -> LiveVars
stgExprLive Bool
includeLHS = \case
  StgApp Id
occ [StgArg]
args -> [LiveVars] -> LiveVars
unionDVarSets (Id -> LiveVars
unitDVarSet Id
occ LiveVars -> [LiveVars] -> [LiveVars]
forall a. a -> [a] -> [a]
: (StgArg -> LiveVars) -> [StgArg] -> [LiveVars]
forall a b. (a -> b) -> [a] -> [b]
map StgArg -> LiveVars
stgArgLive [StgArg]
args)
  StgLit {}       -> LiveVars
emptyDVarSet
  StgConApp DataCon
_dc ConstructorNumber
_n [StgArg]
args [Type]
_tys -> [LiveVars] -> LiveVars
unionDVarSets ((StgArg -> LiveVars) -> [StgArg] -> [LiveVars]
forall a b. (a -> b) -> [a] -> [b]
map StgArg -> LiveVars
stgArgLive [StgArg]
args)
  StgOpApp StgOp
_op [StgArg]
args Type
_ty      -> [LiveVars] -> LiveVars
unionDVarSets ((StgArg -> LiveVars) -> [StgArg] -> [LiveVars]
forall a b. (a -> b) -> [a] -> [b]
map StgArg -> LiveVars
stgArgLive [StgArg]
args)
  StgCase CgStgExpr
e BinderP 'CodeGen
b AltType
_at [GenStgAlt 'CodeGen]
alts
    | Bool
includeLHS -> LiveVars
el LiveVars -> LiveVars -> LiveVars
`unionDVarSet` LiveVars -> Id -> LiveVars
delDVarSet LiveVars
al Id
BinderP 'CodeGen
b
    | Bool
otherwise  -> LiveVars -> Id -> LiveVars
delDVarSet LiveVars
al Id
BinderP 'CodeGen
b
    where
      al :: LiveVars
al = [LiveVars] -> LiveVars
unionDVarSets ((GenStgAlt 'CodeGen -> LiveVars)
-> [GenStgAlt 'CodeGen] -> [LiveVars]
forall a b. (a -> b) -> [a] -> [b]
map GenStgAlt 'CodeGen -> LiveVars
stgAltLive [GenStgAlt 'CodeGen]
alts)
      el :: LiveVars
el = Bool -> CgStgExpr -> LiveVars
stgExprLive Bool
True CgStgExpr
e
  StgLet XLet 'CodeGen
_ CgStgBinding
b CgStgExpr
e         -> LiveVars -> [Id] -> LiveVars
delDVarSetList (CgStgBinding -> LiveVars
stgBindRhsLive CgStgBinding
b LiveVars -> LiveVars -> LiveVars
`unionDVarSet` Bool -> CgStgExpr -> LiveVars
stgExprLive Bool
True CgStgExpr
e) (CgStgBinding -> [Id]
bindees CgStgBinding
b)
  StgLetNoEscape XLetNoEscape 'CodeGen
_ CgStgBinding
b CgStgExpr
e -> LiveVars -> [Id] -> LiveVars
delDVarSetList (CgStgBinding -> LiveVars
stgBindRhsLive CgStgBinding
b LiveVars -> LiveVars -> LiveVars
`unionDVarSet` Bool -> CgStgExpr -> LiveVars
stgExprLive Bool
True CgStgExpr
e) (CgStgBinding -> [Id]
bindees CgStgBinding
b)
  StgTick StgTickish
_ti CgStgExpr
e        -> Bool -> CgStgExpr -> LiveVars
stgExprLive Bool
True CgStgExpr
e

stgAltLive :: CgStgAlt -> LiveVars
stgAltLive :: GenStgAlt 'CodeGen -> LiveVars
stgAltLive GenStgAlt 'CodeGen
alt =
  LiveVars -> [Id] -> LiveVars
delDVarSetList (Bool -> CgStgExpr -> LiveVars
stgExprLive Bool
True (GenStgAlt 'CodeGen -> CgStgExpr
forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs GenStgAlt 'CodeGen
alt)) (GenStgAlt 'CodeGen -> [BinderP 'CodeGen]
forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs GenStgAlt 'CodeGen
alt)

stgLetNoEscapeLive :: Bool -> StgBinding -> StgExpr -> LiveVars
stgLetNoEscapeLive :: Bool -> StgBinding -> StgExpr -> LiveVars
stgLetNoEscapeLive Bool
_someBool StgBinding
_b StgExpr
_e = String -> LiveVars
forall a. HasCallStack => String -> a
panic String
"stgLetNoEscapeLive"

bindees :: CgStgBinding -> [Id]
bindees :: CgStgBinding -> [Id]
bindees = \case
  StgNonRec BinderP 'CodeGen
b GenStgRhs 'CodeGen
_e -> [Id
BinderP 'CodeGen
b]
  StgRec [(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs      -> ((Id, GenStgRhs 'CodeGen) -> Id)
-> [(Id, GenStgRhs 'CodeGen)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, GenStgRhs 'CodeGen) -> Id
forall a b. (a, b) -> a
fst [(Id, GenStgRhs 'CodeGen)]
[(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs

isUpdatableRhs :: CgStgRhs -> Bool
isUpdatableRhs :: GenStgRhs 'CodeGen -> Bool
isUpdatableRhs (StgRhsClosure XRhsClosure 'CodeGen
_ CostCentreStack
_ UpdateFlag
u [BinderP 'CodeGen]
_ CgStgExpr
_) = UpdateFlag -> Bool
isUpdatable UpdateFlag
u
isUpdatableRhs GenStgRhs 'CodeGen
_                         = Bool
False

stgLneLive' :: CgStgBinding -> [Id]
stgLneLive' :: CgStgBinding -> [Id]
stgLneLive' CgStgBinding
b = (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filter (Id -> [Id] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` CgStgBinding -> [Id]
bindees CgStgBinding
b) (CgStgBinding -> [Id]
stgLneLive CgStgBinding
b)

stgLneLive :: CgStgBinding -> [Id]
stgLneLive :: CgStgBinding -> [Id]
stgLneLive (StgNonRec BinderP 'CodeGen
_b GenStgRhs 'CodeGen
e) = GenStgRhs 'CodeGen -> [Id]
stgLneLiveExpr GenStgRhs 'CodeGen
e
stgLneLive (StgRec [(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs)      = [Id] -> [Id]
forall a. Eq a => [a] -> [a]
L.nub ([Id] -> [Id]) -> [Id] -> [Id]
forall a b. (a -> b) -> a -> b
$ ((Id, GenStgRhs 'CodeGen) -> [Id])
-> [(Id, GenStgRhs 'CodeGen)] -> [Id]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (GenStgRhs 'CodeGen -> [Id]
stgLneLiveExpr (GenStgRhs 'CodeGen -> [Id])
-> ((Id, GenStgRhs 'CodeGen) -> GenStgRhs 'CodeGen)
-> (Id, GenStgRhs 'CodeGen)
-> [Id]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id, GenStgRhs 'CodeGen) -> GenStgRhs 'CodeGen
forall a b. (a, b) -> b
snd) [(Id, GenStgRhs 'CodeGen)]
[(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs

stgLneLiveExpr :: CgStgRhs -> [Id]
stgLneLiveExpr :: GenStgRhs 'CodeGen -> [Id]
stgLneLiveExpr GenStgRhs 'CodeGen
rhs = LiveVars -> [Id]
dVarSetElems (LiveVars -> LiveVars
liveVars (LiveVars -> LiveVars) -> LiveVars -> LiveVars
forall a b. (a -> b) -> a -> b
$ GenStgRhs 'CodeGen -> LiveVars
stgRhsLive GenStgRhs 'CodeGen
rhs)
-- stgLneLiveExpr (StgRhsClosure _ _ _ _ e) = dVarSetElems (liveVars (stgExprLive e))
-- stgLneLiveExpr StgRhsCon {}              = []

-- | returns True if the expression is definitely inline
isInlineExpr :: UniqSet Id -> CgStgExpr -> (UniqSet Id, Bool)
isInlineExpr :: UniqSet Id -> CgStgExpr -> (UniqSet Id, Bool)
isInlineExpr UniqSet Id
v = \case
  StgApp Id
i [StgArg]
args
    -> (UniqSet Id
forall a. UniqSet a
emptyUniqSet, UniqSet Id -> Id -> [StgArg] -> Bool
isInlineApp UniqSet Id
v Id
i [StgArg]
args)
  StgLit{}
    -> (UniqSet Id
forall a. UniqSet a
emptyUniqSet, Bool
True)
  StgConApp{}
    -> (UniqSet Id
forall a. UniqSet a
emptyUniqSet, Bool
True)
  StgOpApp (StgFCallOp ForeignCall
f Type
_) [StgArg]
_ Type
_
    -> (UniqSet Id
forall a. UniqSet a
emptyUniqSet, ForeignCall -> Bool
isInlineForeignCall ForeignCall
f)
  StgOpApp (StgPrimOp PrimOp
SeqOp) [StgVarArg Id
e] Type
t
    -> (UniqSet Id
forall a. UniqSet a
emptyUniqSet, Id
e Id -> UniqSet Id -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet Id
v Bool -> Bool -> Bool
|| (() :: Constraint) => Type -> Bool
Type -> Bool
isStrictType Type
t)
  StgOpApp (StgPrimOp PrimOp
op) [StgArg]
_ Type
_
    -> (UniqSet Id
forall a. UniqSet a
emptyUniqSet, PrimOp -> Bool
primOpIsReallyInline PrimOp
op)
  StgOpApp (StgPrimCallOp PrimCall
_c) [StgArg]
_ Type
_
    -> (UniqSet Id
forall a. UniqSet a
emptyUniqSet, Bool
True)
  StgCase CgStgExpr
e BinderP 'CodeGen
b AltType
_ [GenStgAlt 'CodeGen]
alts
    ->let (UniqSet Id
_ve, Bool
ie)   = UniqSet Id -> CgStgExpr -> (UniqSet Id, Bool)
isInlineExpr UniqSet Id
v CgStgExpr
e
          v' :: UniqSet Id
v'          = UniqSet Id -> Id -> UniqSet Id
forall a. Uniquable a => UniqSet a -> a -> UniqSet a
addOneToUniqSet UniqSet Id
v Id
BinderP 'CodeGen
b
          ([UniqSet Id]
vas, [Bool]
ias)  = [(UniqSet Id, Bool)] -> ([UniqSet Id], [Bool])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(UniqSet Id, Bool)] -> ([UniqSet Id], [Bool]))
-> [(UniqSet Id, Bool)] -> ([UniqSet Id], [Bool])
forall a b. (a -> b) -> a -> b
$ (CgStgExpr -> (UniqSet Id, Bool))
-> [CgStgExpr] -> [(UniqSet Id, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (UniqSet Id -> CgStgExpr -> (UniqSet Id, Bool)
isInlineExpr UniqSet Id
v') ((GenStgAlt 'CodeGen -> CgStgExpr)
-> [GenStgAlt 'CodeGen] -> [CgStgExpr]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenStgAlt 'CodeGen -> CgStgExpr
forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs [GenStgAlt 'CodeGen]
alts)
          vr :: UniqSet Id
vr          = (UniqSet Id -> UniqSet Id -> UniqSet Id)
-> [UniqSet Id] -> UniqSet Id
forall a. HasCallStack => (a -> a -> a) -> [a] -> a
L.foldl1' UniqSet Id -> UniqSet Id -> UniqSet Id
forall a. UniqSet a -> UniqSet a -> UniqSet a
intersectUniqSets [UniqSet Id]
vas
      in (UniqSet Id
vr, (Bool
ie Bool -> Bool -> Bool
|| Id
BinderP 'CodeGen
b Id -> UniqSet Id -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet Id
v) Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
ias)
  StgLet XLet 'CodeGen
_ CgStgBinding
b CgStgExpr
e
    -> UniqSet Id -> CgStgExpr -> (UniqSet Id, Bool)
isInlineExpr (UniqSet Id -> CgStgBinding -> UniqSet Id
inspectInlineBinding UniqSet Id
v CgStgBinding
b) CgStgExpr
e
  StgLetNoEscape XLetNoEscape 'CodeGen
_ CgStgBinding
_b CgStgExpr
e
    -> UniqSet Id -> CgStgExpr -> (UniqSet Id, Bool)
isInlineExpr UniqSet Id
v CgStgExpr
e
  StgTick  StgTickish
_ CgStgExpr
e
    -> UniqSet Id -> CgStgExpr -> (UniqSet Id, Bool)
isInlineExpr UniqSet Id
v CgStgExpr
e

inspectInlineBinding :: UniqSet Id -> CgStgBinding -> UniqSet Id
inspectInlineBinding :: UniqSet Id -> CgStgBinding -> UniqSet Id
inspectInlineBinding UniqSet Id
v = \case
  StgNonRec BinderP 'CodeGen
i GenStgRhs 'CodeGen
r -> UniqSet Id -> Id -> GenStgRhs 'CodeGen -> UniqSet Id
inspectInlineRhs UniqSet Id
v Id
BinderP 'CodeGen
i GenStgRhs 'CodeGen
r
  StgRec [(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs     -> (UniqSet Id -> (Id, GenStgRhs 'CodeGen) -> UniqSet Id)
-> UniqSet Id -> [(Id, GenStgRhs 'CodeGen)] -> UniqSet Id
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\UniqSet Id
v' (Id
i,GenStgRhs 'CodeGen
r) -> UniqSet Id -> Id -> GenStgRhs 'CodeGen -> UniqSet Id
inspectInlineRhs UniqSet Id
v' Id
i GenStgRhs 'CodeGen
r) UniqSet Id
v [(Id, GenStgRhs 'CodeGen)]
[(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs

inspectInlineRhs :: UniqSet Id -> Id -> CgStgRhs -> UniqSet Id
inspectInlineRhs :: UniqSet Id -> Id -> GenStgRhs 'CodeGen -> UniqSet Id
inspectInlineRhs UniqSet Id
v Id
i = \case
  StgRhsCon{}                     -> UniqSet Id -> Id -> UniqSet Id
forall a. Uniquable a => UniqSet a -> a -> UniqSet a
addOneToUniqSet UniqSet Id
v Id
i
  StgRhsClosure XRhsClosure 'CodeGen
_ CostCentreStack
_ UpdateFlag
ReEntrant [BinderP 'CodeGen]
_ CgStgExpr
_ -> UniqSet Id -> Id -> UniqSet Id
forall a. Uniquable a => UniqSet a -> a -> UniqSet a
addOneToUniqSet UniqSet Id
v Id
i
  GenStgRhs 'CodeGen
_                               -> UniqSet Id
v

isInlineForeignCall :: ForeignCall -> Bool
isInlineForeignCall :: ForeignCall -> Bool
isInlineForeignCall (CCall (CCallSpec CCallTarget
_ CCallConv
cconv Safety
safety)) =
  Bool -> Bool
not (Safety -> Bool
playInterruptible Safety
safety) Bool -> Bool -> Bool
&&
  Bool -> Bool
not (CCallConv
cconv CCallConv -> CCallConv -> Bool
forall a. Eq a => a -> a -> Bool
/= CCallConv
JavaScriptCallConv Bool -> Bool -> Bool
&& Safety -> Bool
playSafe Safety
safety)

isInlineApp :: UniqSet Id -> Id -> [StgArg] -> Bool
isInlineApp :: UniqSet Id -> Id -> [StgArg] -> Bool
isInlineApp UniqSet Id
v Id
i = \case
  [StgArg]
_ | Id -> Bool
isJoinId Id
i -> Bool
False
  [] -> Type -> Bool
isUnboxedTupleType (Id -> Type
idType Id
i) Bool -> Bool -> Bool
||
                     (() :: Constraint) => Type -> Bool
Type -> Bool
isStrictType (Id -> Type
idType Id
i) Bool -> Bool -> Bool
||
                     Id
i Id -> UniqSet Id -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet Id
v

  [StgVarArg Id
a]
    | DataConWrapId DataCon
dc <- Id -> IdDetails
idDetails Id
i
    , TyCon -> Bool
isNewTyCon (DataCon -> TyCon
dataConTyCon DataCon
dc)
    , (() :: Constraint) => Type -> Bool
Type -> Bool
isStrictType (Id -> Type
idType Id
a) Bool -> Bool -> Bool
|| Id
a Id -> UniqSet Id -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet Id
v Bool -> Bool -> Bool
|| Id -> Bool
isStrictId Id
a
    -> Bool
True
  [StgArg]
_ -> Bool
False