module GHC.Stg.Lift
(
StgLiftConfig (..),
stgLiftLams
)
where
import GHC.Prelude
import GHC.Types.Basic
import GHC.Types.Id
import GHC.Stg.FVs ( annBindingFreeVars )
import GHC.Stg.Lift.Config
import GHC.Stg.Lift.Analysis
import GHC.Stg.Lift.Monad
import GHC.Stg.Syntax
import GHC.Unit.Module (Module)
import GHC.Types.Unique.Supply
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Types.Var.Set
import Control.Monad ( when )
import Data.Maybe ( isNothing )
stgLiftLams :: Module -> StgLiftConfig -> UniqSupply -> [InStgTopBinding] -> [OutStgTopBinding]
stgLiftLams :: Module
-> StgLiftConfig
-> UniqSupply
-> [InStgTopBinding]
-> [InStgTopBinding]
stgLiftLams Module
this_mod StgLiftConfig
cfg UniqSupply
us = StgLiftConfig -> UniqSupply -> LiftM () -> [InStgTopBinding]
runLiftM StgLiftConfig
cfg UniqSupply
us (LiftM () -> [InStgTopBinding])
-> ([InStgTopBinding] -> LiftM ())
-> [InStgTopBinding]
-> [InStgTopBinding]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InStgTopBinding -> LiftM () -> LiftM ())
-> LiftM () -> [InStgTopBinding] -> LiftM ()
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Module -> InStgTopBinding -> LiftM () -> LiftM ()
liftTopLvl Module
this_mod) (() -> LiftM ()
forall a. a -> LiftM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
liftTopLvl :: Module -> InStgTopBinding -> LiftM () -> LiftM ()
liftTopLvl :: Module -> InStgTopBinding -> LiftM () -> LiftM ()
liftTopLvl Module
_ (StgTopStringLit Id
bndr ByteString
lit) LiftM ()
rest = Id -> (Id -> LiftM ()) -> LiftM ()
forall a. Id -> (Id -> LiftM a) -> LiftM a
withSubstBndr Id
bndr ((Id -> LiftM ()) -> LiftM ()) -> (Id -> LiftM ()) -> LiftM ()
forall a b. (a -> b) -> a -> b
$ \Id
bndr' -> do
Id -> ByteString -> LiftM ()
addTopStringLit Id
bndr' ByteString
lit
LiftM ()
rest
liftTopLvl Module
this_mod (StgTopLifted GenStgBinding 'Vanilla
bind) LiftM ()
rest = do
let is_rec :: Bool
is_rec = RecFlag -> Bool
isRec (RecFlag -> Bool) -> RecFlag -> Bool
forall a b. (a -> b) -> a -> b
$ (RecFlag, [(Id, GenStgRhs 'Vanilla)]) -> RecFlag
forall a b. (a, b) -> a
fst ((RecFlag, [(Id, GenStgRhs 'Vanilla)]) -> RecFlag)
-> (RecFlag, [(Id, GenStgRhs 'Vanilla)]) -> RecFlag
forall a b. (a -> b) -> a -> b
$ GenStgBinding 'Vanilla
-> (RecFlag, [(BinderP 'Vanilla, GenStgRhs 'Vanilla)])
forall (pass :: StgPass).
GenStgBinding pass -> (RecFlag, [(BinderP pass, GenStgRhs pass)])
decomposeStgBinding GenStgBinding 'Vanilla
bind
Bool -> LiftM () -> LiftM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
is_rec LiftM ()
startBindingGroup
let bind_w_fvs :: CgStgBinding
bind_w_fvs = Module -> GenStgBinding 'Vanilla -> CgStgBinding
annBindingFreeVars Module
this_mod GenStgBinding 'Vanilla
bind
TopLevelFlag
-> LlStgBinding
-> Skeleton
-> (Maybe (GenStgBinding 'Vanilla) -> LiftM ())
-> LiftM ()
forall a.
TopLevelFlag
-> LlStgBinding
-> Skeleton
-> (Maybe (GenStgBinding 'Vanilla) -> LiftM a)
-> LiftM a
withLiftedBind TopLevelFlag
TopLevel (CgStgBinding -> LlStgBinding
tagSkeletonTopBind CgStgBinding
bind_w_fvs) Skeleton
NilSk ((Maybe (GenStgBinding 'Vanilla) -> LiftM ()) -> LiftM ())
-> (Maybe (GenStgBinding 'Vanilla) -> LiftM ()) -> LiftM ()
forall a b. (a -> b) -> a -> b
$ \Maybe (GenStgBinding 'Vanilla)
mb_bind' -> do
case Maybe (GenStgBinding 'Vanilla)
mb_bind' of
Maybe (GenStgBinding 'Vanilla)
Nothing -> String -> SDoc -> LiftM ()
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"StgLiftLams" (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Lifted top-level binding")
Just GenStgBinding 'Vanilla
bind' -> GenStgBinding 'Vanilla -> LiftM ()
addLiftedBinding GenStgBinding 'Vanilla
bind'
Bool -> LiftM () -> LiftM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
is_rec LiftM ()
endBindingGroup
LiftM ()
rest
withLiftedBind
:: TopLevelFlag
-> LlStgBinding
-> Skeleton
-> (Maybe OutStgBinding -> LiftM a)
-> LiftM a
withLiftedBind :: forall a.
TopLevelFlag
-> LlStgBinding
-> Skeleton
-> (Maybe (GenStgBinding 'Vanilla) -> LiftM a)
-> LiftM a
withLiftedBind TopLevelFlag
top_lvl LlStgBinding
bind Skeleton
scope Maybe (GenStgBinding 'Vanilla) -> LiftM a
k
= TopLevelFlag
-> RecFlag
-> [(BinderInfo, LlStgRhs)]
-> Skeleton
-> (Maybe [(Id, GenStgRhs 'Vanilla)] -> LiftM a)
-> LiftM a
forall a.
TopLevelFlag
-> RecFlag
-> [(BinderInfo, LlStgRhs)]
-> Skeleton
-> (Maybe [(Id, GenStgRhs 'Vanilla)] -> LiftM a)
-> LiftM a
withLiftedBindPairs TopLevelFlag
top_lvl RecFlag
rec [(BinderInfo, LlStgRhs)]
[(BinderP 'LiftLams, LlStgRhs)]
pairs Skeleton
scope (Maybe (GenStgBinding 'Vanilla) -> LiftM a
k (Maybe (GenStgBinding 'Vanilla) -> LiftM a)
-> (Maybe [(Id, GenStgRhs 'Vanilla)]
-> Maybe (GenStgBinding 'Vanilla))
-> Maybe [(Id, GenStgRhs 'Vanilla)]
-> LiftM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Id, GenStgRhs 'Vanilla)] -> GenStgBinding 'Vanilla)
-> Maybe [(Id, GenStgRhs 'Vanilla)]
-> Maybe (GenStgBinding 'Vanilla)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RecFlag
-> [(BinderP 'Vanilla, GenStgRhs 'Vanilla)]
-> GenStgBinding 'Vanilla
forall (pass :: StgPass).
RecFlag -> [(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass
mkStgBinding RecFlag
rec))
where
(RecFlag
rec, [(BinderP 'LiftLams, LlStgRhs)]
pairs) = LlStgBinding -> (RecFlag, [(BinderP 'LiftLams, LlStgRhs)])
forall (pass :: StgPass).
GenStgBinding pass -> (RecFlag, [(BinderP pass, GenStgRhs pass)])
decomposeStgBinding LlStgBinding
bind
withLiftedBindPairs
:: TopLevelFlag
-> RecFlag
-> [(BinderInfo, LlStgRhs)]
-> Skeleton
-> (Maybe [(Id, OutStgRhs)] -> LiftM a)
-> LiftM a
withLiftedBindPairs :: forall a.
TopLevelFlag
-> RecFlag
-> [(BinderInfo, LlStgRhs)]
-> Skeleton
-> (Maybe [(Id, GenStgRhs 'Vanilla)] -> LiftM a)
-> LiftM a
withLiftedBindPairs TopLevelFlag
top RecFlag
rec [(BinderInfo, LlStgRhs)]
pairs Skeleton
scope Maybe [(Id, GenStgRhs 'Vanilla)] -> LiftM a
k = do
let ([BinderInfo]
infos, [LlStgRhs]
rhss) = [(BinderInfo, LlStgRhs)] -> ([BinderInfo], [LlStgRhs])
forall a b. [(a, b)] -> ([a], [b])
unzip [(BinderInfo, LlStgRhs)]
pairs
let bndrs :: [Id]
bndrs = (BinderInfo -> Id) -> [BinderInfo] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map BinderInfo -> Id
binderInfoBndr [BinderInfo]
infos
expander <- LiftM (DIdSet -> DIdSet)
liftedIdsExpander
cfg <- getConfig
case goodToLift cfg top rec expander pairs scope of
Just DIdSet
abs_ids -> DIdSet -> [Id] -> ([Id] -> LiftM a) -> LiftM a
forall (f :: * -> *) a.
Traversable f =>
DIdSet -> f Id -> (f Id -> LiftM a) -> LiftM a
withLiftedBndrs DIdSet
abs_ids [Id]
bndrs (([Id] -> LiftM a) -> LiftM a) -> ([Id] -> LiftM a) -> LiftM a
forall a b. (a -> b) -> a -> b
$ \[Id]
bndrs' -> do
Bool -> LiftM () -> LiftM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RecFlag -> Bool
isRec RecFlag
rec) LiftM ()
startBindingGroup
rhss' <- (LlStgRhs -> LiftM (GenStgRhs 'Vanilla))
-> [LlStgRhs] -> LiftM [GenStgRhs 'Vanilla]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Maybe DIdSet -> LlStgRhs -> LiftM (GenStgRhs 'Vanilla)
liftRhs (DIdSet -> Maybe DIdSet
forall a. a -> Maybe a
Just DIdSet
abs_ids)) [LlStgRhs]
rhss
let pairs' = [Id] -> [GenStgRhs 'Vanilla] -> [(Id, GenStgRhs 'Vanilla)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
bndrs' [GenStgRhs 'Vanilla]
rhss'
addLiftedBinding (mkStgBinding rec pairs')
when (isRec rec) endBindingGroup
k Nothing
Maybe DIdSet
Nothing -> [Id] -> ([Id] -> LiftM a) -> LiftM a
forall (f :: * -> *) a.
Traversable f =>
f Id -> (f Id -> LiftM a) -> LiftM a
withSubstBndrs [Id]
bndrs (([Id] -> LiftM a) -> LiftM a) -> ([Id] -> LiftM a) -> LiftM a
forall a b. (a -> b) -> a -> b
$ \[Id]
bndrs' -> do
rhss' <- (LlStgRhs -> LiftM (GenStgRhs 'Vanilla))
-> [LlStgRhs] -> LiftM [GenStgRhs 'Vanilla]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Maybe DIdSet -> LlStgRhs -> LiftM (GenStgRhs 'Vanilla)
liftRhs Maybe DIdSet
forall a. Maybe a
Nothing) [LlStgRhs]
rhss
let pairs' = [Id] -> [GenStgRhs 'Vanilla] -> [(Id, GenStgRhs 'Vanilla)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
bndrs' [GenStgRhs 'Vanilla]
rhss'
k (Just pairs')
liftRhs
:: Maybe (DIdSet)
-> LlStgRhs
-> LiftM OutStgRhs
liftRhs :: Maybe DIdSet -> LlStgRhs -> LiftM (GenStgRhs 'Vanilla)
liftRhs Maybe DIdSet
mb_former_fvs rhs :: LlStgRhs
rhs@(StgRhsCon CostCentreStack
ccs DataCon
con ConstructorNumber
mn [StgTickish]
ts [StgArg]
args Type
typ)
= Bool
-> SDoc -> LiftM (GenStgRhs 'Vanilla) -> LiftM (GenStgRhs 'Vanilla)
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Maybe DIdSet -> Bool
forall a. Maybe a -> Bool
isNothing Maybe DIdSet
mb_former_fvs)
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Should never lift a constructor"
SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ StgPprOpts -> LlStgRhs -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> GenStgRhs pass -> SDoc
pprStgRhs StgPprOpts
panicStgPprOpts LlStgRhs
rhs) (LiftM (GenStgRhs 'Vanilla) -> LiftM (GenStgRhs 'Vanilla))
-> LiftM (GenStgRhs 'Vanilla) -> LiftM (GenStgRhs 'Vanilla)
forall a b. (a -> b) -> a -> b
$
CostCentreStack
-> DataCon
-> ConstructorNumber
-> [StgTickish]
-> [StgArg]
-> Type
-> GenStgRhs 'Vanilla
forall (pass :: StgPass).
CostCentreStack
-> DataCon
-> ConstructorNumber
-> [StgTickish]
-> [StgArg]
-> Type
-> GenStgRhs pass
StgRhsCon CostCentreStack
ccs DataCon
con ConstructorNumber
mn [StgTickish]
ts ([StgArg] -> Type -> GenStgRhs 'Vanilla)
-> LiftM [StgArg] -> LiftM (Type -> GenStgRhs 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (StgArg -> LiftM StgArg) -> [StgArg] -> LiftM [StgArg]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse StgArg -> LiftM StgArg
liftArgs [StgArg]
args LiftM (Type -> GenStgRhs 'Vanilla)
-> LiftM Type -> LiftM (GenStgRhs 'Vanilla)
forall a b. LiftM (a -> b) -> LiftM a -> LiftM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> LiftM Type
forall a. a -> LiftM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
typ
liftRhs Maybe DIdSet
Nothing (StgRhsClosure XRhsClosure 'LiftLams
_ CostCentreStack
ccs UpdateFlag
upd [BinderP 'LiftLams]
infos GenStgExpr 'LiftLams
body Type
typ) =
[Id]
-> ([Id] -> LiftM (GenStgRhs 'Vanilla))
-> LiftM (GenStgRhs 'Vanilla)
forall (f :: * -> *) a.
Traversable f =>
f Id -> (f Id -> LiftM a) -> LiftM a
withSubstBndrs ((BinderInfo -> Id) -> [BinderInfo] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map BinderInfo -> Id
binderInfoBndr [BinderInfo]
[BinderP 'LiftLams]
infos) (([Id] -> LiftM (GenStgRhs 'Vanilla))
-> LiftM (GenStgRhs 'Vanilla))
-> ([Id] -> LiftM (GenStgRhs 'Vanilla))
-> LiftM (GenStgRhs 'Vanilla)
forall a b. (a -> b) -> a -> b
$ \[Id]
bndrs' ->
XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> GenStgExpr 'Vanilla
-> Type
-> GenStgRhs 'Vanilla
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> Type
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
NoExtFieldSilent
noExtFieldSilent CostCentreStack
ccs UpdateFlag
upd [Id]
[BinderP 'Vanilla]
bndrs' (GenStgExpr 'Vanilla -> Type -> GenStgRhs 'Vanilla)
-> LiftM (GenStgExpr 'Vanilla)
-> LiftM (Type -> GenStgRhs 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenStgExpr 'LiftLams -> LiftM (GenStgExpr 'Vanilla)
liftExpr GenStgExpr 'LiftLams
body LiftM (Type -> GenStgRhs 'Vanilla)
-> LiftM Type -> LiftM (GenStgRhs 'Vanilla)
forall a b. LiftM (a -> b) -> LiftM a -> LiftM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> LiftM Type
forall a. a -> LiftM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
typ
liftRhs (Just DIdSet
former_fvs) (StgRhsClosure XRhsClosure 'LiftLams
_ CostCentreStack
ccs UpdateFlag
upd [BinderP 'LiftLams]
infos GenStgExpr 'LiftLams
body Type
typ) =
[Id]
-> ([Id] -> LiftM (GenStgRhs 'Vanilla))
-> LiftM (GenStgRhs 'Vanilla)
forall (f :: * -> *) a.
Traversable f =>
f Id -> (f Id -> LiftM a) -> LiftM a
withSubstBndrs ((BinderInfo -> Id) -> [BinderInfo] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map BinderInfo -> Id
binderInfoBndr [BinderInfo]
[BinderP 'LiftLams]
infos) (([Id] -> LiftM (GenStgRhs 'Vanilla))
-> LiftM (GenStgRhs 'Vanilla))
-> ([Id] -> LiftM (GenStgRhs 'Vanilla))
-> LiftM (GenStgRhs 'Vanilla)
forall a b. (a -> b) -> a -> b
$ \[Id]
bndrs' -> do
let bndrs'' :: [Id]
bndrs'' = DIdSet -> [Id]
dVarSetElems DIdSet
former_fvs [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
bndrs'
XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> GenStgExpr 'Vanilla
-> Type
-> GenStgRhs 'Vanilla
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> Type
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
NoExtFieldSilent
noExtFieldSilent CostCentreStack
ccs UpdateFlag
upd [Id]
[BinderP 'Vanilla]
bndrs'' (GenStgExpr 'Vanilla -> Type -> GenStgRhs 'Vanilla)
-> LiftM (GenStgExpr 'Vanilla)
-> LiftM (Type -> GenStgRhs 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenStgExpr 'LiftLams -> LiftM (GenStgExpr 'Vanilla)
liftExpr GenStgExpr 'LiftLams
body LiftM (Type -> GenStgRhs 'Vanilla)
-> LiftM Type -> LiftM (GenStgRhs 'Vanilla)
forall a b. LiftM (a -> b) -> LiftM a -> LiftM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> LiftM Type
forall a. a -> LiftM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
typ
liftArgs :: InStgArg -> LiftM OutStgArg
liftArgs :: StgArg -> LiftM StgArg
liftArgs a :: StgArg
a@(StgLitArg Literal
_) = StgArg -> LiftM StgArg
forall a. a -> LiftM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StgArg
a
liftArgs (StgVarArg Id
occ) = do
LiftM Bool -> SDoc -> LiftM ()
forall (m :: * -> *).
(HasCallStack, Monad m) =>
m Bool -> SDoc -> m ()
assertPprM (Bool -> Bool
not (Bool -> Bool) -> LiftM Bool -> LiftM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> LiftM Bool
isLifted Id
occ) (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"StgArgs should never be lifted" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
occ)
Id -> StgArg
StgVarArg (Id -> StgArg) -> LiftM Id -> LiftM StgArg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> LiftM Id
substOcc Id
occ
liftExpr :: LlStgExpr -> LiftM OutStgExpr
liftExpr :: GenStgExpr 'LiftLams -> LiftM (GenStgExpr 'Vanilla)
liftExpr (StgLit Literal
lit) = GenStgExpr 'Vanilla -> LiftM (GenStgExpr 'Vanilla)
forall a. a -> LiftM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Literal -> GenStgExpr 'Vanilla
forall (pass :: StgPass). Literal -> GenStgExpr pass
StgLit Literal
lit)
liftExpr (StgTick StgTickish
t GenStgExpr 'LiftLams
e) = StgTickish -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
forall (pass :: StgPass).
StgTickish -> GenStgExpr pass -> GenStgExpr pass
StgTick StgTickish
t (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> LiftM (GenStgExpr 'Vanilla) -> LiftM (GenStgExpr 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenStgExpr 'LiftLams -> LiftM (GenStgExpr 'Vanilla)
liftExpr GenStgExpr 'LiftLams
e
liftExpr (StgApp Id
f [StgArg]
args) = do
f' <- Id -> LiftM Id
substOcc Id
f
args' <- traverse liftArgs args
fvs' <- formerFreeVars f
let top_lvl_args = (Id -> StgArg) -> [Id] -> [StgArg]
forall a b. (a -> b) -> [a] -> [b]
map Id -> StgArg
StgVarArg [Id]
fvs' [StgArg] -> [StgArg] -> [StgArg]
forall a. [a] -> [a] -> [a]
++ [StgArg]
args'
pure (StgApp f' top_lvl_args)
liftExpr (StgConApp DataCon
con ConstructorNumber
mn [StgArg]
args [[PrimRep]]
tys) = DataCon
-> ConstructorNumber
-> [StgArg]
-> [[PrimRep]]
-> GenStgExpr 'Vanilla
forall (pass :: StgPass).
DataCon
-> ConstructorNumber -> [StgArg] -> [[PrimRep]] -> GenStgExpr pass
StgConApp DataCon
con ConstructorNumber
mn ([StgArg] -> [[PrimRep]] -> GenStgExpr 'Vanilla)
-> LiftM [StgArg] -> LiftM ([[PrimRep]] -> GenStgExpr 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (StgArg -> LiftM StgArg) -> [StgArg] -> LiftM [StgArg]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse StgArg -> LiftM StgArg
liftArgs [StgArg]
args LiftM ([[PrimRep]] -> GenStgExpr 'Vanilla)
-> LiftM [[PrimRep]] -> LiftM (GenStgExpr 'Vanilla)
forall a b. LiftM (a -> b) -> LiftM a -> LiftM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [[PrimRep]] -> LiftM [[PrimRep]]
forall a. a -> LiftM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[PrimRep]]
tys
liftExpr (StgOpApp StgOp
op [StgArg]
args Type
ty) = StgOp -> [StgArg] -> Type -> GenStgExpr 'Vanilla
forall (pass :: StgPass).
StgOp -> [StgArg] -> Type -> GenStgExpr pass
StgOpApp StgOp
op ([StgArg] -> Type -> GenStgExpr 'Vanilla)
-> LiftM [StgArg] -> LiftM (Type -> GenStgExpr 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (StgArg -> LiftM StgArg) -> [StgArg] -> LiftM [StgArg]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse StgArg -> LiftM StgArg
liftArgs [StgArg]
args LiftM (Type -> GenStgExpr 'Vanilla)
-> LiftM Type -> LiftM (GenStgExpr 'Vanilla)
forall a b. LiftM (a -> b) -> LiftM a -> LiftM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> LiftM Type
forall a. a -> LiftM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ty
liftExpr (StgCase GenStgExpr 'LiftLams
scrut BinderP 'LiftLams
info AltType
ty [GenStgAlt 'LiftLams]
alts) = do
scrut' <- GenStgExpr 'LiftLams -> LiftM (GenStgExpr 'Vanilla)
liftExpr GenStgExpr 'LiftLams
scrut
withSubstBndr (binderInfoBndr info) $ \Id
bndr' -> do
alts' <- (GenStgAlt 'LiftLams -> LiftM OutStgAlt)
-> [GenStgAlt 'LiftLams] -> LiftM [OutStgAlt]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse GenStgAlt 'LiftLams -> LiftM OutStgAlt
liftAlt [GenStgAlt 'LiftLams]
alts
pure (StgCase scrut' bndr' ty alts')
liftExpr (StgLet XLet 'LiftLams
scope LlStgBinding
bind GenStgExpr 'LiftLams
body)
= TopLevelFlag
-> LlStgBinding
-> Skeleton
-> (Maybe (GenStgBinding 'Vanilla) -> LiftM (GenStgExpr 'Vanilla))
-> LiftM (GenStgExpr 'Vanilla)
forall a.
TopLevelFlag
-> LlStgBinding
-> Skeleton
-> (Maybe (GenStgBinding 'Vanilla) -> LiftM a)
-> LiftM a
withLiftedBind TopLevelFlag
NotTopLevel LlStgBinding
bind Skeleton
XLet 'LiftLams
scope ((Maybe (GenStgBinding 'Vanilla) -> LiftM (GenStgExpr 'Vanilla))
-> LiftM (GenStgExpr 'Vanilla))
-> (Maybe (GenStgBinding 'Vanilla) -> LiftM (GenStgExpr 'Vanilla))
-> LiftM (GenStgExpr 'Vanilla)
forall a b. (a -> b) -> a -> b
$ \Maybe (GenStgBinding 'Vanilla)
mb_bind' -> do
body' <- GenStgExpr 'LiftLams -> LiftM (GenStgExpr 'Vanilla)
liftExpr GenStgExpr 'LiftLams
body
case mb_bind' of
Maybe (GenStgBinding 'Vanilla)
Nothing -> GenStgExpr 'Vanilla -> LiftM (GenStgExpr 'Vanilla)
forall a. a -> LiftM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenStgExpr 'Vanilla
body'
Just GenStgBinding 'Vanilla
bind' -> GenStgExpr 'Vanilla -> LiftM (GenStgExpr 'Vanilla)
forall a. a -> LiftM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (XLet 'Vanilla
-> GenStgBinding 'Vanilla
-> GenStgExpr 'Vanilla
-> GenStgExpr 'Vanilla
forall (pass :: StgPass).
XLet pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLet XLet 'Vanilla
NoExtFieldSilent
noExtFieldSilent GenStgBinding 'Vanilla
bind' GenStgExpr 'Vanilla
body')
liftExpr (StgLetNoEscape XLetNoEscape 'LiftLams
scope LlStgBinding
bind GenStgExpr 'LiftLams
body)
= TopLevelFlag
-> LlStgBinding
-> Skeleton
-> (Maybe (GenStgBinding 'Vanilla) -> LiftM (GenStgExpr 'Vanilla))
-> LiftM (GenStgExpr 'Vanilla)
forall a.
TopLevelFlag
-> LlStgBinding
-> Skeleton
-> (Maybe (GenStgBinding 'Vanilla) -> LiftM a)
-> LiftM a
withLiftedBind TopLevelFlag
NotTopLevel LlStgBinding
bind Skeleton
XLetNoEscape 'LiftLams
scope ((Maybe (GenStgBinding 'Vanilla) -> LiftM (GenStgExpr 'Vanilla))
-> LiftM (GenStgExpr 'Vanilla))
-> (Maybe (GenStgBinding 'Vanilla) -> LiftM (GenStgExpr 'Vanilla))
-> LiftM (GenStgExpr 'Vanilla)
forall a b. (a -> b) -> a -> b
$ \Maybe (GenStgBinding 'Vanilla)
mb_bind' -> do
body' <- GenStgExpr 'LiftLams -> LiftM (GenStgExpr 'Vanilla)
liftExpr GenStgExpr 'LiftLams
body
case mb_bind' of
Maybe (GenStgBinding 'Vanilla)
Nothing -> String -> SDoc -> LiftM (GenStgExpr 'Vanilla)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"stgLiftLams" (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Should never decide to lift LNEs")
Just GenStgBinding 'Vanilla
bind' -> GenStgExpr 'Vanilla -> LiftM (GenStgExpr 'Vanilla)
forall a. a -> LiftM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (XLetNoEscape 'Vanilla
-> GenStgBinding 'Vanilla
-> GenStgExpr 'Vanilla
-> GenStgExpr 'Vanilla
forall (pass :: StgPass).
XLetNoEscape pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLetNoEscape XLetNoEscape 'Vanilla
NoExtFieldSilent
noExtFieldSilent GenStgBinding 'Vanilla
bind' GenStgExpr 'Vanilla
body')
liftAlt :: LlStgAlt -> LiftM OutStgAlt
liftAlt :: GenStgAlt 'LiftLams -> LiftM OutStgAlt
liftAlt alt :: GenStgAlt 'LiftLams
alt@GenStgAlt{alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con=AltCon
_, alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs=[BinderP 'LiftLams]
infos, alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs=GenStgExpr 'LiftLams
rhs} =
[Id] -> ([Id] -> LiftM OutStgAlt) -> LiftM OutStgAlt
forall (f :: * -> *) a.
Traversable f =>
f Id -> (f Id -> LiftM a) -> LiftM a
withSubstBndrs ((BinderInfo -> Id) -> [BinderInfo] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map BinderInfo -> Id
binderInfoBndr [BinderInfo]
[BinderP 'LiftLams]
infos) (([Id] -> LiftM OutStgAlt) -> LiftM OutStgAlt)
-> ([Id] -> LiftM OutStgAlt) -> LiftM OutStgAlt
forall a b. (a -> b) -> a -> b
$ \[Id]
bndrs' ->
do !rhs' <- GenStgExpr 'LiftLams -> LiftM (GenStgExpr 'Vanilla)
liftExpr GenStgExpr 'LiftLams
rhs
return $! alt {alt_bndrs = bndrs', alt_rhs = rhs'}