module GHC.Stg.BcPrep ( bcPrep ) where
import GHC.Prelude
import GHC.Types.Id.Make
import GHC.Types.Id
import GHC.Core.Type
import GHC.Builtin.Types ( unboxedUnitTy )
import GHC.Builtin.Types.Prim
import GHC.Types.Unique
import GHC.Data.FastString
import GHC.Utils.Panic.Plain
import GHC.Types.Tickish
import GHC.Types.Unique.Supply
import qualified GHC.Types.CostCentre as CC
import GHC.Stg.Syntax
import GHC.Utils.Monad.State.Strict
data BcPrepM_State
= BcPrepM_State
{ BcPrepM_State -> UniqSupply
prepUniqSupply :: !UniqSupply
}
type BcPrepM a = State BcPrepM_State a
bcPrepRHS :: StgRhs -> BcPrepM StgRhs
bcPrepRHS :: StgRhs -> BcPrepM StgRhs
bcPrepRHS (StgRhsClosure XRhsClosure 'Vanilla
fvs CostCentreStack
cc UpdateFlag
upd [BinderP 'Vanilla]
args (StgTick bp :: StgTickish
bp@Breakpoint{} GenStgExpr 'Vanilla
expr)) = do
GenStgExpr 'Vanilla
expr' <- GenStgExpr 'Vanilla -> BcPrepM (GenStgExpr 'Vanilla)
bcPrepExpr GenStgExpr 'Vanilla
expr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
fvs CostCentreStack
cc UpdateFlag
upd [BinderP 'Vanilla]
args (forall (pass :: StgPass).
StgTickish -> GenStgExpr pass -> GenStgExpr pass
StgTick StgTickish
bp GenStgExpr 'Vanilla
expr'))
bcPrepRHS (StgRhsClosure XRhsClosure 'Vanilla
fvs CostCentreStack
cc UpdateFlag
upd [BinderP 'Vanilla]
args GenStgExpr 'Vanilla
expr) =
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
fvs CostCentreStack
cc UpdateFlag
upd [BinderP 'Vanilla]
args forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenStgExpr 'Vanilla -> BcPrepM (GenStgExpr 'Vanilla)
bcPrepExpr GenStgExpr 'Vanilla
expr
bcPrepRHS con :: StgRhs
con@StgRhsCon{} = forall (f :: * -> *) a. Applicative f => a -> f a
pure StgRhs
con
bcPrepExpr :: StgExpr -> BcPrepM StgExpr
bcPrepExpr :: GenStgExpr 'Vanilla -> BcPrepM (GenStgExpr 'Vanilla)
bcPrepExpr (StgTick bp :: StgTickish
bp@(Breakpoint XBreakpoint 'TickishPassStg
tick_ty Int
_ [XTickishId 'TickishPassStg]
_) GenStgExpr 'Vanilla
rhs)
| Kind -> Bool
isLiftedTypeKind (HasDebugCallStack => Kind -> Kind
typeKind XBreakpoint 'TickishPassStg
tick_ty) = do
Id
id <- Kind -> BcPrepM Id
newId XBreakpoint 'TickishPassStg
tick_ty
GenStgExpr 'Vanilla
rhs' <- GenStgExpr 'Vanilla -> BcPrepM (GenStgExpr 'Vanilla)
bcPrepExpr GenStgExpr 'Vanilla
rhs
let expr' :: GenStgExpr 'Vanilla
expr' = forall (pass :: StgPass).
StgTickish -> GenStgExpr pass -> GenStgExpr pass
StgTick StgTickish
bp GenStgExpr 'Vanilla
rhs'
bnd :: GenStgBinding 'Vanilla
bnd = forall (pass :: StgPass).
BinderP pass -> GenStgRhs pass -> GenStgBinding pass
StgNonRec Id
id (forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure NoExtFieldSilent
noExtFieldSilent
CostCentreStack
CC.dontCareCCS
UpdateFlag
ReEntrant
[]
GenStgExpr 'Vanilla
expr'
)
letExp :: GenStgExpr 'Vanilla
letExp = forall (pass :: StgPass).
XLet pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLet NoExtFieldSilent
noExtFieldSilent GenStgBinding 'Vanilla
bnd (forall (pass :: StgPass). Id -> [StgArg] -> GenStgExpr pass
StgApp Id
id [])
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenStgExpr 'Vanilla
letExp
| Bool
otherwise = do
Id
id <- Kind -> BcPrepM Id
newId (HasDebugCallStack => Kind -> Kind -> Kind
mkVisFunTyMany Kind
realWorldStatePrimTy XBreakpoint 'TickishPassStg
tick_ty)
GenStgExpr 'Vanilla
rhs' <- GenStgExpr 'Vanilla -> BcPrepM (GenStgExpr 'Vanilla)
bcPrepExpr GenStgExpr 'Vanilla
rhs
let expr' :: GenStgExpr 'Vanilla
expr' = forall (pass :: StgPass).
StgTickish -> GenStgExpr pass -> GenStgExpr pass
StgTick StgTickish
bp GenStgExpr 'Vanilla
rhs'
bnd :: GenStgBinding 'Vanilla
bnd = forall (pass :: StgPass).
BinderP pass -> GenStgRhs pass -> GenStgBinding pass
StgNonRec Id
id (forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure NoExtFieldSilent
noExtFieldSilent
CostCentreStack
CC.dontCareCCS
UpdateFlag
ReEntrant
[Id
voidArgId]
GenStgExpr 'Vanilla
expr'
)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (pass :: StgPass).
XLet pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLet NoExtFieldSilent
noExtFieldSilent GenStgBinding 'Vanilla
bnd (forall (pass :: StgPass). Id -> [StgArg] -> GenStgExpr pass
StgApp Id
id [Id -> StgArg
StgVarArg Id
realWorldPrimId])
bcPrepExpr (StgTick StgTickish
tick GenStgExpr 'Vanilla
rhs) =
forall (pass :: StgPass).
StgTickish -> GenStgExpr pass -> GenStgExpr pass
StgTick StgTickish
tick forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenStgExpr 'Vanilla -> BcPrepM (GenStgExpr 'Vanilla)
bcPrepExpr GenStgExpr 'Vanilla
rhs
bcPrepExpr (StgLet XLet 'Vanilla
xlet GenStgBinding 'Vanilla
bnds GenStgExpr 'Vanilla
expr) =
forall (pass :: StgPass).
XLet pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLet XLet 'Vanilla
xlet forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenStgBinding 'Vanilla -> BcPrepM (GenStgBinding 'Vanilla)
bcPrepBind GenStgBinding 'Vanilla
bnds
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenStgExpr 'Vanilla -> BcPrepM (GenStgExpr 'Vanilla)
bcPrepExpr GenStgExpr 'Vanilla
expr
bcPrepExpr (StgLetNoEscape XLetNoEscape 'Vanilla
xlne GenStgBinding 'Vanilla
bnds GenStgExpr 'Vanilla
expr) =
forall (pass :: StgPass).
XLet pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLet XLetNoEscape 'Vanilla
xlne forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenStgBinding 'Vanilla -> BcPrepM (GenStgBinding 'Vanilla)
bcPrepBind GenStgBinding 'Vanilla
bnds
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenStgExpr 'Vanilla -> BcPrepM (GenStgExpr 'Vanilla)
bcPrepExpr GenStgExpr 'Vanilla
expr
bcPrepExpr (StgCase GenStgExpr 'Vanilla
expr BinderP 'Vanilla
bndr AltType
alt_type [GenStgAlt 'Vanilla]
alts) =
forall (pass :: StgPass).
GenStgExpr pass
-> BinderP pass -> AltType -> [GenStgAlt pass] -> GenStgExpr pass
StgCase forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenStgExpr 'Vanilla -> BcPrepM (GenStgExpr 'Vanilla)
bcPrepExpr GenStgExpr 'Vanilla
expr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure BinderP 'Vanilla
bndr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure AltType
alt_type
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenStgAlt 'Vanilla -> BcPrepM (GenStgAlt 'Vanilla)
bcPrepAlt [GenStgAlt 'Vanilla]
alts
bcPrepExpr lit :: GenStgExpr 'Vanilla
lit@StgLit{} = forall (f :: * -> *) a. Applicative f => a -> f a
pure GenStgExpr 'Vanilla
lit
bcPrepExpr (StgApp Id
x [])
| Id -> Bool
isNNLJoinPoint Id
x = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
forall (pass :: StgPass). Id -> [StgArg] -> GenStgExpr pass
StgApp (Id -> Id
protectNNLJoinPointId Id
x) [Id -> StgArg
StgVarArg Id
voidPrimId]
bcPrepExpr app :: GenStgExpr 'Vanilla
app@StgApp{} = forall (f :: * -> *) a. Applicative f => a -> f a
pure GenStgExpr 'Vanilla
app
bcPrepExpr app :: GenStgExpr 'Vanilla
app@StgConApp{} = forall (f :: * -> *) a. Applicative f => a -> f a
pure GenStgExpr 'Vanilla
app
bcPrepExpr app :: GenStgExpr 'Vanilla
app@StgOpApp{} = forall (f :: * -> *) a. Applicative f => a -> f a
pure GenStgExpr 'Vanilla
app
bcPrepAlt :: StgAlt -> BcPrepM StgAlt
bcPrepAlt :: GenStgAlt 'Vanilla -> BcPrepM (GenStgAlt 'Vanilla)
bcPrepAlt (GenStgAlt AltCon
con [BinderP 'Vanilla]
bndrs GenStgExpr 'Vanilla
rhs) = forall (pass :: StgPass).
AltCon -> [BinderP pass] -> GenStgExpr pass -> GenStgAlt pass
GenStgAlt AltCon
con [BinderP 'Vanilla]
bndrs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenStgExpr 'Vanilla -> BcPrepM (GenStgExpr 'Vanilla)
bcPrepExpr GenStgExpr 'Vanilla
rhs
bcPrepBind :: StgBinding -> BcPrepM StgBinding
bcPrepBind :: GenStgBinding 'Vanilla -> BcPrepM (GenStgBinding 'Vanilla)
bcPrepBind (StgNonRec BinderP 'Vanilla
bndr StgRhs
rhs) =
let (Id
bndr', StgRhs
rhs') = (Id, StgRhs) -> (Id, StgRhs)
bcPrepSingleBind (BinderP 'Vanilla
bndr, StgRhs
rhs)
in forall (pass :: StgPass).
BinderP pass -> GenStgRhs pass -> GenStgBinding pass
StgNonRec Id
bndr' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StgRhs -> BcPrepM StgRhs
bcPrepRHS StgRhs
rhs'
bcPrepBind (StgRec [(BinderP 'Vanilla, StgRhs)]
bnds) =
forall (pass :: StgPass).
[(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass
StgRec forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((\(Id
b,StgRhs
r) -> (,) Id
b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StgRhs -> BcPrepM StgRhs
bcPrepRHS StgRhs
r) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id, StgRhs) -> (Id, StgRhs)
bcPrepSingleBind)
[(BinderP 'Vanilla, StgRhs)]
bnds
bcPrepSingleBind :: (Id, StgRhs) -> (Id, StgRhs)
bcPrepSingleBind :: (Id, StgRhs) -> (Id, StgRhs)
bcPrepSingleBind (Id
x, StgRhsClosure XRhsClosure 'Vanilla
ext CostCentreStack
cc UpdateFlag
upd_flag [BinderP 'Vanilla]
args GenStgExpr 'Vanilla
body)
| Id -> Bool
isNNLJoinPoint Id
x
= ( Id -> Id
protectNNLJoinPointId Id
x
, forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
ext CostCentreStack
cc UpdateFlag
upd_flag ([BinderP 'Vanilla]
args forall a. [a] -> [a] -> [a]
++ [Id
voidArgId]) GenStgExpr 'Vanilla
body)
bcPrepSingleBind (Id, StgRhs)
bnd = (Id, StgRhs)
bnd
bcPrepTopLvl :: StgTopBinding -> BcPrepM StgTopBinding
bcPrepTopLvl :: StgTopBinding -> BcPrepM StgTopBinding
bcPrepTopLvl lit :: StgTopBinding
lit@StgTopStringLit{} = forall (f :: * -> *) a. Applicative f => a -> f a
pure StgTopBinding
lit
bcPrepTopLvl (StgTopLifted GenStgBinding 'Vanilla
bnd) = forall (pass :: StgPass).
GenStgBinding pass -> GenStgTopBinding pass
StgTopLifted forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenStgBinding 'Vanilla -> BcPrepM (GenStgBinding 'Vanilla)
bcPrepBind GenStgBinding 'Vanilla
bnd
bcPrep :: UniqSupply -> [InStgTopBinding] -> [OutStgTopBinding]
bcPrep :: UniqSupply -> [StgTopBinding] -> [StgTopBinding]
bcPrep UniqSupply
us [StgTopBinding]
bnds = forall s a. State s a -> s -> a
evalState (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM StgTopBinding -> BcPrepM StgTopBinding
bcPrepTopLvl [StgTopBinding]
bnds) (UniqSupply -> BcPrepM_State
BcPrepM_State UniqSupply
us)
isNNLJoinPoint :: Id -> Bool
isNNLJoinPoint :: Id -> Bool
isNNLJoinPoint Id
x = Id -> Bool
isJoinId Id
x Bool -> Bool -> Bool
&& Kind -> Bool
mightBeUnliftedType (Id -> Kind
idType Id
x)
protectNNLJoinPointId :: Id -> Id
protectNNLJoinPointId :: Id -> Id
protectNNLJoinPointId Id
x
= forall a. HasCallStack => Bool -> a -> a
assert (Id -> Bool
isNNLJoinPoint Id
x )
(Kind -> Kind) -> Id -> Id
updateIdTypeButNotMult (Kind
unboxedUnitTy HasDebugCallStack => Kind -> Kind -> Kind
`mkVisFunTyMany`) Id
x
newUnique :: BcPrepM Unique
newUnique :: BcPrepM Unique
newUnique = forall s a. (s -> (a, s)) -> State s a
state forall a b. (a -> b) -> a -> b
$
\BcPrepM_State
st -> case UniqSupply -> (Unique, UniqSupply)
takeUniqFromSupply (BcPrepM_State -> UniqSupply
prepUniqSupply BcPrepM_State
st) of
(Unique
uniq, UniqSupply
us) -> (Unique
uniq, BcPrepM_State
st { prepUniqSupply :: UniqSupply
prepUniqSupply = UniqSupply
us })
newId :: Type -> BcPrepM Id
newId :: Kind -> BcPrepM Id
newId Kind
ty = do
Unique
uniq <- BcPrepM Unique
newUnique
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ FastString -> Unique -> Kind -> Kind -> Id
mkSysLocal FastString
prepFS Unique
uniq Kind
ManyTy Kind
ty
prepFS :: FastString
prepFS :: FastString
prepFS = String -> FastString
fsLit String
"bcprep"