{-# LANGUAGE TypeFamilies #-}
module GHC.Stg.CSE (stgCse) where
import GHC.Prelude
import GHC.Core.DataCon
import GHC.Types.Id
import GHC.Stg.Syntax
import GHC.Types.Basic (isWeakLoopBreaker)
import GHC.Types.Var.Env
import GHC.Core (AltCon(..))
import Data.List (mapAccumL)
import Data.Maybe (fromMaybe)
import GHC.Core.Map.Expr
import GHC.Data.TrieMap
import GHC.Types.Name.Env
import Control.Monad( (>=>) )
data StgArgMap a = SAM
{ forall a. StgArgMap a -> DVarEnv a
sam_var :: DVarEnv a
, forall a. StgArgMap a -> LiteralMap a
sam_lit :: LiteralMap a
}
instance Functor StgArgMap where
fmap :: forall a b. (a -> b) -> StgArgMap a -> StgArgMap b
fmap a -> b
f SAM { sam_var :: forall a. StgArgMap a -> DVarEnv a
sam_var = DVarEnv a
varm, sam_lit :: forall a. StgArgMap a -> LiteralMap a
sam_lit = LiteralMap a
litm } = SAM
{ sam_var :: DVarEnv b
sam_var = (a -> b) -> DVarEnv a -> DVarEnv b
forall a b. (a -> b) -> UniqDFM Id a -> UniqDFM Id b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f DVarEnv a
varm, sam_lit :: LiteralMap b
sam_lit = (a -> b) -> LiteralMap a -> LiteralMap b
forall a b. (a -> b) -> Map Literal a -> Map Literal b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f LiteralMap a
litm }
instance TrieMap StgArgMap where
type Key StgArgMap = StgArg
emptyTM :: forall a. StgArgMap a
emptyTM = SAM { sam_var :: DVarEnv a
sam_var = DVarEnv a
forall a. UniqDFM Id a
forall (m :: * -> *) a. TrieMap m => m a
emptyTM
, sam_lit :: LiteralMap a
sam_lit = LiteralMap a
forall a. Map Literal a
forall (m :: * -> *) a. TrieMap m => m a
emptyTM }
lookupTM :: forall b. Key StgArgMap -> StgArgMap b -> Maybe b
lookupTM (StgVarArg Id
var) = StgArgMap b -> DVarEnv b
forall a. StgArgMap a -> DVarEnv a
sam_var (StgArgMap b -> DVarEnv b)
-> (DVarEnv b -> Maybe b) -> StgArgMap b -> Maybe b
forall a b c. (a -> b) -> (b -> c) -> a -> c
>.> Id -> DVarEnv b -> Maybe b
forall a. Id -> DVarEnv a -> Maybe a
lkDFreeVar Id
var
lookupTM (StgLitArg Literal
lit) = StgArgMap b -> LiteralMap b
forall a. StgArgMap a -> LiteralMap a
sam_lit (StgArgMap b -> LiteralMap b)
-> (LiteralMap b -> Maybe b) -> StgArgMap b -> Maybe b
forall a b c. (a -> b) -> (b -> c) -> a -> c
>.> Key (Map Literal) -> LiteralMap b -> Maybe b
forall b. Key (Map Literal) -> Map Literal b -> Maybe b
forall (m :: * -> *) b. TrieMap m => Key m -> m b -> Maybe b
lookupTM Literal
Key (Map Literal)
lit
alterTM :: forall b. Key StgArgMap -> XT b -> StgArgMap b -> StgArgMap b
alterTM (StgVarArg Id
var) XT b
f StgArgMap b
m = StgArgMap b
m { sam_var = sam_var m |> xtDFreeVar var f }
alterTM (StgLitArg Literal
lit) XT b
f StgArgMap b
m = StgArgMap b
m { sam_lit = sam_lit m |> alterTM lit f }
foldTM :: forall a b. (a -> b -> b) -> StgArgMap a -> b -> b
foldTM a -> b -> b
k StgArgMap a
m = (a -> b -> b) -> UniqDFM Id a -> b -> b
forall a b. (a -> b -> b) -> UniqDFM Id a -> b -> b
forall (m :: * -> *) a b.
TrieMap m =>
(a -> b -> b) -> m a -> b -> b
foldTM a -> b -> b
k (StgArgMap a -> UniqDFM Id a
forall a. StgArgMap a -> DVarEnv a
sam_var StgArgMap a
m) (b -> b) -> (b -> b) -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b -> b) -> Map Literal a -> b -> b
forall a b. (a -> b -> b) -> Map Literal a -> b -> b
forall (m :: * -> *) a b.
TrieMap m =>
(a -> b -> b) -> m a -> b -> b
foldTM a -> b -> b
k (StgArgMap a -> Map Literal a
forall a. StgArgMap a -> LiteralMap a
sam_lit StgArgMap a
m)
filterTM :: forall a. (a -> Bool) -> StgArgMap a -> StgArgMap a
filterTM a -> Bool
f (SAM {sam_var :: forall a. StgArgMap a -> DVarEnv a
sam_var = DVarEnv a
varm, sam_lit :: forall a. StgArgMap a -> LiteralMap a
sam_lit = LiteralMap a
litm}) =
SAM { sam_var :: DVarEnv a
sam_var = (a -> Bool) -> DVarEnv a -> DVarEnv a
forall a. (a -> Bool) -> UniqDFM Id a -> UniqDFM Id a
forall (m :: * -> *) a. TrieMap m => (a -> Bool) -> m a -> m a
filterTM a -> Bool
f DVarEnv a
varm, sam_lit :: LiteralMap a
sam_lit = (a -> Bool) -> LiteralMap a -> LiteralMap a
forall a. (a -> Bool) -> Map Literal a -> Map Literal a
forall (m :: * -> *) a. TrieMap m => (a -> Bool) -> m a -> m a
filterTM a -> Bool
f LiteralMap a
litm }
newtype ConAppMap a = CAM { forall a. ConAppMap a -> DNameEnv (ListMap StgArgMap a)
un_cam :: DNameEnv (ListMap StgArgMap a) }
instance Functor ConAppMap where
fmap :: forall a b. (a -> b) -> ConAppMap a -> ConAppMap b
fmap a -> b
f = DNameEnv (ListMap StgArgMap b) -> ConAppMap b
forall a. DNameEnv (ListMap StgArgMap a) -> ConAppMap a
CAM (DNameEnv (ListMap StgArgMap b) -> ConAppMap b)
-> (ConAppMap a -> DNameEnv (ListMap StgArgMap b))
-> ConAppMap a
-> ConAppMap b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ListMap StgArgMap a -> ListMap StgArgMap b)
-> UniqDFM Name (ListMap StgArgMap a)
-> DNameEnv (ListMap StgArgMap b)
forall a b. (a -> b) -> UniqDFM Name a -> UniqDFM Name b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> ListMap StgArgMap a -> ListMap StgArgMap b
forall a b. (a -> b) -> ListMap StgArgMap a -> ListMap StgArgMap b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) (UniqDFM Name (ListMap StgArgMap a)
-> DNameEnv (ListMap StgArgMap b))
-> (ConAppMap a -> UniqDFM Name (ListMap StgArgMap a))
-> ConAppMap a
-> DNameEnv (ListMap StgArgMap b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConAppMap a -> UniqDFM Name (ListMap StgArgMap a)
forall a. ConAppMap a -> DNameEnv (ListMap StgArgMap a)
un_cam
{-# INLINE fmap #-}
instance TrieMap ConAppMap where
type Key ConAppMap = (DataCon, [StgArg])
emptyTM :: forall a. ConAppMap a
emptyTM = DNameEnv (ListMap StgArgMap a) -> ConAppMap a
forall a. DNameEnv (ListMap StgArgMap a) -> ConAppMap a
CAM DNameEnv (ListMap StgArgMap a)
forall a. UniqDFM Name a
forall (m :: * -> *) a. TrieMap m => m a
emptyTM
lookupTM :: forall b. Key ConAppMap -> ConAppMap b -> Maybe b
lookupTM (DataCon
dataCon, [StgArg]
args) = ConAppMap b -> DNameEnv (ListMap StgArgMap b)
forall a. ConAppMap a -> DNameEnv (ListMap StgArgMap a)
un_cam (ConAppMap b -> DNameEnv (ListMap StgArgMap b))
-> (DNameEnv (ListMap StgArgMap b) -> Maybe b)
-> ConAppMap b
-> Maybe b
forall a b c. (a -> b) -> (b -> c) -> a -> c
>.> DataCon
-> DNameEnv (ListMap StgArgMap b) -> Maybe (ListMap StgArgMap b)
forall n a. NamedThing n => n -> DNameEnv a -> Maybe a
lkDNamed DataCon
dataCon (DNameEnv (ListMap StgArgMap b) -> Maybe (ListMap StgArgMap b))
-> (ListMap StgArgMap b -> Maybe b)
-> DNameEnv (ListMap StgArgMap b)
-> Maybe b
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Key (ListMap StgArgMap) -> ListMap StgArgMap b -> Maybe b
forall b. Key (ListMap StgArgMap) -> ListMap StgArgMap b -> Maybe b
forall (m :: * -> *) b. TrieMap m => Key m -> m b -> Maybe b
lookupTM [StgArg]
Key (ListMap StgArgMap)
args
alterTM :: forall b. Key ConAppMap -> XT b -> ConAppMap b -> ConAppMap b
alterTM (DataCon
dataCon, [StgArg]
args) XT b
f ConAppMap b
m =
ConAppMap b
m { un_cam = un_cam m |> xtDNamed dataCon |>> alterTM args f }
foldTM :: forall a b. (a -> b -> b) -> ConAppMap a -> b -> b
foldTM a -> b -> b
k = ConAppMap a -> DNameEnv (ListMap StgArgMap a)
forall a. ConAppMap a -> DNameEnv (ListMap StgArgMap a)
un_cam (ConAppMap a -> DNameEnv (ListMap StgArgMap a))
-> (DNameEnv (ListMap StgArgMap a) -> b -> b)
-> ConAppMap a
-> b
-> b
forall a b c. (a -> b) -> (b -> c) -> a -> c
>.> (ListMap StgArgMap a -> b -> b)
-> DNameEnv (ListMap StgArgMap a) -> b -> b
forall a b. (a -> b -> b) -> UniqDFM Name a -> b -> b
forall (m :: * -> *) a b.
TrieMap m =>
(a -> b -> b) -> m a -> b -> b
foldTM ((a -> b -> b) -> ListMap StgArgMap a -> b -> b
forall a b. (a -> b -> b) -> ListMap StgArgMap a -> b -> b
forall (m :: * -> *) a b.
TrieMap m =>
(a -> b -> b) -> m a -> b -> b
foldTM a -> b -> b
k)
filterTM :: forall a. (a -> Bool) -> ConAppMap a -> ConAppMap a
filterTM a -> Bool
f = ConAppMap a -> DNameEnv (ListMap StgArgMap a)
forall a. ConAppMap a -> DNameEnv (ListMap StgArgMap a)
un_cam (ConAppMap a -> DNameEnv (ListMap StgArgMap a))
-> (DNameEnv (ListMap StgArgMap a) -> ConAppMap a)
-> ConAppMap a
-> ConAppMap a
forall a b c. (a -> b) -> (b -> c) -> a -> c
>.> (ListMap StgArgMap a -> ListMap StgArgMap a)
-> DNameEnv (ListMap StgArgMap a) -> DNameEnv (ListMap StgArgMap a)
forall a b. (a -> b) -> UniqDFM Name a -> UniqDFM Name b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> Bool) -> ListMap StgArgMap a -> ListMap StgArgMap a
forall a. (a -> Bool) -> ListMap StgArgMap a -> ListMap StgArgMap a
forall (m :: * -> *) a. TrieMap m => (a -> Bool) -> m a -> m a
filterTM a -> Bool
f) (DNameEnv (ListMap StgArgMap a) -> DNameEnv (ListMap StgArgMap a))
-> (DNameEnv (ListMap StgArgMap a) -> ConAppMap a)
-> DNameEnv (ListMap StgArgMap a)
-> ConAppMap a
forall a b c. (a -> b) -> (b -> c) -> a -> c
>.> DNameEnv (ListMap StgArgMap a) -> ConAppMap a
forall a. DNameEnv (ListMap StgArgMap a) -> ConAppMap a
CAM
data CseEnv = CseEnv
{ CseEnv -> ConAppMap Id
ce_conAppMap :: ConAppMap OutId
, CseEnv -> IdEnv Id
ce_subst :: IdEnv OutId
, CseEnv -> IdEnv Id
ce_bndrMap :: IdEnv OutId
, CseEnv -> InScopeSet
ce_in_scope :: InScopeSet
}
initEnv :: InScopeSet -> CseEnv
initEnv :: InScopeSet -> CseEnv
initEnv InScopeSet
in_scope = CseEnv
{ ce_conAppMap :: ConAppMap Id
ce_conAppMap = ConAppMap Id
forall a. ConAppMap a
forall (m :: * -> *) a. TrieMap m => m a
emptyTM
, ce_subst :: IdEnv Id
ce_subst = IdEnv Id
forall a. VarEnv a
emptyVarEnv
, ce_bndrMap :: IdEnv Id
ce_bndrMap = IdEnv Id
forall a. VarEnv a
emptyVarEnv
, ce_in_scope :: InScopeSet
ce_in_scope = InScopeSet
in_scope
}
normaliseConArgs :: CseEnv -> [OutStgArg] -> [OutStgArg]
normaliseConArgs :: CseEnv -> [StgArg] -> [StgArg]
normaliseConArgs CseEnv
env [StgArg]
args
= (StgArg -> StgArg) -> [StgArg] -> [StgArg]
forall a b. (a -> b) -> [a] -> [b]
map StgArg -> StgArg
go [StgArg]
args
where
bndr_map :: IdEnv Id
bndr_map = CseEnv -> IdEnv Id
ce_bndrMap CseEnv
env
go :: StgArg -> StgArg
go (StgVarArg Id
v ) = Id -> StgArg
StgVarArg (IdEnv Id -> Id -> Id
normaliseId IdEnv Id
bndr_map Id
v)
go (StgLitArg Literal
lit) = Literal -> StgArg
StgLitArg Literal
lit
normaliseId :: IdEnv OutId -> OutId -> OutId
normaliseId :: IdEnv Id -> Id -> Id
normaliseId IdEnv Id
bndr_map Id
v = case IdEnv Id -> Id -> Maybe Id
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv IdEnv Id
bndr_map Id
v of
Just Id
v' -> Id
v'
Maybe Id
Nothing -> Id
v
addTrivCaseBndr :: OutId -> OutId -> CseEnv -> CseEnv
addTrivCaseBndr :: Id -> Id -> CseEnv -> CseEnv
addTrivCaseBndr Id
from Id
to CseEnv
env
= CseEnv
env { ce_bndrMap = extendVarEnv bndr_map from norm_to }
where
bndr_map :: IdEnv Id
bndr_map = CseEnv -> IdEnv Id
ce_bndrMap CseEnv
env
norm_to :: Id
norm_to = IdEnv Id -> Id -> Id
normaliseId IdEnv Id
bndr_map Id
to
envLookup :: DataCon -> [OutStgArg] -> CseEnv -> Maybe OutId
envLookup :: DataCon -> [StgArg] -> CseEnv -> Maybe Id
envLookup DataCon
dataCon [StgArg]
args CseEnv
env
= Key ConAppMap -> ConAppMap Id -> Maybe Id
forall b. Key ConAppMap -> ConAppMap b -> Maybe b
forall (m :: * -> *) b. TrieMap m => Key m -> m b -> Maybe b
lookupTM (DataCon
dataCon, CseEnv -> [StgArg] -> [StgArg]
normaliseConArgs CseEnv
env [StgArg]
args)
(CseEnv -> ConAppMap Id
ce_conAppMap CseEnv
env)
addDataCon :: OutId -> DataCon -> [OutStgArg] -> CseEnv -> CseEnv
addDataCon :: Id -> DataCon -> [StgArg] -> CseEnv -> CseEnv
addDataCon Id
_ DataCon
_ [] CseEnv
env = CseEnv
env
addDataCon Id
bndr DataCon
dataCon [StgArg]
args CseEnv
env
= CseEnv
env { ce_conAppMap = new_env }
where
new_env :: ConAppMap Id
new_env = Key ConAppMap -> Id -> ConAppMap Id -> ConAppMap Id
forall (m :: * -> *) a. TrieMap m => Key m -> a -> m a -> m a
insertTM (DataCon
dataCon, CseEnv -> [StgArg] -> [StgArg]
normaliseConArgs CseEnv
env [StgArg]
args)
Id
bndr (CseEnv -> ConAppMap Id
ce_conAppMap CseEnv
env)
forgetCse :: CseEnv -> CseEnv
forgetCse :: CseEnv -> CseEnv
forgetCse CseEnv
env = CseEnv
env { ce_conAppMap = emptyTM }
addSubst :: OutId -> OutId -> CseEnv -> CseEnv
addSubst :: Id -> Id -> CseEnv -> CseEnv
addSubst Id
from Id
to CseEnv
env
= CseEnv
env { ce_subst = extendVarEnv (ce_subst env) from to }
substArgs :: CseEnv -> [InStgArg] -> [OutStgArg]
substArgs :: CseEnv -> [StgArg] -> [StgArg]
substArgs CseEnv
env = (StgArg -> StgArg) -> [StgArg] -> [StgArg]
forall a b. (a -> b) -> [a] -> [b]
map (CseEnv -> StgArg -> StgArg
substArg CseEnv
env)
substArg :: CseEnv -> InStgArg -> OutStgArg
substArg :: CseEnv -> StgArg -> StgArg
substArg CseEnv
env (StgVarArg Id
from) = Id -> StgArg
StgVarArg (CseEnv -> Id -> Id
substVar CseEnv
env Id
from)
substArg CseEnv
_ (StgLitArg Literal
lit) = Literal -> StgArg
StgLitArg Literal
lit
substVar :: CseEnv -> InId -> OutId
substVar :: CseEnv -> Id -> Id
substVar CseEnv
env Id
id = Id -> Maybe Id -> Id
forall a. a -> Maybe a -> a
fromMaybe Id
id (Maybe Id -> Id) -> Maybe Id -> Id
forall a b. (a -> b) -> a -> b
$ IdEnv Id -> Id -> Maybe Id
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv (CseEnv -> IdEnv Id
ce_subst CseEnv
env) Id
id
substBndr :: CseEnv -> InId -> (CseEnv, OutId)
substBndr :: CseEnv -> Id -> (CseEnv, Id)
substBndr CseEnv
env Id
old_id
= (CseEnv
new_env, Id
new_id)
where
new_id :: Id
new_id = InScopeSet -> Id -> Id
uniqAway (CseEnv -> InScopeSet
ce_in_scope CseEnv
env) Id
old_id
no_change :: Bool
no_change = Id
new_id Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
old_id
env' :: CseEnv
env' = CseEnv
env { ce_in_scope = ce_in_scope env `extendInScopeSet` new_id }
new_env :: CseEnv
new_env | Bool
no_change = CseEnv
env'
| Bool
otherwise = CseEnv
env' { ce_subst = extendVarEnv (ce_subst env) old_id new_id }
substBndrs :: CseEnv -> [InVar] -> (CseEnv, [OutVar])
substBndrs :: CseEnv -> [Id] -> (CseEnv, [Id])
substBndrs CseEnv
env [Id]
bndrs = (CseEnv -> Id -> (CseEnv, Id)) -> CseEnv -> [Id] -> (CseEnv, [Id])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL CseEnv -> Id -> (CseEnv, Id)
substBndr CseEnv
env [Id]
bndrs
substPairs :: CseEnv -> [(InVar, a)] -> (CseEnv, [(OutVar, a)])
substPairs :: forall a. CseEnv -> [(Id, a)] -> (CseEnv, [(Id, a)])
substPairs CseEnv
env [(Id, a)]
bndrs = (CseEnv -> (Id, a) -> (CseEnv, (Id, a)))
-> CseEnv -> [(Id, a)] -> (CseEnv, [(Id, a)])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL CseEnv -> (Id, a) -> (CseEnv, (Id, a))
forall {b}. CseEnv -> (Id, b) -> (CseEnv, (Id, b))
go CseEnv
env [(Id, a)]
bndrs
where go :: CseEnv -> (Id, b) -> (CseEnv, (Id, b))
go CseEnv
env (Id
id, b
x) = let (CseEnv
env', Id
id') = CseEnv -> Id -> (CseEnv, Id)
substBndr CseEnv
env Id
id
in (CseEnv
env', (Id
id', b
x))
stgCse :: [InStgTopBinding] -> [OutStgTopBinding]
stgCse :: [InStgTopBinding] -> [InStgTopBinding]
stgCse [InStgTopBinding]
binds = (InScopeSet, [InStgTopBinding]) -> [InStgTopBinding]
forall a b. (a, b) -> b
snd ((InScopeSet, [InStgTopBinding]) -> [InStgTopBinding])
-> (InScopeSet, [InStgTopBinding]) -> [InStgTopBinding]
forall a b. (a -> b) -> a -> b
$ (InScopeSet -> InStgTopBinding -> (InScopeSet, InStgTopBinding))
-> InScopeSet
-> [InStgTopBinding]
-> (InScopeSet, [InStgTopBinding])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL InScopeSet -> InStgTopBinding -> (InScopeSet, InStgTopBinding)
stgCseTopLvl InScopeSet
emptyInScopeSet [InStgTopBinding]
binds
stgCseTopLvl :: InScopeSet -> InStgTopBinding -> (InScopeSet, OutStgTopBinding)
stgCseTopLvl :: InScopeSet -> InStgTopBinding -> (InScopeSet, InStgTopBinding)
stgCseTopLvl InScopeSet
in_scope t :: InStgTopBinding
t@(StgTopStringLit Id
_ ByteString
_) = (InScopeSet
in_scope, InStgTopBinding
t)
stgCseTopLvl InScopeSet
in_scope (StgTopLifted (StgNonRec BinderP 'Vanilla
bndr GenStgRhs 'Vanilla
rhs))
= (InScopeSet
in_scope'
, GenStgBinding 'Vanilla -> InStgTopBinding
forall (pass :: StgPass).
GenStgBinding pass -> GenStgTopBinding pass
StgTopLifted (BinderP 'Vanilla -> GenStgRhs 'Vanilla -> GenStgBinding 'Vanilla
forall (pass :: StgPass).
BinderP pass -> GenStgRhs pass -> GenStgBinding pass
StgNonRec BinderP 'Vanilla
bndr (InScopeSet -> GenStgRhs 'Vanilla -> GenStgRhs 'Vanilla
stgCseTopLvlRhs InScopeSet
in_scope GenStgRhs 'Vanilla
rhs)))
where in_scope' :: InScopeSet
in_scope' = InScopeSet
in_scope InScopeSet -> Id -> InScopeSet
`extendInScopeSet` Id
BinderP 'Vanilla
bndr
stgCseTopLvl InScopeSet
in_scope (StgTopLifted (StgRec [(BinderP 'Vanilla, GenStgRhs 'Vanilla)]
eqs))
= ( InScopeSet
in_scope'
, GenStgBinding 'Vanilla -> InStgTopBinding
forall (pass :: StgPass).
GenStgBinding pass -> GenStgTopBinding pass
StgTopLifted ([(BinderP 'Vanilla, GenStgRhs 'Vanilla)] -> GenStgBinding 'Vanilla
forall (pass :: StgPass).
[(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass
StgRec [ (Id
BinderP 'Vanilla
bndr, InScopeSet -> GenStgRhs 'Vanilla -> GenStgRhs 'Vanilla
stgCseTopLvlRhs InScopeSet
in_scope' GenStgRhs 'Vanilla
rhs) | (Id
bndr, GenStgRhs 'Vanilla
rhs) <- [(Id, GenStgRhs 'Vanilla)]
[(BinderP 'Vanilla, GenStgRhs 'Vanilla)]
eqs ]))
where in_scope' :: InScopeSet
in_scope' = InScopeSet
in_scope InScopeSet -> [Id] -> InScopeSet
`extendInScopeSetList` [ Id
bndr | (Id
bndr, GenStgRhs 'Vanilla
_) <- [(Id, GenStgRhs 'Vanilla)]
[(BinderP 'Vanilla, GenStgRhs 'Vanilla)]
eqs ]
stgCseTopLvlRhs :: InScopeSet -> InStgRhs -> OutStgRhs
stgCseTopLvlRhs :: InScopeSet -> GenStgRhs 'Vanilla -> GenStgRhs 'Vanilla
stgCseTopLvlRhs InScopeSet
in_scope (StgRhsClosure XRhsClosure 'Vanilla
ext CostCentreStack
ccs UpdateFlag
upd [BinderP 'Vanilla]
args GenStgExpr 'Vanilla
body)
= let body' :: GenStgExpr 'Vanilla
body' = CseEnv -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
stgCseExpr (InScopeSet -> CseEnv
initEnv InScopeSet
in_scope) GenStgExpr 'Vanilla
body
in XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> GenStgExpr 'Vanilla
-> GenStgRhs 'Vanilla
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
ext CostCentreStack
ccs UpdateFlag
upd [BinderP 'Vanilla]
args GenStgExpr 'Vanilla
body'
stgCseTopLvlRhs InScopeSet
_ (StgRhsCon CostCentreStack
ccs DataCon
dataCon ConstructorNumber
mu [StgTickish]
ticks [StgArg]
args)
= CostCentreStack
-> DataCon
-> ConstructorNumber
-> [StgTickish]
-> [StgArg]
-> GenStgRhs 'Vanilla
forall (pass :: StgPass).
CostCentreStack
-> DataCon
-> ConstructorNumber
-> [StgTickish]
-> [StgArg]
-> GenStgRhs pass
StgRhsCon CostCentreStack
ccs DataCon
dataCon ConstructorNumber
mu [StgTickish]
ticks [StgArg]
args
stgCseExpr :: CseEnv -> InStgExpr -> OutStgExpr
stgCseExpr :: CseEnv -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
stgCseExpr CseEnv
env (StgApp Id
fun [StgArg]
args)
= Id -> [StgArg] -> GenStgExpr 'Vanilla
forall (pass :: StgPass). Id -> [StgArg] -> GenStgExpr pass
StgApp Id
fun' [StgArg]
args'
where fun' :: Id
fun' = CseEnv -> Id -> Id
substVar CseEnv
env Id
fun
args' :: [StgArg]
args' = CseEnv -> [StgArg] -> [StgArg]
substArgs CseEnv
env [StgArg]
args
stgCseExpr CseEnv
_ (StgLit Literal
lit)
= Literal -> GenStgExpr 'Vanilla
forall (pass :: StgPass). Literal -> GenStgExpr pass
StgLit Literal
lit
stgCseExpr CseEnv
env (StgOpApp StgOp
op [StgArg]
args Type
tys)
= StgOp -> [StgArg] -> Type -> GenStgExpr 'Vanilla
forall (pass :: StgPass).
StgOp -> [StgArg] -> Type -> GenStgExpr pass
StgOpApp StgOp
op [StgArg]
args' Type
tys
where args' :: [StgArg]
args' = CseEnv -> [StgArg] -> [StgArg]
substArgs CseEnv
env [StgArg]
args
stgCseExpr CseEnv
env (StgTick StgTickish
tick GenStgExpr 'Vanilla
body)
= let body' :: GenStgExpr 'Vanilla
body' = CseEnv -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
stgCseExpr CseEnv
env GenStgExpr 'Vanilla
body
in StgTickish -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
forall (pass :: StgPass).
StgTickish -> GenStgExpr pass -> GenStgExpr pass
StgTick StgTickish
tick GenStgExpr 'Vanilla
body'
stgCseExpr CseEnv
env (StgCase GenStgExpr 'Vanilla
scrut BinderP 'Vanilla
bndr AltType
ty [GenStgAlt 'Vanilla]
alts)
= GenStgExpr 'Vanilla
-> Id -> AltType -> [GenStgAlt 'Vanilla] -> GenStgExpr 'Vanilla
mkStgCase GenStgExpr 'Vanilla
scrut' Id
bndr' AltType
ty [GenStgAlt 'Vanilla]
alts'
where
scrut' :: GenStgExpr 'Vanilla
scrut' = CseEnv -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
stgCseExpr CseEnv
env GenStgExpr 'Vanilla
scrut
(CseEnv
env1, Id
bndr') = CseEnv -> Id -> (CseEnv, Id)
substBndr CseEnv
env Id
BinderP 'Vanilla
bndr
env2 :: CseEnv
env2 | StgApp Id
trivial_scrut [] <- GenStgExpr 'Vanilla
scrut'
= Id -> Id -> CseEnv -> CseEnv
addTrivCaseBndr Id
BinderP 'Vanilla
bndr Id
trivial_scrut CseEnv
env1
| Bool
otherwise
= CseEnv
env1
alts' :: [GenStgAlt 'Vanilla]
alts' = (GenStgAlt 'Vanilla -> GenStgAlt 'Vanilla)
-> [GenStgAlt 'Vanilla] -> [GenStgAlt 'Vanilla]
forall a b. (a -> b) -> [a] -> [b]
map (CseEnv -> AltType -> Id -> GenStgAlt 'Vanilla -> GenStgAlt 'Vanilla
stgCseAlt CseEnv
env2 AltType
ty Id
bndr') [GenStgAlt 'Vanilla]
alts
stgCseExpr CseEnv
env (StgConApp DataCon
dataCon ConstructorNumber
n [StgArg]
args [Type]
tys)
| Just Id
bndr' <- DataCon -> [StgArg] -> CseEnv -> Maybe Id
envLookup DataCon
dataCon [StgArg]
args' CseEnv
env
= Id -> [StgArg] -> GenStgExpr 'Vanilla
forall (pass :: StgPass). Id -> [StgArg] -> GenStgExpr pass
StgApp Id
bndr' []
| Bool
otherwise
= DataCon
-> ConstructorNumber -> [StgArg] -> [Type] -> GenStgExpr 'Vanilla
forall (pass :: StgPass).
DataCon
-> ConstructorNumber -> [StgArg] -> [Type] -> GenStgExpr pass
StgConApp DataCon
dataCon ConstructorNumber
n [StgArg]
args' [Type]
tys
where args' :: [StgArg]
args' = CseEnv -> [StgArg] -> [StgArg]
substArgs CseEnv
env [StgArg]
args
stgCseExpr CseEnv
env (StgLet XLet 'Vanilla
ext GenStgBinding 'Vanilla
binds GenStgExpr 'Vanilla
body)
= let (Maybe (GenStgBinding 'Vanilla)
binds', CseEnv
env') = CseEnv
-> GenStgBinding 'Vanilla
-> (Maybe (GenStgBinding 'Vanilla), CseEnv)
stgCseBind CseEnv
env GenStgBinding 'Vanilla
binds
body' :: GenStgExpr 'Vanilla
body' = CseEnv -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
stgCseExpr CseEnv
env' GenStgExpr 'Vanilla
body
in (GenStgBinding 'Vanilla
-> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> Maybe (GenStgBinding 'Vanilla)
-> GenStgExpr 'Vanilla
-> GenStgExpr 'Vanilla
forall a b. (a -> b -> b) -> Maybe a -> b -> b
mkStgLet (XLet 'Vanilla
-> GenStgBinding 'Vanilla
-> GenStgExpr 'Vanilla
-> GenStgExpr 'Vanilla
forall (pass :: StgPass).
XLet pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLet XLet 'Vanilla
ext) Maybe (GenStgBinding 'Vanilla)
binds' GenStgExpr 'Vanilla
body'
stgCseExpr CseEnv
env (StgLetNoEscape XLetNoEscape 'Vanilla
ext GenStgBinding 'Vanilla
binds GenStgExpr 'Vanilla
body)
= let (Maybe (GenStgBinding 'Vanilla)
binds', CseEnv
env') = CseEnv
-> GenStgBinding 'Vanilla
-> (Maybe (GenStgBinding 'Vanilla), CseEnv)
stgCseBind CseEnv
env GenStgBinding 'Vanilla
binds
body' :: GenStgExpr 'Vanilla
body' = CseEnv -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
stgCseExpr CseEnv
env' GenStgExpr 'Vanilla
body
in (GenStgBinding 'Vanilla
-> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> Maybe (GenStgBinding 'Vanilla)
-> GenStgExpr 'Vanilla
-> GenStgExpr 'Vanilla
forall a b. (a -> b -> b) -> Maybe a -> b -> b
mkStgLet (XLetNoEscape 'Vanilla
-> GenStgBinding 'Vanilla
-> GenStgExpr 'Vanilla
-> GenStgExpr 'Vanilla
forall (pass :: StgPass).
XLetNoEscape pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLetNoEscape XLetNoEscape 'Vanilla
ext) Maybe (GenStgBinding 'Vanilla)
binds' GenStgExpr 'Vanilla
body'
stgCseAlt :: CseEnv -> AltType -> OutId -> InStgAlt -> OutStgAlt
stgCseAlt :: CseEnv -> AltType -> Id -> GenStgAlt 'Vanilla -> GenStgAlt 'Vanilla
stgCseAlt CseEnv
env AltType
ty Id
case_bndr GenStgAlt{alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con=DataAlt DataCon
dataCon, alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs=[BinderP 'Vanilla]
args, alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs=GenStgExpr 'Vanilla
rhs}
= let (CseEnv
env1, [Id]
args') = CseEnv -> [Id] -> (CseEnv, [Id])
substBndrs CseEnv
env [Id]
[BinderP 'Vanilla]
args
env2 :: CseEnv
env2
| AltType -> Bool -> Bool
stgCaseBndrInScope AltType
ty Bool
True
= Id -> DataCon -> [StgArg] -> CseEnv -> CseEnv
addDataCon Id
case_bndr DataCon
dataCon ((Id -> StgArg) -> [Id] -> [StgArg]
forall a b. (a -> b) -> [a] -> [b]
map Id -> StgArg
StgVarArg [Id]
args') CseEnv
env1
| Bool
otherwise
= CseEnv
env1
rhs' :: GenStgExpr 'Vanilla
rhs' = CseEnv -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
stgCseExpr CseEnv
env2 GenStgExpr 'Vanilla
rhs
in AltCon
-> [BinderP 'Vanilla] -> GenStgExpr 'Vanilla -> GenStgAlt 'Vanilla
forall (pass :: StgPass).
AltCon -> [BinderP pass] -> GenStgExpr pass -> GenStgAlt pass
GenStgAlt (DataCon -> AltCon
DataAlt DataCon
dataCon) [Id]
[BinderP 'Vanilla]
args' GenStgExpr 'Vanilla
rhs'
stgCseAlt CseEnv
env AltType
_ Id
_ g :: GenStgAlt 'Vanilla
g@GenStgAlt{alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con=AltCon
_, alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs=[BinderP 'Vanilla]
args, alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs=GenStgExpr 'Vanilla
rhs}
= let (CseEnv
env1, [Id]
args') = CseEnv -> [Id] -> (CseEnv, [Id])
substBndrs CseEnv
env [Id]
[BinderP 'Vanilla]
args
rhs' :: GenStgExpr 'Vanilla
rhs' = CseEnv -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
stgCseExpr CseEnv
env1 GenStgExpr 'Vanilla
rhs
in GenStgAlt 'Vanilla
g {alt_bndrs=args', alt_rhs=rhs'}
stgCseBind :: CseEnv -> InStgBinding -> (Maybe OutStgBinding, CseEnv)
stgCseBind :: CseEnv
-> GenStgBinding 'Vanilla
-> (Maybe (GenStgBinding 'Vanilla), CseEnv)
stgCseBind CseEnv
env (StgNonRec BinderP 'Vanilla
b GenStgRhs 'Vanilla
e)
= let (CseEnv
env1, Id
b') = CseEnv -> Id -> (CseEnv, Id)
substBndr CseEnv
env Id
BinderP 'Vanilla
b
in case CseEnv
-> Id
-> GenStgRhs 'Vanilla
-> (Maybe (Id, GenStgRhs 'Vanilla), CseEnv)
stgCseRhs CseEnv
env1 Id
b' GenStgRhs 'Vanilla
e of
(Maybe (Id, GenStgRhs 'Vanilla)
Nothing, CseEnv
env2) -> (Maybe (GenStgBinding 'Vanilla)
forall a. Maybe a
Nothing, CseEnv
env2)
(Just (Id
b2,GenStgRhs 'Vanilla
e'), CseEnv
env2) -> (GenStgBinding 'Vanilla -> Maybe (GenStgBinding 'Vanilla)
forall a. a -> Maybe a
Just (BinderP 'Vanilla -> GenStgRhs 'Vanilla -> GenStgBinding 'Vanilla
forall (pass :: StgPass).
BinderP pass -> GenStgRhs pass -> GenStgBinding pass
StgNonRec Id
BinderP 'Vanilla
b2 GenStgRhs 'Vanilla
e'), CseEnv
env2)
stgCseBind CseEnv
env (StgRec [(BinderP 'Vanilla, GenStgRhs 'Vanilla)]
pairs)
= let (CseEnv
env1, [(Id, GenStgRhs 'Vanilla)]
pairs1) = CseEnv
-> [(Id, GenStgRhs 'Vanilla)]
-> (CseEnv, [(Id, GenStgRhs 'Vanilla)])
forall a. CseEnv -> [(Id, a)] -> (CseEnv, [(Id, a)])
substPairs CseEnv
env [(Id, GenStgRhs 'Vanilla)]
[(BinderP 'Vanilla, GenStgRhs 'Vanilla)]
pairs
in case CseEnv
-> [(Id, GenStgRhs 'Vanilla)]
-> ([(Id, GenStgRhs 'Vanilla)], CseEnv)
stgCsePairs CseEnv
env1 [(Id, GenStgRhs 'Vanilla)]
pairs1 of
([], CseEnv
env2) -> (Maybe (GenStgBinding 'Vanilla)
forall a. Maybe a
Nothing, CseEnv
env2)
([(Id, GenStgRhs 'Vanilla)]
pairs2, CseEnv
env2) -> (GenStgBinding 'Vanilla -> Maybe (GenStgBinding 'Vanilla)
forall a. a -> Maybe a
Just ([(BinderP 'Vanilla, GenStgRhs 'Vanilla)] -> GenStgBinding 'Vanilla
forall (pass :: StgPass).
[(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass
StgRec [(Id, GenStgRhs 'Vanilla)]
[(BinderP 'Vanilla, GenStgRhs 'Vanilla)]
pairs2), CseEnv
env2)
stgCsePairs :: CseEnv -> [(OutId, InStgRhs)] -> ([(OutId, OutStgRhs)], CseEnv)
stgCsePairs :: CseEnv
-> [(Id, GenStgRhs 'Vanilla)]
-> ([(Id, GenStgRhs 'Vanilla)], CseEnv)
stgCsePairs CseEnv
env [] = ([], CseEnv
env)
stgCsePairs CseEnv
env0 ((Id
b,GenStgRhs 'Vanilla
e):[(Id, GenStgRhs 'Vanilla)]
pairs)
= let (Maybe (Id, GenStgRhs 'Vanilla)
pairMB, CseEnv
env1) = CseEnv
-> Id
-> GenStgRhs 'Vanilla
-> (Maybe (Id, GenStgRhs 'Vanilla), CseEnv)
stgCseRhs CseEnv
env0 Id
b GenStgRhs 'Vanilla
e
([(Id, GenStgRhs 'Vanilla)]
pairs', CseEnv
env2) = CseEnv
-> [(Id, GenStgRhs 'Vanilla)]
-> ([(Id, GenStgRhs 'Vanilla)], CseEnv)
stgCsePairs CseEnv
env1 [(Id, GenStgRhs 'Vanilla)]
pairs
in (Maybe (Id, GenStgRhs 'Vanilla)
pairMB Maybe (Id, GenStgRhs 'Vanilla)
-> [(Id, GenStgRhs 'Vanilla)] -> [(Id, GenStgRhs 'Vanilla)]
forall {a}. Maybe a -> [a] -> [a]
`mbCons` [(Id, GenStgRhs 'Vanilla)]
pairs', CseEnv
env2)
where
mbCons :: Maybe a -> [a] -> [a]
mbCons = ([a] -> [a]) -> (a -> [a] -> [a]) -> Maybe a -> [a] -> [a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [a] -> [a]
forall a. a -> a
id (:)
stgCseRhs :: CseEnv -> OutId -> InStgRhs -> (Maybe (OutId, OutStgRhs), CseEnv)
stgCseRhs :: CseEnv
-> Id
-> GenStgRhs 'Vanilla
-> (Maybe (Id, GenStgRhs 'Vanilla), CseEnv)
stgCseRhs CseEnv
env Id
bndr (StgRhsCon CostCentreStack
ccs DataCon
dataCon ConstructorNumber
mu [StgTickish]
ticks [StgArg]
args)
| Just Id
other_bndr <- DataCon -> [StgArg] -> CseEnv -> Maybe Id
envLookup DataCon
dataCon [StgArg]
args' CseEnv
env
, Bool -> Bool
not (OccInfo -> Bool
isWeakLoopBreaker (Id -> OccInfo
idOccInfo Id
bndr))
= let env' :: CseEnv
env' = Id -> Id -> CseEnv -> CseEnv
addSubst Id
bndr Id
other_bndr CseEnv
env
in (Maybe (Id, GenStgRhs 'Vanilla)
forall a. Maybe a
Nothing, CseEnv
env')
| Bool
otherwise
= let env' :: CseEnv
env' = Id -> DataCon -> [StgArg] -> CseEnv -> CseEnv
addDataCon Id
bndr DataCon
dataCon [StgArg]
args' CseEnv
env
pair :: (Id, GenStgRhs 'Vanilla)
pair = (Id
bndr, CostCentreStack
-> DataCon
-> ConstructorNumber
-> [StgTickish]
-> [StgArg]
-> GenStgRhs 'Vanilla
forall (pass :: StgPass).
CostCentreStack
-> DataCon
-> ConstructorNumber
-> [StgTickish]
-> [StgArg]
-> GenStgRhs pass
StgRhsCon CostCentreStack
ccs DataCon
dataCon ConstructorNumber
mu [StgTickish]
ticks [StgArg]
args')
in ((Id, GenStgRhs 'Vanilla) -> Maybe (Id, GenStgRhs 'Vanilla)
forall a. a -> Maybe a
Just (Id, GenStgRhs 'Vanilla)
pair, CseEnv
env')
where args' :: [StgArg]
args' = CseEnv -> [StgArg] -> [StgArg]
substArgs CseEnv
env [StgArg]
args
stgCseRhs CseEnv
env Id
bndr (StgRhsClosure XRhsClosure 'Vanilla
ext CostCentreStack
ccs UpdateFlag
upd [BinderP 'Vanilla]
args GenStgExpr 'Vanilla
body)
= let (CseEnv
env1, [Id]
args') = CseEnv -> [Id] -> (CseEnv, [Id])
substBndrs CseEnv
env [Id]
[BinderP 'Vanilla]
args
env2 :: CseEnv
env2 = CseEnv -> CseEnv
forgetCse CseEnv
env1
body' :: GenStgExpr 'Vanilla
body' = CseEnv -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
stgCseExpr CseEnv
env2 GenStgExpr 'Vanilla
body
in ((Id, GenStgRhs 'Vanilla) -> Maybe (Id, GenStgRhs 'Vanilla)
forall a. a -> Maybe a
Just (CseEnv -> Id -> Id
substVar CseEnv
env Id
bndr, XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> GenStgExpr 'Vanilla
-> GenStgRhs 'Vanilla
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
ext CostCentreStack
ccs UpdateFlag
upd [Id]
[BinderP 'Vanilla]
args' GenStgExpr 'Vanilla
body'), CseEnv
env)
mkStgCase :: StgExpr -> OutId -> AltType -> [StgAlt] -> StgExpr
mkStgCase :: GenStgExpr 'Vanilla
-> Id -> AltType -> [GenStgAlt 'Vanilla] -> GenStgExpr 'Vanilla
mkStgCase GenStgExpr 'Vanilla
scrut Id
bndr AltType
ty [GenStgAlt 'Vanilla]
alts | (GenStgAlt 'Vanilla -> Bool) -> [GenStgAlt 'Vanilla] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all GenStgAlt 'Vanilla -> Bool
isBndr [GenStgAlt 'Vanilla]
alts = GenStgExpr 'Vanilla
scrut
| Bool
otherwise = GenStgExpr 'Vanilla
-> BinderP 'Vanilla
-> AltType
-> [GenStgAlt 'Vanilla]
-> GenStgExpr 'Vanilla
forall (pass :: StgPass).
GenStgExpr pass
-> BinderP pass -> AltType -> [GenStgAlt pass] -> GenStgExpr pass
StgCase GenStgExpr 'Vanilla
scrut Id
BinderP 'Vanilla
bndr AltType
ty [GenStgAlt 'Vanilla]
alts
where
isBndr :: GenStgAlt 'Vanilla -> Bool
isBndr GenStgAlt{alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con=AltCon
_,alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs=[BinderP 'Vanilla]
_,alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs=StgApp Id
f []} = Id
f Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
bndr
isBndr GenStgAlt 'Vanilla
_ = Bool
False
mkStgLet :: (a -> b -> b) -> Maybe a -> b -> b
mkStgLet :: forall a b. (a -> b -> b) -> Maybe a -> b -> b
mkStgLet a -> b -> b
_ Maybe a
Nothing b
body = b
body
mkStgLet a -> b -> b
stgLet (Just a
binds) b
body = a -> b -> b
stgLet a
binds b
body