{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TypeFamilies #-}
module GHC.CoreToStg ( CoreToStgOpts (..), coreToStg ) where
import GHC.Prelude
import GHC.Core
import GHC.Core.Utils ( exprType, findDefault, isJoinBind
, exprIsTickedString_maybe )
import GHC.Core.Opt.Arity ( manifestArity )
import GHC.Core.Type
import GHC.Core.TyCon
import GHC.Core.DataCon
import GHC.Stg.Syntax
import GHC.Stg.Debug
import GHC.Stg.Utils
import GHC.Types.RepType
import GHC.Types.Id.Make ( coercionTokenId )
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.CostCentre
import GHC.Types.Tickish
import GHC.Types.Var.Env
import GHC.Types.Name ( isExternalName, nameModule_maybe )
import GHC.Types.Basic ( Arity, TypeOrConstraint(..) )
import GHC.Types.Literal
import GHC.Types.ForeignCall
import GHC.Types.IPE
import GHC.Types.Demand ( isUsedOnceDmd )
import GHC.Types.SrcLoc ( mkGeneralSrcSpan )
import GHC.Unit.Module
import GHC.Data.FastString
import GHC.Platform ( Platform )
import GHC.Platform.Ways
import GHC.Builtin.PrimOps ( PrimCall(..), primOpWrapperId )
import GHC.Utils.Outputable
import GHC.Utils.Monad
import GHC.Utils.Misc (HasDebugCallStack)
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import Control.Monad (ap)
import Data.Maybe (fromMaybe)
coreToStg :: CoreToStgOpts -> Module -> ModLocation -> CoreProgram
-> ([StgTopBinding], InfoTableProvMap, CollectedCCs)
coreToStg :: CoreToStgOpts
-> Module
-> ModLocation
-> CoreProgram
-> ([StgTopBinding], InfoTableProvMap, CollectedCCs)
coreToStg opts :: CoreToStgOpts
opts@CoreToStgOpts
{ coreToStg_ways :: CoreToStgOpts -> Ways
coreToStg_ways = Ways
ways
, coreToStg_AutoSccsOnIndividualCafs :: CoreToStgOpts -> Bool
coreToStg_AutoSccsOnIndividualCafs = Bool
opt_AutoSccsOnIndividualCafs
, coreToStg_InfoTableMap :: CoreToStgOpts -> Bool
coreToStg_InfoTableMap = Bool
opt_InfoTableMap
, coreToStg_stgDebugOpts :: CoreToStgOpts -> StgDebugOpts
coreToStg_stgDebugOpts = StgDebugOpts
stgDebugOpts
} Module
this_mod ModLocation
ml CoreProgram
pgm
= ([StgTopBinding]
pgm'', InfoTableProvMap
denv, CollectedCCs
final_ccs)
where
(IdEnv HowBound
_, ([CostCentre]
local_ccs, [CostCentreStack]
local_cc_stacks), [StgTopBinding]
pgm')
= CoreToStgOpts
-> Module
-> IdEnv HowBound
-> CollectedCCs
-> CoreProgram
-> (IdEnv HowBound, CollectedCCs, [StgTopBinding])
coreTopBindsToStg CoreToStgOpts
opts Module
this_mod IdEnv HowBound
forall a. VarEnv a
emptyVarEnv CollectedCCs
emptyCollectedCCs CoreProgram
pgm
(![StgTopBinding]
pgm'', !InfoTableProvMap
denv)
| Bool
opt_InfoTableMap
= StgDebugOpts
-> ModLocation
-> [StgTopBinding]
-> ([StgTopBinding], InfoTableProvMap)
collectDebugInformation StgDebugOpts
stgDebugOpts ModLocation
ml [StgTopBinding]
pgm'
| Bool
otherwise = ([StgTopBinding]
pgm', InfoTableProvMap
emptyInfoTableProvMap)
prof :: Bool
prof = Ways -> Way -> Bool
hasWay Ways
ways Way
WayProf
final_ccs :: CollectedCCs
final_ccs
| Bool
prof Bool -> Bool -> Bool
&& Bool
opt_AutoSccsOnIndividualCafs
= ([CostCentre]
local_ccs,[CostCentreStack]
local_cc_stacks)
| Bool
prof
= (CostCentre
all_cafs_ccCostCentre -> [CostCentre] -> [CostCentre]
forall a. a -> [a] -> [a]
:[CostCentre]
local_ccs, CostCentreStack
all_cafs_ccsCostCentreStack -> [CostCentreStack] -> [CostCentreStack]
forall a. a -> [a] -> [a]
:[CostCentreStack]
local_cc_stacks)
| Bool
otherwise
= CollectedCCs
emptyCollectedCCs
(CostCentre
all_cafs_cc, CostCentreStack
all_cafs_ccs) = Module -> (CostCentre, CostCentreStack)
getAllCAFsCC Module
this_mod
coreTopBindsToStg
:: CoreToStgOpts
-> Module
-> IdEnv HowBound
-> CollectedCCs
-> CoreProgram
-> (IdEnv HowBound, CollectedCCs, [StgTopBinding])
coreTopBindsToStg :: CoreToStgOpts
-> Module
-> IdEnv HowBound
-> CollectedCCs
-> CoreProgram
-> (IdEnv HowBound, CollectedCCs, [StgTopBinding])
coreTopBindsToStg CoreToStgOpts
_ Module
_ IdEnv HowBound
env CollectedCCs
ccs []
= (IdEnv HowBound
env, CollectedCCs
ccs, [])
coreTopBindsToStg CoreToStgOpts
opts Module
this_mod IdEnv HowBound
env CollectedCCs
ccs (CoreBind
b:CoreProgram
bs)
| NonRec Id
_ CoreArg
rhs <- CoreBind
b, CoreArg -> Bool
forall b. Expr b -> Bool
isTyCoArg CoreArg
rhs
= CoreToStgOpts
-> Module
-> IdEnv HowBound
-> CollectedCCs
-> CoreProgram
-> (IdEnv HowBound, CollectedCCs, [StgTopBinding])
coreTopBindsToStg CoreToStgOpts
opts Module
this_mod IdEnv HowBound
env1 CollectedCCs
ccs1 CoreProgram
bs
| Bool
otherwise
= (IdEnv HowBound
env2, CollectedCCs
ccs2, StgTopBinding
b'StgTopBinding -> [StgTopBinding] -> [StgTopBinding]
forall a. a -> [a] -> [a]
:[StgTopBinding]
bs')
where
(IdEnv HowBound
env1, CollectedCCs
ccs1, StgTopBinding
b' ) = CoreToStgOpts
-> Module
-> IdEnv HowBound
-> CollectedCCs
-> CoreBind
-> (IdEnv HowBound, CollectedCCs, StgTopBinding)
coreTopBindToStg CoreToStgOpts
opts Module
this_mod IdEnv HowBound
env CollectedCCs
ccs CoreBind
b
(IdEnv HowBound
env2, CollectedCCs
ccs2, [StgTopBinding]
bs') = CoreToStgOpts
-> Module
-> IdEnv HowBound
-> CollectedCCs
-> CoreProgram
-> (IdEnv HowBound, CollectedCCs, [StgTopBinding])
coreTopBindsToStg CoreToStgOpts
opts Module
this_mod IdEnv HowBound
env1 CollectedCCs
ccs1 CoreProgram
bs
coreTopBindToStg
:: CoreToStgOpts
-> Module
-> IdEnv HowBound
-> CollectedCCs
-> CoreBind
-> (IdEnv HowBound, CollectedCCs, StgTopBinding)
coreTopBindToStg :: CoreToStgOpts
-> Module
-> IdEnv HowBound
-> CollectedCCs
-> CoreBind
-> (IdEnv HowBound, CollectedCCs, StgTopBinding)
coreTopBindToStg CoreToStgOpts
_ Module
_ IdEnv HowBound
env CollectedCCs
ccs (NonRec Id
id CoreArg
e)
| Just ByteString
str <- CoreArg -> Maybe ByteString
exprIsTickedString_maybe CoreArg
e
= let
env' :: IdEnv HowBound
env' = IdEnv HowBound -> Id -> HowBound -> IdEnv HowBound
forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv IdEnv HowBound
env Id
id HowBound
how_bound
how_bound :: HowBound
how_bound = LetInfo -> Arity -> HowBound
LetBound LetInfo
TopLet Arity
0
in (IdEnv HowBound
env', CollectedCCs
ccs, Id -> ByteString -> StgTopBinding
forall (pass :: StgPass). Id -> ByteString -> GenStgTopBinding pass
StgTopStringLit Id
id ByteString
str)
coreTopBindToStg opts :: CoreToStgOpts
opts@CoreToStgOpts
{ coreToStg_platform :: CoreToStgOpts -> Platform
coreToStg_platform = Platform
platform
} Module
this_mod IdEnv HowBound
env CollectedCCs
ccs (NonRec Id
id CoreArg
rhs)
= let
env' :: IdEnv HowBound
env' = IdEnv HowBound -> Id -> HowBound -> IdEnv HowBound
forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv IdEnv HowBound
env Id
id HowBound
how_bound
how_bound :: HowBound
how_bound = LetInfo -> Arity -> HowBound
LetBound LetInfo
TopLet (Arity -> HowBound) -> Arity -> HowBound
forall a b. (a -> b) -> a -> b
$! CoreArg -> Arity
manifestArity CoreArg
rhs
(CollectedCCs
ccs', (Id
id', StgRhs
stg_rhs)) =
Platform
-> IdEnv HowBound
-> CtsM (CollectedCCs, (Id, StgRhs))
-> (CollectedCCs, (Id, StgRhs))
forall a. Platform -> IdEnv HowBound -> CtsM a -> a
initCts Platform
platform IdEnv HowBound
env (CtsM (CollectedCCs, (Id, StgRhs)) -> (CollectedCCs, (Id, StgRhs)))
-> CtsM (CollectedCCs, (Id, StgRhs))
-> (CollectedCCs, (Id, StgRhs))
forall a b. (a -> b) -> a -> b
$
CoreToStgOpts
-> Module
-> CollectedCCs
-> (Id, CoreArg)
-> CtsM (CollectedCCs, (Id, StgRhs))
coreToTopStgRhs CoreToStgOpts
opts Module
this_mod CollectedCCs
ccs (Id
id,CoreArg
rhs)
bind :: StgTopBinding
bind = GenStgBinding 'Vanilla -> StgTopBinding
forall (pass :: StgPass).
GenStgBinding pass -> GenStgTopBinding pass
StgTopLifted (GenStgBinding 'Vanilla -> StgTopBinding)
-> GenStgBinding 'Vanilla -> StgTopBinding
forall a b. (a -> b) -> a -> b
$ BinderP 'Vanilla -> StgRhs -> GenStgBinding 'Vanilla
forall (pass :: StgPass).
BinderP pass -> GenStgRhs pass -> GenStgBinding pass
StgNonRec Id
BinderP 'Vanilla
id' StgRhs
stg_rhs
in
(IdEnv HowBound
env', CollectedCCs
ccs', StgTopBinding
bind)
coreTopBindToStg opts :: CoreToStgOpts
opts@CoreToStgOpts
{ coreToStg_platform :: CoreToStgOpts -> Platform
coreToStg_platform = Platform
platform
} Module
this_mod IdEnv HowBound
env CollectedCCs
ccs (Rec [(Id, CoreArg)]
pairs)
= Bool
-> (IdEnv HowBound, CollectedCCs, StgTopBinding)
-> (IdEnv HowBound, CollectedCCs, StgTopBinding)
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not ([(Id, CoreArg)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Id, CoreArg)]
pairs)) ((IdEnv HowBound, CollectedCCs, StgTopBinding)
-> (IdEnv HowBound, CollectedCCs, StgTopBinding))
-> (IdEnv HowBound, CollectedCCs, StgTopBinding)
-> (IdEnv HowBound, CollectedCCs, StgTopBinding)
forall a b. (a -> b) -> a -> b
$
let
extra_env' :: [(Id, HowBound)]
extra_env' = [ (Id
b, LetInfo -> Arity -> HowBound
LetBound LetInfo
TopLet (Arity -> HowBound) -> Arity -> HowBound
forall a b. (a -> b) -> a -> b
$! CoreArg -> Arity
manifestArity CoreArg
rhs)
| (Id
b, CoreArg
rhs) <- [(Id, CoreArg)]
pairs ]
env' :: IdEnv HowBound
env' = IdEnv HowBound -> [(Id, HowBound)] -> IdEnv HowBound
forall a. VarEnv a -> [(Id, a)] -> VarEnv a
extendVarEnvList IdEnv HowBound
env [(Id, HowBound)]
extra_env'
(CollectedCCs
ccs', [(Id, StgRhs)]
stg_rhss)
= Platform
-> IdEnv HowBound
-> CtsM (CollectedCCs, [(Id, StgRhs)])
-> (CollectedCCs, [(Id, StgRhs)])
forall a. Platform -> IdEnv HowBound -> CtsM a -> a
initCts Platform
platform IdEnv HowBound
env' (CtsM (CollectedCCs, [(Id, StgRhs)])
-> (CollectedCCs, [(Id, StgRhs)]))
-> CtsM (CollectedCCs, [(Id, StgRhs)])
-> (CollectedCCs, [(Id, StgRhs)])
forall a b. (a -> b) -> a -> b
$ (CollectedCCs
-> (Id, CoreArg) -> CtsM (CollectedCCs, (Id, StgRhs)))
-> CollectedCCs
-> [(Id, CoreArg)]
-> CtsM (CollectedCCs, [(Id, StgRhs)])
forall (m :: * -> *) (t :: * -> *) acc x y.
(Monad m, Traversable t) =>
(acc -> x -> m (acc, y)) -> acc -> t x -> m (acc, t y)
mapAccumLM (CoreToStgOpts
-> Module
-> CollectedCCs
-> (Id, CoreArg)
-> CtsM (CollectedCCs, (Id, StgRhs))
coreToTopStgRhs CoreToStgOpts
opts Module
this_mod) CollectedCCs
ccs [(Id, CoreArg)]
pairs
bind :: StgTopBinding
bind = GenStgBinding 'Vanilla -> StgTopBinding
forall (pass :: StgPass).
GenStgBinding pass -> GenStgTopBinding pass
StgTopLifted (GenStgBinding 'Vanilla -> StgTopBinding)
-> GenStgBinding 'Vanilla -> StgTopBinding
forall a b. (a -> b) -> a -> b
$ [(BinderP 'Vanilla, StgRhs)] -> GenStgBinding 'Vanilla
forall (pass :: StgPass).
[(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass
StgRec [(Id, StgRhs)]
[(BinderP 'Vanilla, StgRhs)]
stg_rhss
in
(IdEnv HowBound
env', CollectedCCs
ccs', StgTopBinding
bind)
coreToTopStgRhs
:: CoreToStgOpts
-> Module
-> CollectedCCs
-> (Id,CoreExpr)
-> CtsM (CollectedCCs, (Id, StgRhs))
coreToTopStgRhs :: CoreToStgOpts
-> Module
-> CollectedCCs
-> (Id, CoreArg)
-> CtsM (CollectedCCs, (Id, StgRhs))
coreToTopStgRhs CoreToStgOpts
opts Module
this_mod CollectedCCs
ccs (Id
bndr, CoreArg
rhs)
= do { PreStgRhs
new_rhs <- (() :: Constraint) => CoreArg -> CtsM PreStgRhs
CoreArg -> CtsM PreStgRhs
coreToPreStgRhs CoreArg
rhs
; let (StgRhs
stg_rhs, CollectedCCs
ccs') =
CoreToStgOpts
-> Module
-> CollectedCCs
-> Id
-> PreStgRhs
-> (StgRhs, CollectedCCs)
mkTopStgRhs CoreToStgOpts
opts Module
this_mod CollectedCCs
ccs Id
bndr PreStgRhs
new_rhs
stg_arity :: Arity
stg_arity =
StgRhs -> Arity
stgRhsArity StgRhs
stg_rhs
; (CollectedCCs, (Id, StgRhs)) -> CtsM (CollectedCCs, (Id, StgRhs))
forall a. a -> CtsM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CollectedCCs
ccs', (Id
bndr, Bool -> SDoc -> StgRhs -> StgRhs
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Arity -> Bool
arity_ok Arity
stg_arity) (Arity -> SDoc
mk_arity_msg Arity
stg_arity) StgRhs
stg_rhs)) }
where
arity_ok :: Arity -> Bool
arity_ok Arity
stg_arity
| Name -> Bool
isExternalName (Id -> Name
idName Id
bndr) = Arity
id_arity Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
stg_arity
| Bool
otherwise = Bool
True
id_arity :: Arity
id_arity = Id -> Arity
idArity Id
bndr
mk_arity_msg :: Arity -> SDoc
mk_arity_msg Arity
stg_arity
= [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
bndr,
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Id arity:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Arity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Arity
id_arity,
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"STG arity:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Arity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Arity
stg_arity]
coreToStgExpr
:: HasDebugCallStack => CoreExpr
-> CtsM StgExpr
coreToStgExpr :: (() :: Constraint) => CoreArg -> CtsM StgExpr
coreToStgExpr (Lit (LitNumber LitNumType
LitNumBigNat Integer
_)) = String -> CtsM StgExpr
forall a. HasCallStack => String -> a
panic String
"coreToStgExpr: LitNumBigNat"
coreToStgExpr (Lit Literal
l) = StgExpr -> CtsM StgExpr
forall a. a -> CtsM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> StgExpr
forall (pass :: StgPass). Literal -> GenStgExpr pass
StgLit Literal
l)
coreToStgExpr (Var Id
v) = Id -> [CoreArg] -> [CoreTickish] -> CtsM StgExpr
coreToStgApp Id
v [] []
coreToStgExpr (Coercion Coercion
_)
= Id -> [CoreArg] -> [CoreTickish] -> CtsM StgExpr
coreToStgApp Id
coercionTokenId [] []
coreToStgExpr expr :: CoreArg
expr@(App CoreArg
_ CoreArg
_)
= case CoreArg
app_head of
Var Id
f -> Id -> [CoreArg] -> [CoreTickish] -> CtsM StgExpr
coreToStgApp Id
f [CoreArg]
args [CoreTickish]
ticks
Lit Literal
l | Literal -> Bool
isLitRubbish Literal
l
-> StgExpr -> CtsM StgExpr
forall a. a -> CtsM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> StgExpr
forall (pass :: StgPass). Literal -> GenStgExpr pass
StgLit (Literal -> StgExpr) -> Literal -> StgExpr
forall a b. (a -> b) -> a -> b
$ TypeOrConstraint -> RuntimeRepType -> Literal
LitRubbish TypeOrConstraint
TypeLike (RuntimeRepType -> Literal) -> RuntimeRepType -> Literal
forall a b. (a -> b) -> a -> b
$ (() :: Constraint) => RuntimeRepType -> RuntimeRepType
RuntimeRepType -> RuntimeRepType
getRuntimeRep ((() :: Constraint) => CoreArg -> RuntimeRepType
CoreArg -> RuntimeRepType
exprType CoreArg
expr))
CoreArg
_ -> String -> SDoc -> CtsM StgExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"coreToStgExpr - Invalid app head:" (CoreArg -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreArg
expr)
where
(CoreArg
app_head, [CoreArg]
args, [CoreTickish]
ticks) = (() :: Constraint) =>
CoreArg -> (CoreArg, [CoreArg], [CoreTickish])
CoreArg -> (CoreArg, [CoreArg], [CoreTickish])
myCollectArgs CoreArg
expr
coreToStgExpr expr :: CoreArg
expr@(Lam Id
_ CoreArg
_)
= let
([Id]
args, CoreArg
body) = CoreArg -> ([Id], CoreArg)
myCollectBinders CoreArg
expr
in
case [Id] -> [Id]
filterStgBinders [Id]
args of
[] -> (() :: Constraint) => CoreArg -> CtsM StgExpr
CoreArg -> CtsM StgExpr
coreToStgExpr CoreArg
body
[Id]
_ -> String -> SDoc -> CtsM StgExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"coretoStgExpr" (SDoc -> CtsM StgExpr) -> SDoc -> CtsM StgExpr
forall a b. (a -> b) -> a -> b
$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Unexpected value lambda:" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ CoreArg -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreArg
expr
coreToStgExpr (Tick CoreTickish
tick CoreArg
expr)
= do
let !stg_tick :: StgTickish
stg_tick = RuntimeRepType -> CoreTickish -> StgTickish
coreToStgTick ((() :: Constraint) => CoreArg -> RuntimeRepType
CoreArg -> RuntimeRepType
exprType CoreArg
expr) CoreTickish
tick
!StgExpr
expr2 <- (() :: Constraint) => CoreArg -> CtsM StgExpr
CoreArg -> CtsM StgExpr
coreToStgExpr CoreArg
expr
StgExpr -> CtsM StgExpr
forall a. a -> CtsM a
forall (m :: * -> *) a. Monad m => a -> m a
return (StgTickish -> StgExpr -> StgExpr
forall (pass :: StgPass).
StgTickish -> GenStgExpr pass -> GenStgExpr pass
StgTick StgTickish
stg_tick StgExpr
expr2)
coreToStgExpr (Cast CoreArg
expr Coercion
_)
= (() :: Constraint) => CoreArg -> CtsM StgExpr
CoreArg -> CtsM StgExpr
coreToStgExpr CoreArg
expr
coreToStgExpr (Case CoreArg
scrut Id
bndr RuntimeRepType
_ [Alt Id]
alts)
= do { StgExpr
scrut2 <- (() :: Constraint) => CoreArg -> CtsM StgExpr
CoreArg -> CtsM StgExpr
coreToStgExpr CoreArg
scrut
; [StgAlt]
alts2 <- [(Id, HowBound)] -> CtsM [StgAlt] -> CtsM [StgAlt]
forall a. [(Id, HowBound)] -> CtsM a -> CtsM a
extendVarEnvCts [(Id
bndr, HowBound
LambdaBound)] ((Alt Id -> CtsM StgAlt) -> [Alt Id] -> CtsM [StgAlt]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Alt Id -> CtsM StgAlt
vars_alt [Alt Id]
alts)
; StgExpr -> CtsM StgExpr
forall a. a -> CtsM a
forall (m :: * -> *) a. Monad m => a -> m a
return (StgExpr -> BinderP 'Vanilla -> AltType -> [StgAlt] -> StgExpr
forall (pass :: StgPass).
GenStgExpr pass
-> BinderP pass -> AltType -> [GenStgAlt pass] -> GenStgExpr pass
StgCase StgExpr
scrut2 Id
BinderP 'Vanilla
bndr (Id -> [Alt Id] -> AltType
mkStgAltType Id
bndr [Alt Id]
alts) [StgAlt]
alts2) }
where
vars_alt :: CoreAlt -> CtsM StgAlt
vars_alt :: Alt Id -> CtsM StgAlt
vars_alt (Alt AltCon
con [Id]
binders CoreArg
rhs)
= let
binders' :: [Id]
binders' = [Id] -> [Id]
filterStgBinders [Id]
binders
in
[(Id, HowBound)] -> CtsM StgAlt -> CtsM StgAlt
forall a. [(Id, HowBound)] -> CtsM a -> CtsM a
extendVarEnvCts [(Id
b, HowBound
LambdaBound) | Id
b <- [Id]
binders'] (CtsM StgAlt -> CtsM StgAlt) -> CtsM StgAlt -> CtsM StgAlt
forall a b. (a -> b) -> a -> b
$ do
StgExpr
rhs2 <- (() :: Constraint) => CoreArg -> CtsM StgExpr
CoreArg -> CtsM StgExpr
coreToStgExpr CoreArg
rhs
StgAlt -> CtsM StgAlt
forall a. a -> CtsM a
forall (m :: * -> *) a. Monad m => a -> m a
return (StgAlt -> CtsM StgAlt) -> StgAlt -> CtsM StgAlt
forall a b. (a -> b) -> a -> b
$! GenStgAlt{ alt_con :: AltCon
alt_con = AltCon
con
, alt_bndrs :: [BinderP 'Vanilla]
alt_bndrs = [Id]
[BinderP 'Vanilla]
binders'
, alt_rhs :: StgExpr
alt_rhs = StgExpr
rhs2
}
coreToStgExpr (Let CoreBind
bind CoreArg
body) = CoreBind -> CoreArg -> CtsM StgExpr
coreToStgLet CoreBind
bind CoreArg
body
coreToStgExpr CoreArg
e = String -> SDoc -> CtsM StgExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"coreToStgExpr" (CoreArg -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreArg
e)
mkStgAltType :: Id -> [CoreAlt] -> AltType
mkStgAltType :: Id -> [Alt Id] -> AltType
mkStgAltType Id
bndr [Alt Id]
alts
| RuntimeRepType -> Bool
isUnboxedTupleType RuntimeRepType
bndr_ty Bool -> Bool -> Bool
|| RuntimeRepType -> Bool
isUnboxedSumType RuntimeRepType
bndr_ty
= Arity -> AltType
MultiValAlt ([PrimRep] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [PrimRep]
prim_reps)
| Bool
otherwise
= case [PrimRep]
prim_reps of
[PrimRep
rep] | PrimRep -> Bool
isGcPtrRep PrimRep
rep ->
case RuntimeRepType -> Maybe TyCon
tyConAppTyCon_maybe (RuntimeRepType -> RuntimeRepType
unwrapType RuntimeRepType
bndr_ty) of
Just TyCon
tc
| TyCon -> Bool
isAbstractTyCon TyCon
tc -> AltType
look_for_better_tycon
| TyCon -> Bool
isAlgTyCon TyCon
tc -> TyCon -> AltType
AlgAlt TyCon
tc
| Bool
otherwise -> Bool -> SDoc -> AltType -> AltType
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (TyCon -> Bool
_is_poly_alt_tycon TyCon
tc) (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc) AltType
PolyAlt
Maybe TyCon
Nothing -> AltType
PolyAlt
[PrimRep
non_gcd] -> PrimRep -> AltType
PrimAlt PrimRep
non_gcd
[PrimRep]
not_unary -> Arity -> AltType
MultiValAlt ([PrimRep] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [PrimRep]
not_unary)
where
bndr_ty :: RuntimeRepType
bndr_ty = Id -> RuntimeRepType
idType Id
bndr
prim_reps :: [PrimRep]
prim_reps = (() :: Constraint) => RuntimeRepType -> [PrimRep]
RuntimeRepType -> [PrimRep]
typePrimRep RuntimeRepType
bndr_ty
_is_poly_alt_tycon :: TyCon -> Bool
_is_poly_alt_tycon TyCon
tc
= TyCon -> Bool
isPrimTyCon TyCon
tc
Bool -> Bool -> Bool
|| TyCon -> Bool
isFamilyTyCon TyCon
tc
look_for_better_tycon :: AltType
look_for_better_tycon
| ((Alt (DataAlt DataCon
con) [Id]
_ CoreArg
_) : [Alt Id]
_) <- [Alt Id]
data_alts =
TyCon -> AltType
AlgAlt (DataCon -> TyCon
dataConTyCon DataCon
con)
| Bool
otherwise =
Bool -> AltType -> AltType
forall a. HasCallStack => Bool -> a -> a
assert ([Alt Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Alt Id]
data_alts)
AltType
PolyAlt
where
([Alt Id]
data_alts, Maybe CoreArg
_deflt) = [Alt Id] -> ([Alt Id], Maybe CoreArg)
forall b. [Alt b] -> ([Alt b], Maybe (Expr b))
findDefault [Alt Id]
alts
coreToStgApp :: Id
-> [CoreArg]
-> [CoreTickish]
-> CtsM StgExpr
coreToStgApp :: Id -> [CoreArg] -> [CoreTickish] -> CtsM StgExpr
coreToStgApp Id
f [CoreArg]
args [CoreTickish]
ticks = do
([StgArg]
args', [StgTickish]
ticks') <- [CoreArg] -> CtsM ([StgArg], [StgTickish])
coreToStgArgs [CoreArg]
args
HowBound
how_bound <- Id -> CtsM HowBound
lookupVarCts Id
f
let
n_val_args :: Arity
n_val_args = [CoreArg] -> Arity
forall b. [Arg b] -> Arity
valArgCount [CoreArg]
args
f_arity :: Arity
f_arity = Id -> HowBound -> Arity
stgArity Id
f HowBound
how_bound
saturated :: Bool
saturated = Arity
f_arity Arity -> Arity -> Bool
forall a. Ord a => a -> a -> Bool
<= Arity
n_val_args
res_ty :: RuntimeRepType
res_ty = (() :: Constraint) => CoreArg -> RuntimeRepType
CoreArg -> RuntimeRepType
exprType (CoreArg -> [CoreArg] -> CoreArg
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreArg
forall b. Id -> Expr b
Var Id
f) [CoreArg]
args)
app :: StgExpr
app = case Id -> IdDetails
idDetails Id
f of
DataConWorkId DataCon
dc
| Bool
saturated -> DataCon
-> ConstructorNumber -> [StgArg] -> [RuntimeRepType] -> StgExpr
forall (pass :: StgPass).
DataCon
-> ConstructorNumber
-> [StgArg]
-> [RuntimeRepType]
-> GenStgExpr pass
StgConApp DataCon
dc ConstructorNumber
NoNumber [StgArg]
args'
([RuntimeRepType] -> [RuntimeRepType]
dropRuntimeRepArgs ([RuntimeRepType] -> Maybe [RuntimeRepType] -> [RuntimeRepType]
forall a. a -> Maybe a -> a
fromMaybe [] (RuntimeRepType -> Maybe [RuntimeRepType]
tyConAppArgs_maybe RuntimeRepType
res_ty)))
PrimOpId PrimOp
op Bool
_ ->
StgOp -> [StgArg] -> RuntimeRepType -> StgExpr
forall (pass :: StgPass).
StgOp -> [StgArg] -> RuntimeRepType -> GenStgExpr pass
StgOpApp (PrimOp -> StgOp
StgPrimOp PrimOp
op) [StgArg]
args' RuntimeRepType
res_ty
FCallId (CCall (CCallSpec (StaticTarget SourceText
_ CLabelString
lbl (Just Unit
pkgId) Bool
True)
CCallConv
PrimCallConv Safety
_))
-> Bool -> StgExpr -> StgExpr
forall a. HasCallStack => Bool -> a -> a
assert Bool
saturated (StgExpr -> StgExpr) -> StgExpr -> StgExpr
forall a b. (a -> b) -> a -> b
$
StgOp -> [StgArg] -> RuntimeRepType -> StgExpr
forall (pass :: StgPass).
StgOp -> [StgArg] -> RuntimeRepType -> GenStgExpr pass
StgOpApp (PrimCall -> StgOp
StgPrimCallOp (CLabelString -> Unit -> PrimCall
PrimCall CLabelString
lbl Unit
pkgId)) [StgArg]
args' RuntimeRepType
res_ty
FCallId ForeignCall
call -> Bool -> StgExpr -> StgExpr
forall a. HasCallStack => Bool -> a -> a
assert Bool
saturated (StgExpr -> StgExpr) -> StgExpr -> StgExpr
forall a b. (a -> b) -> a -> b
$
StgOp -> [StgArg] -> RuntimeRepType -> StgExpr
forall (pass :: StgPass).
StgOp -> [StgArg] -> RuntimeRepType -> GenStgExpr pass
StgOpApp (ForeignCall -> RuntimeRepType -> StgOp
StgFCallOp ForeignCall
call (Id -> RuntimeRepType
idType Id
f)) [StgArg]
args' RuntimeRepType
res_ty
TickBoxOpId {} -> String -> SDoc -> StgExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"coreToStg TickBox" (SDoc -> StgExpr) -> SDoc -> StgExpr
forall a b. (a -> b) -> a -> b
$ (Id, [StgArg]) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id
f,[StgArg]
args')
IdDetails
_other -> Id -> [StgArg] -> StgExpr
forall (pass :: StgPass). Id -> [StgArg] -> GenStgExpr pass
StgApp Id
f [StgArg]
args'
add_tick :: StgTickish -> GenStgExpr pass -> GenStgExpr pass
add_tick !StgTickish
t !GenStgExpr pass
e = StgTickish -> GenStgExpr pass -> GenStgExpr pass
forall (pass :: StgPass).
StgTickish -> GenStgExpr pass -> GenStgExpr pass
StgTick StgTickish
t GenStgExpr pass
e
tapp :: StgExpr
tapp = (StgTickish -> StgExpr -> StgExpr)
-> StgExpr -> [StgTickish] -> StgExpr
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr StgTickish -> StgExpr -> StgExpr
forall (pass :: StgPass).
StgTickish -> GenStgExpr pass -> GenStgExpr pass
add_tick StgExpr
app ((CoreTickish -> StgTickish) -> [CoreTickish] -> [StgTickish]
forall a b. (a -> b) -> [a] -> [b]
map (RuntimeRepType -> CoreTickish -> StgTickish
coreToStgTick RuntimeRepType
res_ty) [CoreTickish]
ticks [StgTickish] -> [StgTickish] -> [StgTickish]
forall a. [a] -> [a] -> [a]
++ [StgTickish]
ticks')
StgExpr
app StgExpr -> CtsM StgExpr -> CtsM StgExpr
forall a b. a -> b -> b
`seq` StgExpr -> CtsM StgExpr
forall a. a -> CtsM a
forall (m :: * -> *) a. Monad m => a -> m a
return StgExpr
tapp
coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [StgTickish])
coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [StgTickish])
coreToStgArgs []
= ([StgArg], [StgTickish]) -> CtsM ([StgArg], [StgTickish])
forall a. a -> CtsM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
coreToStgArgs (Type RuntimeRepType
_ : [CoreArg]
args) = do
([StgArg]
args', [StgTickish]
ts) <- [CoreArg] -> CtsM ([StgArg], [StgTickish])
coreToStgArgs [CoreArg]
args
([StgArg], [StgTickish]) -> CtsM ([StgArg], [StgTickish])
forall a. a -> CtsM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([StgArg]
args', [StgTickish]
ts)
coreToStgArgs (Coercion Coercion
_ : [CoreArg]
args)
= do { ([StgArg]
args', [StgTickish]
ts) <- [CoreArg] -> CtsM ([StgArg], [StgTickish])
coreToStgArgs [CoreArg]
args
; ([StgArg], [StgTickish]) -> CtsM ([StgArg], [StgTickish])
forall a. a -> CtsM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> StgArg
StgVarArg Id
coercionTokenId StgArg -> [StgArg] -> [StgArg]
forall a. a -> [a] -> [a]
: [StgArg]
args', [StgTickish]
ts) }
coreToStgArgs (Tick CoreTickish
t CoreArg
e : [CoreArg]
args)
= Bool
-> CtsM ([StgArg], [StgTickish]) -> CtsM ([StgArg], [StgTickish])
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode CoreTickish
t)) (CtsM ([StgArg], [StgTickish]) -> CtsM ([StgArg], [StgTickish]))
-> CtsM ([StgArg], [StgTickish]) -> CtsM ([StgArg], [StgTickish])
forall a b. (a -> b) -> a -> b
$
do { ([StgArg]
args', [StgTickish]
ts) <- [CoreArg] -> CtsM ([StgArg], [StgTickish])
coreToStgArgs (CoreArg
e CoreArg -> [CoreArg] -> [CoreArg]
forall a. a -> [a] -> [a]
: [CoreArg]
args)
; let !t' :: StgTickish
t' = RuntimeRepType -> CoreTickish -> StgTickish
coreToStgTick ((() :: Constraint) => CoreArg -> RuntimeRepType
CoreArg -> RuntimeRepType
exprType CoreArg
e) CoreTickish
t
; ([StgArg], [StgTickish]) -> CtsM ([StgArg], [StgTickish])
forall a. a -> CtsM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([StgArg]
args', StgTickish
t'StgTickish -> [StgTickish] -> [StgTickish]
forall a. a -> [a] -> [a]
:[StgTickish]
ts) }
coreToStgArgs (CoreArg
arg : [CoreArg]
args) = do
([StgArg]
stg_args, [StgTickish]
ticks) <- [CoreArg] -> CtsM ([StgArg], [StgTickish])
coreToStgArgs [CoreArg]
args
StgExpr
arg' <- (() :: Constraint) => CoreArg -> CtsM StgExpr
CoreArg -> CtsM StgExpr
coreToStgExpr CoreArg
arg
let
([StgTickish]
aticks, StgExpr
arg'') = (StgTickish -> Bool) -> StgExpr -> ([StgTickish], StgExpr)
forall (p :: StgPass).
(StgTickish -> Bool)
-> GenStgExpr p -> ([StgTickish], GenStgExpr p)
stripStgTicksTop StgTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable StgExpr
arg'
stg_arg :: StgArg
stg_arg = case StgExpr
arg'' of
StgApp Id
v [] -> Id -> StgArg
StgVarArg Id
v
StgConApp DataCon
con ConstructorNumber
_ [] [RuntimeRepType]
_ -> Id -> StgArg
StgVarArg (DataCon -> Id
dataConWorkId DataCon
con)
StgOpApp (StgPrimOp PrimOp
op) [] RuntimeRepType
_ -> Id -> StgArg
StgVarArg (PrimOp -> Id
primOpWrapperId PrimOp
op)
StgLit Literal
lit -> Literal -> StgArg
StgLitArg Literal
lit
StgExpr
_ -> String -> SDoc -> StgArg
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"coreToStgArgs" (CoreArg -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreArg
arg SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ StgPprOpts -> StgExpr -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> GenStgExpr pass -> SDoc
pprStgExpr StgPprOpts
panicStgPprOpts StgExpr
arg' SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ StgPprOpts -> StgExpr -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> GenStgExpr pass -> SDoc
pprStgExpr StgPprOpts
panicStgPprOpts StgExpr
arg'')
Platform
platform <- CtsM Platform
getPlatform
let
arg_rep :: [PrimRep]
arg_rep = (() :: Constraint) => RuntimeRepType -> [PrimRep]
RuntimeRepType -> [PrimRep]
typePrimRep ((() :: Constraint) => CoreArg -> RuntimeRepType
CoreArg -> RuntimeRepType
exprType CoreArg
arg)
stg_arg_rep :: [PrimRep]
stg_arg_rep = (() :: Constraint) => RuntimeRepType -> [PrimRep]
RuntimeRepType -> [PrimRep]
typePrimRep (StgArg -> RuntimeRepType
stgArgType StgArg
stg_arg)
bad_args :: Bool
bad_args = Bool -> Bool
not (Platform -> [PrimRep] -> [PrimRep] -> Bool
primRepsCompatible Platform
platform [PrimRep]
arg_rep [PrimRep]
stg_arg_rep)
Bool
-> String
-> SDoc
-> CtsM ([StgArg], [StgTickish])
-> CtsM ([StgArg], [StgTickish])
forall a. HasCallStack => Bool -> String -> SDoc -> a -> a
warnPprTrace Bool
bad_args String
"Dangerous-looking argument. Probable cause: bad unsafeCoerce#" (CoreArg -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreArg
arg) (CtsM ([StgArg], [StgTickish]) -> CtsM ([StgArg], [StgTickish]))
-> CtsM ([StgArg], [StgTickish]) -> CtsM ([StgArg], [StgTickish])
forall a b. (a -> b) -> a -> b
$
([StgArg], [StgTickish]) -> CtsM ([StgArg], [StgTickish])
forall a. a -> CtsM a
forall (m :: * -> *) a. Monad m => a -> m a
return (StgArg
stg_arg StgArg -> [StgArg] -> [StgArg]
forall a. a -> [a] -> [a]
: [StgArg]
stg_args, [StgTickish]
ticks [StgTickish] -> [StgTickish] -> [StgTickish]
forall a. [a] -> [a] -> [a]
++ [StgTickish]
aticks)
coreToStgTick :: Type
-> CoreTickish
-> StgTickish
coreToStgTick :: RuntimeRepType -> CoreTickish -> StgTickish
coreToStgTick RuntimeRepType
_ty (HpcTick Module
m Arity
i) = Module -> Arity -> StgTickish
forall (pass :: TickishPass). Module -> Arity -> GenTickish pass
HpcTick Module
m Arity
i
coreToStgTick RuntimeRepType
_ty (SourceNote RealSrcSpan
span String
nm) = RealSrcSpan -> String -> StgTickish
forall (pass :: TickishPass).
RealSrcSpan -> String -> GenTickish pass
SourceNote RealSrcSpan
span String
nm
coreToStgTick RuntimeRepType
_ty (ProfNote CostCentre
cc Bool
cnt Bool
scope) = CostCentre -> Bool -> Bool -> StgTickish
forall (pass :: TickishPass).
CostCentre -> Bool -> Bool -> GenTickish pass
ProfNote CostCentre
cc Bool
cnt Bool
scope
coreToStgTick !RuntimeRepType
ty (Breakpoint XBreakpoint 'TickishPassCore
_ Arity
bid [XTickishId 'TickishPassCore]
fvs) = XBreakpoint 'TickishPassStg
-> Arity -> [XTickishId 'TickishPassStg] -> StgTickish
forall (pass :: TickishPass).
XBreakpoint pass -> Arity -> [XTickishId pass] -> GenTickish pass
Breakpoint RuntimeRepType
XBreakpoint 'TickishPassStg
ty Arity
bid [XTickishId 'TickishPassCore]
[XTickishId 'TickishPassStg]
fvs
coreToStgLet
:: CoreBind
-> CoreExpr
-> CtsM StgExpr
coreToStgLet :: CoreBind -> CoreArg -> CtsM StgExpr
coreToStgLet CoreBind
bind CoreArg
body
| NonRec Id
_ CoreArg
rhs <- CoreBind
bind, CoreArg -> Bool
forall b. Expr b -> Bool
isTyCoArg CoreArg
rhs
= (() :: Constraint) => CoreArg -> CtsM StgExpr
CoreArg -> CtsM StgExpr
coreToStgExpr CoreArg
body
| Bool
otherwise
= do { (GenStgBinding 'Vanilla
bind2, [(Id, HowBound)]
env_ext) <- CoreBind -> CtsM (GenStgBinding 'Vanilla, [(Id, HowBound)])
vars_bind CoreBind
bind
; StgExpr
body2 <- [(Id, HowBound)] -> CtsM StgExpr -> CtsM StgExpr
forall a. [(Id, HowBound)] -> CtsM a -> CtsM a
extendVarEnvCts [(Id, HowBound)]
env_ext (CtsM StgExpr -> CtsM StgExpr) -> CtsM StgExpr -> CtsM StgExpr
forall a b. (a -> b) -> a -> b
$
(() :: Constraint) => CoreArg -> CtsM StgExpr
CoreArg -> CtsM StgExpr
coreToStgExpr CoreArg
body
; let new_let :: StgExpr
new_let | CoreBind -> Bool
isJoinBind CoreBind
bind
= XLetNoEscape 'Vanilla
-> GenStgBinding 'Vanilla -> StgExpr -> StgExpr
forall (pass :: StgPass).
XLetNoEscape pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLetNoEscape XLetNoEscape 'Vanilla
NoExtFieldSilent
noExtFieldSilent GenStgBinding 'Vanilla
bind2 StgExpr
body2
| Bool
otherwise
= XLet 'Vanilla -> GenStgBinding 'Vanilla -> StgExpr -> StgExpr
forall (pass :: StgPass).
XLet pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLet XLet 'Vanilla
NoExtFieldSilent
noExtFieldSilent GenStgBinding 'Vanilla
bind2 StgExpr
body2
; StgExpr -> CtsM StgExpr
forall a. a -> CtsM a
forall (m :: * -> *) a. Monad m => a -> m a
return StgExpr
new_let }
where
mk_binding :: a -> CoreArg -> (a, HowBound)
mk_binding a
binder CoreArg
rhs
= (a
binder, LetInfo -> Arity -> HowBound
LetBound LetInfo
NestedLet (CoreArg -> Arity
manifestArity CoreArg
rhs))
vars_bind :: CoreBind
-> CtsM (StgBinding,
[(Id, HowBound)])
vars_bind :: CoreBind -> CtsM (GenStgBinding 'Vanilla, [(Id, HowBound)])
vars_bind (NonRec Id
binder CoreArg
rhs) = do
StgRhs
rhs2 <- (Id, CoreArg) -> CtsM StgRhs
coreToStgRhs (Id
binder,CoreArg
rhs)
let
env_ext_item :: (Id, HowBound)
env_ext_item = Id -> CoreArg -> (Id, HowBound)
forall {a}. a -> CoreArg -> (a, HowBound)
mk_binding Id
binder CoreArg
rhs
(GenStgBinding 'Vanilla, [(Id, HowBound)])
-> CtsM (GenStgBinding 'Vanilla, [(Id, HowBound)])
forall a. a -> CtsM a
forall (m :: * -> *) a. Monad m => a -> m a
return (BinderP 'Vanilla -> StgRhs -> GenStgBinding 'Vanilla
forall (pass :: StgPass).
BinderP pass -> GenStgRhs pass -> GenStgBinding pass
StgNonRec Id
BinderP 'Vanilla
binder StgRhs
rhs2, [(Id, HowBound)
env_ext_item])
vars_bind (Rec [(Id, CoreArg)]
pairs)
= let
binders :: [Id]
binders = ((Id, CoreArg) -> Id) -> [(Id, CoreArg)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, CoreArg) -> Id
forall a b. (a, b) -> a
fst [(Id, CoreArg)]
pairs
env_ext :: [(Id, HowBound)]
env_ext = [ Id -> CoreArg -> (Id, HowBound)
forall {a}. a -> CoreArg -> (a, HowBound)
mk_binding Id
b CoreArg
rhs
| (Id
b,CoreArg
rhs) <- [(Id, CoreArg)]
pairs ]
in
[(Id, HowBound)]
-> CtsM (GenStgBinding 'Vanilla, [(Id, HowBound)])
-> CtsM (GenStgBinding 'Vanilla, [(Id, HowBound)])
forall a. [(Id, HowBound)] -> CtsM a -> CtsM a
extendVarEnvCts [(Id, HowBound)]
env_ext (CtsM (GenStgBinding 'Vanilla, [(Id, HowBound)])
-> CtsM (GenStgBinding 'Vanilla, [(Id, HowBound)]))
-> CtsM (GenStgBinding 'Vanilla, [(Id, HowBound)])
-> CtsM (GenStgBinding 'Vanilla, [(Id, HowBound)])
forall a b. (a -> b) -> a -> b
$ do
[StgRhs]
rhss2 <- ((Id, CoreArg) -> CtsM StgRhs) -> [(Id, CoreArg)] -> CtsM [StgRhs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Id, CoreArg) -> CtsM StgRhs
coreToStgRhs [(Id, CoreArg)]
pairs
(GenStgBinding 'Vanilla, [(Id, HowBound)])
-> CtsM (GenStgBinding 'Vanilla, [(Id, HowBound)])
forall a. a -> CtsM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(BinderP 'Vanilla, StgRhs)] -> GenStgBinding 'Vanilla
forall (pass :: StgPass).
[(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass
StgRec ([Id]
binders [Id] -> [StgRhs] -> [(Id, StgRhs)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [StgRhs]
rhss2), [(Id, HowBound)]
env_ext)
coreToStgRhs :: (Id,CoreExpr)
-> CtsM StgRhs
coreToStgRhs :: (Id, CoreArg) -> CtsM StgRhs
coreToStgRhs (Id
bndr, CoreArg
rhs) = do
PreStgRhs
new_rhs <- (() :: Constraint) => CoreArg -> CtsM PreStgRhs
CoreArg -> CtsM PreStgRhs
coreToPreStgRhs CoreArg
rhs
StgRhs -> CtsM StgRhs
forall a. a -> CtsM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> PreStgRhs -> StgRhs
mkStgRhs Id
bndr PreStgRhs
new_rhs)
data PreStgRhs = PreStgRhs [Id] StgExpr
coreToPreStgRhs :: HasDebugCallStack => CoreExpr -> CtsM PreStgRhs
coreToPreStgRhs :: (() :: Constraint) => CoreArg -> CtsM PreStgRhs
coreToPreStgRhs CoreArg
expr
= [(Id, HowBound)] -> CtsM PreStgRhs -> CtsM PreStgRhs
forall a. [(Id, HowBound)] -> CtsM a -> CtsM a
extendVarEnvCts [ (Id
a, HowBound
LambdaBound) | Id
a <- [Id]
args' ] (CtsM PreStgRhs -> CtsM PreStgRhs)
-> CtsM PreStgRhs -> CtsM PreStgRhs
forall a b. (a -> b) -> a -> b
$
do { StgExpr
body' <- (() :: Constraint) => CoreArg -> CtsM StgExpr
CoreArg -> CtsM StgExpr
coreToStgExpr CoreArg
body
; PreStgRhs -> CtsM PreStgRhs
forall a. a -> CtsM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id] -> StgExpr -> PreStgRhs
PreStgRhs [Id]
args' StgExpr
body') }
where
([Id]
args, CoreArg
body) = CoreArg -> ([Id], CoreArg)
myCollectBinders CoreArg
expr
args' :: [Id]
args' = [Id] -> [Id]
filterStgBinders [Id]
args
mkTopStgRhs :: CoreToStgOpts -> Module -> CollectedCCs
-> Id -> PreStgRhs -> (StgRhs, CollectedCCs)
mkTopStgRhs :: CoreToStgOpts
-> Module
-> CollectedCCs
-> Id
-> PreStgRhs
-> (StgRhs, CollectedCCs)
mkTopStgRhs CoreToStgOpts
{ coreToStg_platform :: CoreToStgOpts -> Platform
coreToStg_platform = Platform
platform
, coreToStg_ExternalDynamicRefs :: CoreToStgOpts -> Bool
coreToStg_ExternalDynamicRefs = Bool
opt_ExternalDynamicRefs
, coreToStg_AutoSccsOnIndividualCafs :: CoreToStgOpts -> Bool
coreToStg_AutoSccsOnIndividualCafs = Bool
opt_AutoSccsOnIndividualCafs
} Module
this_mod CollectedCCs
ccs Id
bndr (PreStgRhs [Id]
bndrs StgExpr
rhs)
| Bool -> Bool
not ([Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
bndrs)
=
( XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> StgExpr
-> StgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
NoExtFieldSilent
noExtFieldSilent
CostCentreStack
dontCareCCS
UpdateFlag
ReEntrant
[Id]
[BinderP 'Vanilla]
bndrs StgExpr
rhs
, CollectedCCs
ccs )
| StgConApp DataCon
con ConstructorNumber
mn [StgArg]
args [RuntimeRepType]
_ <- StgExpr
unticked_rhs
,
Bool -> Bool
not (Platform -> Bool -> Module -> DataCon -> [StgArg] -> Bool
isDllConApp Platform
platform Bool
opt_ExternalDynamicRefs Module
this_mod DataCon
con [StgArg]
args)
=
Bool -> SDoc -> (StgRhs, CollectedCCs) -> (StgRhs, CollectedCCs)
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Bool -> Bool
not (DataCon -> Bool
isUnboxedTupleDataCon DataCon
con Bool -> Bool -> Bool
|| DataCon -> Bool
isUnboxedSumDataCon DataCon
con))
(Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
bndr SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
con SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [StgArg] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [StgArg]
args)
( CostCentreStack
-> DataCon
-> ConstructorNumber
-> [StgTickish]
-> [StgArg]
-> StgRhs
forall (pass :: StgPass).
CostCentreStack
-> DataCon
-> ConstructorNumber
-> [StgTickish]
-> [StgArg]
-> GenStgRhs pass
StgRhsCon CostCentreStack
dontCareCCS DataCon
con ConstructorNumber
mn [StgTickish]
ticks [StgArg]
args, CollectedCCs
ccs )
| Bool
opt_AutoSccsOnIndividualCafs
= ( XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> StgExpr
-> StgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
NoExtFieldSilent
noExtFieldSilent
CostCentreStack
caf_ccs
UpdateFlag
upd_flag [] StgExpr
rhs
, CostCentre -> CostCentreStack -> CollectedCCs -> CollectedCCs
collectCC CostCentre
caf_cc CostCentreStack
caf_ccs CollectedCCs
ccs )
| Bool
otherwise
= ( XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> StgExpr
-> StgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
NoExtFieldSilent
noExtFieldSilent
CostCentreStack
all_cafs_ccs
UpdateFlag
upd_flag [] StgExpr
rhs
, CollectedCCs
ccs )
where
([StgTickish]
ticks, StgExpr
unticked_rhs) = (StgTickish -> Bool) -> StgExpr -> ([StgTickish], StgExpr)
forall (p :: StgPass).
(StgTickish -> Bool)
-> GenStgExpr p -> ([StgTickish], GenStgExpr p)
stripStgTicksTop (Bool -> Bool
not (Bool -> Bool) -> (StgTickish -> Bool) -> StgTickish -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StgTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode) StgExpr
rhs
upd_flag :: UpdateFlag
upd_flag | Demand -> Bool
isUsedOnceDmd (Id -> Demand
idDemandInfo Id
bndr) = UpdateFlag
SingleEntry
| Bool
otherwise = UpdateFlag
Updatable
caf_cc :: CostCentre
caf_cc = Id -> Module -> CostCentre
mkAutoCC Id
bndr Module
modl
caf_ccs :: CostCentreStack
caf_ccs = CostCentre -> CostCentreStack
mkSingletonCCS CostCentre
caf_cc
modl :: Module
modl | Just Module
m <- Name -> Maybe Module
nameModule_maybe (Id -> Name
idName Id
bndr) = Module
m
| Bool
otherwise = Module
this_mod
(CostCentre
_, CostCentreStack
all_cafs_ccs) = Module -> (CostCentre, CostCentreStack)
getAllCAFsCC Module
this_mod
mkStgRhs :: Id -> PreStgRhs -> StgRhs
mkStgRhs :: Id -> PreStgRhs -> StgRhs
mkStgRhs Id
bndr (PreStgRhs [Id]
bndrs StgExpr
rhs)
| Bool -> Bool
not ([Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
bndrs)
= XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> StgExpr
-> StgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
NoExtFieldSilent
noExtFieldSilent
CostCentreStack
currentCCS
UpdateFlag
ReEntrant
[Id]
[BinderP 'Vanilla]
bndrs StgExpr
rhs
| Id -> Bool
isJoinId Id
bndr
=
XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> StgExpr
-> StgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
NoExtFieldSilent
noExtFieldSilent
CostCentreStack
currentCCS
UpdateFlag
ReEntrant
[] StgExpr
rhs
| StgConApp DataCon
con ConstructorNumber
mn [StgArg]
args [RuntimeRepType]
_ <- StgExpr
unticked_rhs
= CostCentreStack
-> DataCon
-> ConstructorNumber
-> [StgTickish]
-> [StgArg]
-> StgRhs
forall (pass :: StgPass).
CostCentreStack
-> DataCon
-> ConstructorNumber
-> [StgTickish]
-> [StgArg]
-> GenStgRhs pass
StgRhsCon CostCentreStack
currentCCS DataCon
con ConstructorNumber
mn [StgTickish]
ticks [StgArg]
args
| Bool
otherwise
= XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> StgExpr
-> StgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
NoExtFieldSilent
noExtFieldSilent
CostCentreStack
currentCCS
UpdateFlag
upd_flag [] StgExpr
rhs
where
([StgTickish]
ticks, StgExpr
unticked_rhs) = (StgTickish -> Bool) -> StgExpr -> ([StgTickish], StgExpr)
forall (p :: StgPass).
(StgTickish -> Bool)
-> GenStgExpr p -> ([StgTickish], GenStgExpr p)
stripStgTicksTop (Bool -> Bool
not (Bool -> Bool) -> (StgTickish -> Bool) -> StgTickish -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StgTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode) StgExpr
rhs
upd_flag :: UpdateFlag
upd_flag | Demand -> Bool
isUsedOnceDmd (Id -> Demand
idDemandInfo Id
bndr) = UpdateFlag
SingleEntry
| Bool
otherwise = UpdateFlag
Updatable
newtype CtsM a = CtsM
{ forall a. CtsM a -> Platform -> IdEnv HowBound -> a
unCtsM :: Platform
-> IdEnv HowBound
-> a
}
deriving ((forall a b. (a -> b) -> CtsM a -> CtsM b)
-> (forall a b. a -> CtsM b -> CtsM a) -> Functor CtsM
forall a b. a -> CtsM b -> CtsM a
forall a b. (a -> b) -> CtsM a -> CtsM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> CtsM a -> CtsM b
fmap :: forall a b. (a -> b) -> CtsM a -> CtsM b
$c<$ :: forall a b. a -> CtsM b -> CtsM a
<$ :: forall a b. a -> CtsM b -> CtsM a
Functor)
data HowBound
= ImportBound
| LetBound
LetInfo
Arity
| LambdaBound
deriving (HowBound -> HowBound -> Bool
(HowBound -> HowBound -> Bool)
-> (HowBound -> HowBound -> Bool) -> Eq HowBound
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HowBound -> HowBound -> Bool
== :: HowBound -> HowBound -> Bool
$c/= :: HowBound -> HowBound -> Bool
/= :: HowBound -> HowBound -> Bool
Eq)
data LetInfo
= TopLet
| NestedLet
deriving (LetInfo -> LetInfo -> Bool
(LetInfo -> LetInfo -> Bool)
-> (LetInfo -> LetInfo -> Bool) -> Eq LetInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LetInfo -> LetInfo -> Bool
== :: LetInfo -> LetInfo -> Bool
$c/= :: LetInfo -> LetInfo -> Bool
/= :: LetInfo -> LetInfo -> Bool
Eq)
initCts :: Platform -> IdEnv HowBound -> CtsM a -> a
initCts :: forall a. Platform -> IdEnv HowBound -> CtsM a -> a
initCts Platform
platform IdEnv HowBound
env CtsM a
m = CtsM a -> Platform -> IdEnv HowBound -> a
forall a. CtsM a -> Platform -> IdEnv HowBound -> a
unCtsM CtsM a
m Platform
platform IdEnv HowBound
env
{-# INLINE thenCts #-}
{-# INLINE returnCts #-}
returnCts :: a -> CtsM a
returnCts :: forall a. a -> CtsM a
returnCts a
e = (Platform -> IdEnv HowBound -> a) -> CtsM a
forall a. (Platform -> IdEnv HowBound -> a) -> CtsM a
CtsM ((Platform -> IdEnv HowBound -> a) -> CtsM a)
-> (Platform -> IdEnv HowBound -> a) -> CtsM a
forall a b. (a -> b) -> a -> b
$ \Platform
_ IdEnv HowBound
_ -> a
e
thenCts :: CtsM a -> (a -> CtsM b) -> CtsM b
thenCts :: forall a b. CtsM a -> (a -> CtsM b) -> CtsM b
thenCts CtsM a
m a -> CtsM b
k = (Platform -> IdEnv HowBound -> b) -> CtsM b
forall a. (Platform -> IdEnv HowBound -> a) -> CtsM a
CtsM ((Platform -> IdEnv HowBound -> b) -> CtsM b)
-> (Platform -> IdEnv HowBound -> b) -> CtsM b
forall a b. (a -> b) -> a -> b
$ \Platform
platform IdEnv HowBound
env
-> CtsM b -> Platform -> IdEnv HowBound -> b
forall a. CtsM a -> Platform -> IdEnv HowBound -> a
unCtsM (a -> CtsM b
k (CtsM a -> Platform -> IdEnv HowBound -> a
forall a. CtsM a -> Platform -> IdEnv HowBound -> a
unCtsM CtsM a
m Platform
platform IdEnv HowBound
env)) Platform
platform IdEnv HowBound
env
instance Applicative CtsM where
pure :: forall a. a -> CtsM a
pure = a -> CtsM a
forall a. a -> CtsM a
returnCts
<*> :: forall a b. CtsM (a -> b) -> CtsM a -> CtsM b
(<*>) = CtsM (a -> b) -> CtsM a -> CtsM b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad CtsM where
>>= :: forall a b. CtsM a -> (a -> CtsM b) -> CtsM b
(>>=) = CtsM a -> (a -> CtsM b) -> CtsM b
forall a b. CtsM a -> (a -> CtsM b) -> CtsM b
thenCts
getPlatform :: CtsM Platform
getPlatform :: CtsM Platform
getPlatform = (Platform -> IdEnv HowBound -> Platform) -> CtsM Platform
forall a. (Platform -> IdEnv HowBound -> a) -> CtsM a
CtsM Platform -> IdEnv HowBound -> Platform
forall a b. a -> b -> a
const
extendVarEnvCts :: [(Id, HowBound)] -> CtsM a -> CtsM a
extendVarEnvCts :: forall a. [(Id, HowBound)] -> CtsM a -> CtsM a
extendVarEnvCts [(Id, HowBound)]
ids_w_howbound CtsM a
expr
= (Platform -> IdEnv HowBound -> a) -> CtsM a
forall a. (Platform -> IdEnv HowBound -> a) -> CtsM a
CtsM ((Platform -> IdEnv HowBound -> a) -> CtsM a)
-> (Platform -> IdEnv HowBound -> a) -> CtsM a
forall a b. (a -> b) -> a -> b
$ \Platform
platform IdEnv HowBound
env
-> CtsM a -> Platform -> IdEnv HowBound -> a
forall a. CtsM a -> Platform -> IdEnv HowBound -> a
unCtsM CtsM a
expr Platform
platform (IdEnv HowBound -> [(Id, HowBound)] -> IdEnv HowBound
forall a. VarEnv a -> [(Id, a)] -> VarEnv a
extendVarEnvList IdEnv HowBound
env [(Id, HowBound)]
ids_w_howbound)
lookupVarCts :: Id -> CtsM HowBound
lookupVarCts :: Id -> CtsM HowBound
lookupVarCts Id
v = (Platform -> IdEnv HowBound -> HowBound) -> CtsM HowBound
forall a. (Platform -> IdEnv HowBound -> a) -> CtsM a
CtsM ((Platform -> IdEnv HowBound -> HowBound) -> CtsM HowBound)
-> (Platform -> IdEnv HowBound -> HowBound) -> CtsM HowBound
forall a b. (a -> b) -> a -> b
$ \Platform
_ IdEnv HowBound
env -> IdEnv HowBound -> Id -> HowBound
lookupBinding IdEnv HowBound
env Id
v
lookupBinding :: IdEnv HowBound -> Id -> HowBound
lookupBinding :: IdEnv HowBound -> Id -> HowBound
lookupBinding IdEnv HowBound
env Id
v = case IdEnv HowBound -> Id -> Maybe HowBound
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv IdEnv HowBound
env Id
v of
Just HowBound
xx -> HowBound
xx
Maybe HowBound
Nothing -> Bool -> SDoc -> HowBound -> HowBound
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Id -> Bool
isGlobalId Id
v) (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
v) HowBound
ImportBound
getAllCAFsCC :: Module -> (CostCentre, CostCentreStack)
getAllCAFsCC :: Module -> (CostCentre, CostCentreStack)
getAllCAFsCC Module
this_mod =
let
span :: SrcSpan
span = CLabelString -> SrcSpan
mkGeneralSrcSpan (String -> CLabelString
mkFastString String
"<entire-module>")
all_cafs_cc :: CostCentre
all_cafs_cc = Module -> SrcSpan -> CostCentre
mkAllCafsCC Module
this_mod SrcSpan
span
all_cafs_ccs :: CostCentreStack
all_cafs_ccs = CostCentre -> CostCentreStack
mkSingletonCCS CostCentre
all_cafs_cc
in
(CostCentre
all_cafs_cc, CostCentreStack
all_cafs_ccs)
filterStgBinders :: [Var] -> [Var]
filterStgBinders :: [Id] -> [Id]
filterStgBinders [Id]
bndrs = (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filter Id -> Bool
isId [Id]
bndrs
myCollectBinders :: Expr Var -> ([Var], Expr Var)
myCollectBinders :: CoreArg -> ([Id], CoreArg)
myCollectBinders CoreArg
expr
= [Id] -> CoreArg -> ([Id], CoreArg)
forall {a}. [a] -> Expr a -> ([a], Expr a)
go [] CoreArg
expr
where
go :: [a] -> Expr a -> ([a], Expr a)
go [a]
bs (Lam a
b Expr a
e) = [a] -> Expr a -> ([a], Expr a)
go (a
ba -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
bs) Expr a
e
go [a]
bs (Cast Expr a
e Coercion
_) = [a] -> Expr a -> ([a], Expr a)
go [a]
bs Expr a
e
go [a]
bs Expr a
e = ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
bs, Expr a
e)
myCollectArgs :: HasDebugCallStack => CoreExpr -> (CoreExpr, [CoreArg], [CoreTickish])
myCollectArgs :: (() :: Constraint) =>
CoreArg -> (CoreArg, [CoreArg], [CoreTickish])
myCollectArgs CoreArg
expr
= CoreArg
-> [CoreArg]
-> [CoreTickish]
-> (CoreArg, [CoreArg], [CoreTickish])
go CoreArg
expr [] []
where
go :: CoreArg
-> [CoreArg]
-> [CoreTickish]
-> (CoreArg, [CoreArg], [CoreTickish])
go h :: CoreArg
h@(Var Id
_v) [CoreArg]
as [CoreTickish]
ts = (CoreArg
h, [CoreArg]
as, [CoreTickish]
ts)
go (App CoreArg
f CoreArg
a) [CoreArg]
as [CoreTickish]
ts = CoreArg
-> [CoreArg]
-> [CoreTickish]
-> (CoreArg, [CoreArg], [CoreTickish])
go CoreArg
f (CoreArg
aCoreArg -> [CoreArg] -> [CoreArg]
forall a. a -> [a] -> [a]
:[CoreArg]
as) [CoreTickish]
ts
go (Tick CoreTickish
t CoreArg
e) [CoreArg]
as [CoreTickish]
ts = Bool
-> SDoc
-> (CoreArg, [CoreArg], [CoreTickish])
-> (CoreArg, [CoreArg], [CoreTickish])
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Bool -> Bool
not (CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode CoreTickish
t) Bool -> Bool -> Bool
|| (CoreArg -> Bool) -> [CoreArg] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all CoreArg -> Bool
forall b. Expr b -> Bool
isTypeArg [CoreArg]
as)
(CoreArg -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreArg
e SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [CoreArg] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CoreArg]
as SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [CoreTickish] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CoreTickish]
ts) ((CoreArg, [CoreArg], [CoreTickish])
-> (CoreArg, [CoreArg], [CoreTickish]))
-> (CoreArg, [CoreArg], [CoreTickish])
-> (CoreArg, [CoreArg], [CoreTickish])
forall a b. (a -> b) -> a -> b
$
CoreArg
-> [CoreArg]
-> [CoreTickish]
-> (CoreArg, [CoreArg], [CoreTickish])
go CoreArg
e [CoreArg]
as (CoreTickish
tCoreTickish -> [CoreTickish] -> [CoreTickish]
forall a. a -> [a] -> [a]
:[CoreTickish]
ts)
go (Cast CoreArg
e Coercion
_) [CoreArg]
as [CoreTickish]
ts = CoreArg
-> [CoreArg]
-> [CoreTickish]
-> (CoreArg, [CoreArg], [CoreTickish])
go CoreArg
e [CoreArg]
as [CoreTickish]
ts
go (Lam Id
b CoreArg
e) [CoreArg]
as [CoreTickish]
ts
| Id -> Bool
isTyVar Id
b = CoreArg
-> [CoreArg]
-> [CoreTickish]
-> (CoreArg, [CoreArg], [CoreTickish])
go CoreArg
e [CoreArg]
as [CoreTickish]
ts
go CoreArg
e [CoreArg]
as [CoreTickish]
ts = (CoreArg
e, [CoreArg]
as, [CoreTickish]
ts)
stgArity :: Id -> HowBound -> Arity
stgArity :: Id -> HowBound -> Arity
stgArity Id
_ (LetBound LetInfo
_ Arity
arity) = Arity
arity
stgArity Id
f HowBound
ImportBound = Id -> Arity
idArity Id
f
stgArity Id
_ HowBound
LambdaBound = Arity
0
data CoreToStgOpts = CoreToStgOpts
{ CoreToStgOpts -> Platform
coreToStg_platform :: Platform
, CoreToStgOpts -> Ways
coreToStg_ways :: Ways
, CoreToStgOpts -> Bool
coreToStg_AutoSccsOnIndividualCafs :: Bool
, CoreToStgOpts -> Bool
coreToStg_InfoTableMap :: Bool
, CoreToStgOpts -> Bool
coreToStg_ExternalDynamicRefs :: Bool
, CoreToStgOpts -> StgDebugOpts
coreToStg_stgDebugOpts :: StgDebugOpts
}