{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TypeFamilies #-}
module GHC.CoreToStg ( coreToStg ) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Core
import GHC.Core.Utils ( exprType, findDefault, isJoinBind
, exprIsTickedString_maybe )
import GHC.Core.Opt.Arity ( manifestArity )
import GHC.Stg.Syntax
import GHC.Stg.Debug
import GHC.Core.Type
import GHC.Types.RepType
import GHC.Core.TyCon
import GHC.Types.Id.Make ( coercionTokenId )
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Core.DataCon
import GHC.Types.CostCentre
import GHC.Types.Tickish
import GHC.Types.Var.Env
import GHC.Unit.Module
import GHC.Types.Name ( isExternalName, nameModule_maybe )
import GHC.Types.Basic ( Arity )
import GHC.Builtin.Types ( unboxedUnitDataCon, unitDataConId )
import GHC.Types.Literal
import GHC.Utils.Outputable
import GHC.Utils.Monad
import GHC.Data.FastString
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Driver.Session
import GHC.Platform.Ways
import GHC.Driver.Ppr
import GHC.Types.ForeignCall
import GHC.Types.IPE
import GHC.Types.Demand ( isUsedOnceDmd )
import GHC.Builtin.PrimOps ( PrimCall(..) )
import GHC.Types.SrcLoc ( mkGeneralSrcSpan )
import Control.Monad (ap)
import Data.Maybe (fromMaybe)
import Data.Tuple (swap)
import qualified Data.Set as Set
coreToStg :: DynFlags -> Module -> ModLocation -> CoreProgram
-> ([StgTopBinding], InfoTableProvMap, CollectedCCs)
coreToStg :: DynFlags
-> Module
-> ModLocation
-> CoreProgram
-> ([StgTopBinding], InfoTableProvMap, CollectedCCs)
coreToStg DynFlags
dflags 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')
= DynFlags
-> Module
-> IdEnv HowBound
-> CollectedCCs
-> CoreProgram
-> (IdEnv HowBound, CollectedCCs, [StgTopBinding])
coreTopBindsToStg DynFlags
dflags Module
this_mod forall a. VarEnv a
emptyVarEnv CollectedCCs
emptyCollectedCCs CoreProgram
pgm
(![StgTopBinding]
pgm'', !InfoTableProvMap
denv) =
if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_InfoTableMap DynFlags
dflags
then DynFlags
-> ModLocation
-> [StgTopBinding]
-> ([StgTopBinding], InfoTableProvMap)
collectDebugInformation DynFlags
dflags ModLocation
ml [StgTopBinding]
pgm'
else ([StgTopBinding]
pgm', InfoTableProvMap
emptyInfoTableProvMap)
prof :: Bool
prof = Way
WayProf forall a. Ord a => a -> Set a -> Bool
`Set.member` DynFlags -> Ways
ways DynFlags
dflags
final_ccs :: CollectedCCs
final_ccs
| Bool
prof Bool -> Bool -> Bool
&& GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_AutoSccsOnIndividualCafs DynFlags
dflags
= ([CostCentre]
local_ccs,[CostCentreStack]
local_cc_stacks)
| Bool
prof
= (CostCentre
all_cafs_ccforall a. a -> [a] -> [a]
:[CostCentre]
local_ccs, CostCentreStack
all_cafs_ccsforall 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
:: DynFlags
-> Module
-> IdEnv HowBound
-> CollectedCCs
-> CoreProgram
-> (IdEnv HowBound, CollectedCCs, [StgTopBinding])
coreTopBindsToStg :: DynFlags
-> Module
-> IdEnv HowBound
-> CollectedCCs
-> CoreProgram
-> (IdEnv HowBound, CollectedCCs, [StgTopBinding])
coreTopBindsToStg DynFlags
_ Module
_ IdEnv HowBound
env CollectedCCs
ccs []
= (IdEnv HowBound
env, CollectedCCs
ccs, [])
coreTopBindsToStg DynFlags
dflags Module
this_mod IdEnv HowBound
env CollectedCCs
ccs (CoreBind
b:CoreProgram
bs)
| NonRec Var
_ Expr Var
rhs <- CoreBind
b, forall b. Expr b -> Bool
isTyCoArg Expr Var
rhs
= DynFlags
-> Module
-> IdEnv HowBound
-> CollectedCCs
-> CoreProgram
-> (IdEnv HowBound, CollectedCCs, [StgTopBinding])
coreTopBindsToStg DynFlags
dflags Module
this_mod IdEnv HowBound
env1 CollectedCCs
ccs1 CoreProgram
bs
| Bool
otherwise
= (IdEnv HowBound
env2, CollectedCCs
ccs2, StgTopBinding
b'forall a. a -> [a] -> [a]
:[StgTopBinding]
bs')
where
(IdEnv HowBound
env1, CollectedCCs
ccs1, StgTopBinding
b' ) = DynFlags
-> Module
-> IdEnv HowBound
-> CollectedCCs
-> CoreBind
-> (IdEnv HowBound, CollectedCCs, StgTopBinding)
coreTopBindToStg DynFlags
dflags Module
this_mod IdEnv HowBound
env CollectedCCs
ccs CoreBind
b
(IdEnv HowBound
env2, CollectedCCs
ccs2, [StgTopBinding]
bs') = DynFlags
-> Module
-> IdEnv HowBound
-> CollectedCCs
-> CoreProgram
-> (IdEnv HowBound, CollectedCCs, [StgTopBinding])
coreTopBindsToStg DynFlags
dflags Module
this_mod IdEnv HowBound
env1 CollectedCCs
ccs1 CoreProgram
bs
coreTopBindToStg
:: DynFlags
-> Module
-> IdEnv HowBound
-> CollectedCCs
-> CoreBind
-> (IdEnv HowBound, CollectedCCs, StgTopBinding)
coreTopBindToStg :: DynFlags
-> Module
-> IdEnv HowBound
-> CollectedCCs
-> CoreBind
-> (IdEnv HowBound, CollectedCCs, StgTopBinding)
coreTopBindToStg DynFlags
_ Module
_ IdEnv HowBound
env CollectedCCs
ccs (NonRec Var
id Expr Var
e)
| Just ByteString
str <- Expr Var -> Maybe ByteString
exprIsTickedString_maybe Expr Var
e
= let
env' :: IdEnv HowBound
env' = forall a. VarEnv a -> Var -> a -> VarEnv a
extendVarEnv IdEnv HowBound
env Var
id HowBound
how_bound
how_bound :: HowBound
how_bound = LetInfo -> JoinArity -> HowBound
LetBound LetInfo
TopLet JoinArity
0
in (IdEnv HowBound
env', CollectedCCs
ccs, forall (pass :: StgPass).
Var -> ByteString -> GenStgTopBinding pass
StgTopStringLit Var
id ByteString
str)
coreTopBindToStg DynFlags
dflags Module
this_mod IdEnv HowBound
env CollectedCCs
ccs (NonRec Var
id Expr Var
rhs)
= let
env' :: IdEnv HowBound
env' = forall a. VarEnv a -> Var -> a -> VarEnv a
extendVarEnv IdEnv HowBound
env Var
id HowBound
how_bound
how_bound :: HowBound
how_bound = LetInfo -> JoinArity -> HowBound
LetBound LetInfo
TopLet forall a b. (a -> b) -> a -> b
$! Expr Var -> JoinArity
manifestArity Expr Var
rhs
(StgRhs
stg_rhs, CollectedCCs
ccs') =
forall a. DynFlags -> IdEnv HowBound -> CtsM a -> a
initCts DynFlags
dflags IdEnv HowBound
env forall a b. (a -> b) -> a -> b
$
DynFlags
-> CollectedCCs
-> Module
-> (Var, Expr Var)
-> CtsM (StgRhs, CollectedCCs)
coreToTopStgRhs DynFlags
dflags CollectedCCs
ccs Module
this_mod (Var
id,Expr Var
rhs)
bind :: StgTopBinding
bind = forall (pass :: StgPass).
GenStgBinding pass -> GenStgTopBinding pass
StgTopLifted forall a b. (a -> b) -> a -> b
$ forall (pass :: StgPass).
BinderP pass -> GenStgRhs pass -> GenStgBinding pass
StgNonRec Var
id StgRhs
stg_rhs
in
(IdEnv HowBound
env', CollectedCCs
ccs', StgTopBinding
bind)
coreTopBindToStg DynFlags
dflags Module
this_mod IdEnv HowBound
env CollectedCCs
ccs (Rec [(Var, Expr Var)]
pairs)
= ASSERT( not (null pairs) )
let
binders :: [Var]
binders = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Var, Expr Var)]
pairs
extra_env' :: [(Var, HowBound)]
extra_env' = [ (Var
b, LetInfo -> JoinArity -> HowBound
LetBound LetInfo
TopLet forall a b. (a -> b) -> a -> b
$! Expr Var -> JoinArity
manifestArity Expr Var
rhs)
| (Var
b, Expr Var
rhs) <- [(Var, Expr Var)]
pairs ]
env' :: IdEnv HowBound
env' = forall a. VarEnv a -> [(Var, a)] -> VarEnv a
extendVarEnvList IdEnv HowBound
env [(Var, HowBound)]
extra_env'
(CollectedCCs
ccs', [StgRhs]
stg_rhss)
= forall a. DynFlags -> IdEnv HowBound -> CtsM a -> a
initCts DynFlags
dflags IdEnv HowBound
env' forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM (\CollectedCCs
ccs (Var, Expr Var)
rhs -> forall a b. (a, b) -> (b, a)
swap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DynFlags
-> CollectedCCs
-> Module
-> (Var, Expr Var)
-> CtsM (StgRhs, CollectedCCs)
coreToTopStgRhs DynFlags
dflags CollectedCCs
ccs Module
this_mod (Var, Expr Var)
rhs)
CollectedCCs
ccs
[(Var, Expr Var)]
pairs
bind :: StgTopBinding
bind = forall (pass :: StgPass).
GenStgBinding pass -> GenStgTopBinding pass
StgTopLifted forall a b. (a -> b) -> a -> b
$ forall (pass :: StgPass).
[(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass
StgRec (forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
binders [StgRhs]
stg_rhss)
in
(IdEnv HowBound
env', CollectedCCs
ccs', StgTopBinding
bind)
coreToTopStgRhs
:: DynFlags
-> CollectedCCs
-> Module
-> (Id,CoreExpr)
-> CtsM (StgRhs, CollectedCCs)
coreToTopStgRhs :: DynFlags
-> CollectedCCs
-> Module
-> (Var, Expr Var)
-> CtsM (StgRhs, CollectedCCs)
coreToTopStgRhs DynFlags
dflags CollectedCCs
ccs Module
this_mod (Var
bndr, Expr Var
rhs)
= do { PreStgRhs
new_rhs <- Expr Var -> CtsM PreStgRhs
coreToPreStgRhs Expr Var
rhs
; let (StgRhs
stg_rhs, CollectedCCs
ccs') =
DynFlags
-> Module
-> CollectedCCs
-> Var
-> PreStgRhs
-> (StgRhs, CollectedCCs)
mkTopStgRhs DynFlags
dflags Module
this_mod CollectedCCs
ccs Var
bndr PreStgRhs
new_rhs
stg_arity :: JoinArity
stg_arity =
StgRhs -> JoinArity
stgRhsArity StgRhs
stg_rhs
; forall (m :: * -> *) a. Monad m => a -> m a
return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs,
CollectedCCs
ccs') }
where
arity_ok :: JoinArity -> Bool
arity_ok JoinArity
stg_arity
| Name -> Bool
isExternalName (Var -> Name
idName Var
bndr) = JoinArity
id_arity forall a. Eq a => a -> a -> Bool
== JoinArity
stg_arity
| Bool
otherwise = Bool
True
id_arity :: JoinArity
id_arity = Var -> JoinArity
idArity Var
bndr
mk_arity_msg :: JoinArity -> SDoc
mk_arity_msg JoinArity
stg_arity
= [SDoc] -> SDoc
vcat [forall a. Outputable a => a -> SDoc
ppr Var
bndr,
String -> SDoc
text String
"Id arity:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr JoinArity
id_arity,
String -> SDoc
text String
"STG arity:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr JoinArity
stg_arity]
coreToStgExpr
:: CoreExpr
-> CtsM StgExpr
coreToStgExpr :: Expr Var -> CtsM StgExpr
coreToStgExpr (Lit (LitNumber LitNumType
LitNumInteger Integer
_)) = forall a. String -> a
panic String
"coreToStgExpr: LitInteger"
coreToStgExpr (Lit (LitNumber LitNumType
LitNumNatural Integer
_)) = forall a. String -> a
panic String
"coreToStgExpr: LitNatural"
coreToStgExpr (Lit Literal
l) = forall (m :: * -> *) a. Monad m => a -> m a
return (forall (pass :: StgPass). Literal -> GenStgExpr pass
StgLit Literal
l)
coreToStgExpr (App (Lit Literal
lit) Expr Var
_some_boxed_type)
| Literal -> Bool
isRubbishLit Literal
lit
= Expr Var -> CtsM StgExpr
coreToStgExpr (forall b. Var -> Expr b
Var Var
unitDataConId)
coreToStgExpr (Var Var
v) = Var -> [Expr Var] -> [CoreTickish] -> CtsM StgExpr
coreToStgApp Var
v [] []
coreToStgExpr (Coercion Coercion
_)
= Var -> [Expr Var] -> [CoreTickish] -> CtsM StgExpr
coreToStgApp Var
coercionTokenId [] []
coreToStgExpr expr :: Expr Var
expr@(App Expr Var
_ Expr Var
_)
= Var -> [Expr Var] -> [CoreTickish] -> CtsM StgExpr
coreToStgApp Var
f [Expr Var]
args [CoreTickish]
ticks
where
(Var
f, [Expr Var]
args, [CoreTickish]
ticks) = Expr Var -> (Var, [Expr Var], [CoreTickish])
myCollectArgs Expr Var
expr
coreToStgExpr expr :: Expr Var
expr@(Lam Var
_ Expr Var
_)
= let
([Var]
args, Expr Var
body) = Expr Var -> ([Var], Expr Var)
myCollectBinders Expr Var
expr
in
case [Var] -> [Var]
filterStgBinders [Var]
args of
[] -> Expr Var -> CtsM StgExpr
coreToStgExpr Expr Var
body
[Var]
_ -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"coretoStgExpr" forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Unexpected value lambda:" SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr Expr Var
expr
coreToStgExpr (Tick CoreTickish
tick Expr Var
expr)
= do
let !stg_tick :: StgTickish
stg_tick = Type -> CoreTickish -> StgTickish
coreToStgTick (Expr Var -> Type
exprType Expr Var
expr) CoreTickish
tick
!StgExpr
expr2 <- Expr Var -> CtsM StgExpr
coreToStgExpr Expr Var
expr
forall (m :: * -> *) a. Monad m => a -> m a
return (forall (pass :: StgPass).
StgTickish -> GenStgExpr pass -> GenStgExpr pass
StgTick StgTickish
stg_tick StgExpr
expr2)
coreToStgExpr (Cast Expr Var
expr Coercion
_)
= Expr Var -> CtsM StgExpr
coreToStgExpr Expr Var
expr
coreToStgExpr (Case Expr Var
scrut Var
bndr Type
_ [Alt Var]
alts)
= do { StgExpr
scrut2 <- Expr Var -> CtsM StgExpr
coreToStgExpr Expr Var
scrut
; [(AltCon, [Var], StgExpr)]
alts2 <- forall a. [(Var, HowBound)] -> CtsM a -> CtsM a
extendVarEnvCts [(Var
bndr, HowBound
LambdaBound)] (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Alt Var -> CtsM (AltCon, [Var], StgExpr)
vars_alt [Alt Var]
alts)
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall (pass :: StgPass).
GenStgExpr pass
-> BinderP pass -> AltType -> [GenStgAlt pass] -> GenStgExpr pass
StgCase StgExpr
scrut2 Var
bndr (Var -> [Alt Var] -> AltType
mkStgAltType Var
bndr [Alt Var]
alts) [(AltCon, [Var], StgExpr)]
alts2) }
where
vars_alt :: CoreAlt -> CtsM (AltCon, [Var], StgExpr)
vars_alt :: Alt Var -> CtsM (AltCon, [Var], StgExpr)
vars_alt (Alt AltCon
con [Var]
binders Expr Var
rhs)
| DataAlt DataCon
c <- AltCon
con, DataCon
c forall a. Eq a => a -> a -> Bool
== DataCon
unboxedUnitDataCon
=
ASSERT( null binders )
do { StgExpr
rhs2 <- Expr Var -> CtsM StgExpr
coreToStgExpr Expr Var
rhs
; forall (m :: * -> *) a. Monad m => a -> m a
return (AltCon
DEFAULT, [], StgExpr
rhs2) }
| Bool
otherwise
= let
binders' :: [Var]
binders' = [Var] -> [Var]
filterStgBinders [Var]
binders
in
forall a. [(Var, HowBound)] -> CtsM a -> CtsM a
extendVarEnvCts [(Var
b, HowBound
LambdaBound) | Var
b <- [Var]
binders'] forall a b. (a -> b) -> a -> b
$ do
StgExpr
rhs2 <- Expr Var -> CtsM StgExpr
coreToStgExpr Expr Var
rhs
forall (m :: * -> *) a. Monad m => a -> m a
return (AltCon
con, [Var]
binders', StgExpr
rhs2)
coreToStgExpr (Let CoreBind
bind Expr Var
body) = CoreBind -> Expr Var -> CtsM StgExpr
coreToStgLet CoreBind
bind Expr Var
body
coreToStgExpr Expr Var
e = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"coreToStgExpr" (forall a. Outputable a => a -> SDoc
ppr Expr Var
e)
mkStgAltType :: Id -> [CoreAlt] -> AltType
mkStgAltType :: Var -> [Alt Var] -> AltType
mkStgAltType Var
bndr [Alt Var]
alts
| Type -> Bool
isUnboxedTupleType Type
bndr_ty Bool -> Bool -> Bool
|| Type -> Bool
isUnboxedSumType Type
bndr_ty
= JoinArity -> AltType
MultiValAlt (forall (t :: * -> *) a. Foldable t => t a -> JoinArity
length [PrimRep]
prim_reps)
| Bool
otherwise
= case [PrimRep]
prim_reps of
[PrimRep
rep] | PrimRep -> Bool
isGcPtrRep PrimRep
rep ->
case Type -> Maybe TyCon
tyConAppTyCon_maybe (Type -> Type
unwrapType Type
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 -> ASSERT2( _is_poly_alt_tycon tc, ppr tc )
AltType
PolyAlt
Maybe TyCon
Nothing -> AltType
PolyAlt
[PrimRep
non_gcd] -> PrimRep -> AltType
PrimAlt PrimRep
non_gcd
[PrimRep]
not_unary -> JoinArity -> AltType
MultiValAlt (forall (t :: * -> *) a. Foldable t => t a -> JoinArity
length [PrimRep]
not_unary)
where
bndr_ty :: Type
bndr_ty = Var -> Type
idType Var
bndr
prim_reps :: [PrimRep]
prim_reps = HasDebugCallStack => Type -> [PrimRep]
typePrimRep Type
bndr_ty
_is_poly_alt_tycon :: TyCon -> Bool
_is_poly_alt_tycon TyCon
tc
= TyCon -> Bool
isFunTyCon TyCon
tc
Bool -> Bool -> Bool
|| 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) [Var]
_ Expr Var
_) : [Alt Var]
_) <- [Alt Var]
data_alts =
TyCon -> AltType
AlgAlt (DataCon -> TyCon
dataConTyCon DataCon
con)
| Bool
otherwise =
ASSERT(null data_alts)
AltType
PolyAlt
where
([Alt Var]
data_alts, Maybe (Expr Var)
_deflt) = forall b. [Alt b] -> ([Alt b], Maybe (Expr b))
findDefault [Alt Var]
alts
coreToStgApp :: Id
-> [CoreArg]
-> [CoreTickish]
-> CtsM StgExpr
coreToStgApp :: Var -> [Expr Var] -> [CoreTickish] -> CtsM StgExpr
coreToStgApp Var
f [Expr Var]
args [CoreTickish]
ticks = do
([StgArg]
args', [StgTickish]
ticks') <- [Expr Var] -> CtsM ([StgArg], [StgTickish])
coreToStgArgs [Expr Var]
args
HowBound
how_bound <- Var -> CtsM HowBound
lookupVarCts Var
f
let
n_val_args :: JoinArity
n_val_args = forall b. [Arg b] -> JoinArity
valArgCount [Expr Var]
args
f_arity :: JoinArity
f_arity = Var -> HowBound -> JoinArity
stgArity Var
f HowBound
how_bound
saturated :: Bool
saturated = JoinArity
f_arity forall a. Ord a => a -> a -> Bool
<= JoinArity
n_val_args
res_ty :: Type
res_ty = Expr Var -> Type
exprType (forall b. Expr b -> [Expr b] -> Expr b
mkApps (forall b. Var -> Expr b
Var Var
f) [Expr Var]
args)
app :: StgExpr
app = case Var -> IdDetails
idDetails Var
f of
DataConWorkId DataCon
dc
| Bool
saturated -> forall (pass :: StgPass).
DataCon -> XConApp pass -> [StgArg] -> [Type] -> GenStgExpr pass
StgConApp DataCon
dc ConstructorNumber
NoNumber [StgArg]
args'
([Type] -> [Type]
dropRuntimeRepArgs (forall a. a -> Maybe a -> a
fromMaybe [] (Type -> Maybe [Type]
tyConAppArgs_maybe Type
res_ty)))
PrimOpId PrimOp
op -> ASSERT( saturated )
forall (pass :: StgPass).
StgOp -> [StgArg] -> Type -> GenStgExpr pass
StgOpApp (PrimOp -> StgOp
StgPrimOp PrimOp
op) [StgArg]
args' Type
res_ty
FCallId (CCall (CCallSpec (StaticTarget SourceText
_ CLabelString
lbl (Just Unit
pkgId) Bool
True)
CCallConv
PrimCallConv Safety
_))
-> ASSERT( saturated )
forall (pass :: StgPass).
StgOp -> [StgArg] -> Type -> GenStgExpr pass
StgOpApp (PrimCall -> StgOp
StgPrimCallOp (CLabelString -> Unit -> PrimCall
PrimCall CLabelString
lbl Unit
pkgId)) [StgArg]
args' Type
res_ty
FCallId ForeignCall
call -> ASSERT( saturated )
forall (pass :: StgPass).
StgOp -> [StgArg] -> Type -> GenStgExpr pass
StgOpApp (ForeignCall -> Type -> StgOp
StgFCallOp ForeignCall
call (Var -> Type
idType Var
f)) [StgArg]
args' Type
res_ty
TickBoxOpId {} -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"coreToStg TickBox" forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> SDoc
ppr (Var
f,[StgArg]
args')
IdDetails
_other -> forall (pass :: StgPass). Var -> [StgArg] -> GenStgExpr pass
StgApp Var
f [StgArg]
args'
add_tick :: StgTickish -> GenStgExpr pass -> GenStgExpr pass
add_tick !StgTickish
t !GenStgExpr pass
e = forall (pass :: StgPass).
StgTickish -> GenStgExpr pass -> GenStgExpr pass
StgTick StgTickish
t GenStgExpr pass
e
tapp :: StgExpr
tapp = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall (pass :: StgPass).
StgTickish -> GenStgExpr pass -> GenStgExpr pass
add_tick StgExpr
app (forall a b. (a -> b) -> [a] -> [b]
map (Type -> CoreTickish -> StgTickish
coreToStgTick Type
res_ty) [CoreTickish]
ticks forall a. [a] -> [a] -> [a]
++ [StgTickish]
ticks')
StgExpr
app seq :: forall a b. a -> b -> b
`seq` forall (m :: * -> *) a. Monad m => a -> m a
return StgExpr
tapp
coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [StgTickish])
coreToStgArgs :: [Expr Var] -> CtsM ([StgArg], [StgTickish])
coreToStgArgs []
= forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
coreToStgArgs (Type Type
_ : [Expr Var]
args) = do
([StgArg]
args', [StgTickish]
ts) <- [Expr Var] -> CtsM ([StgArg], [StgTickish])
coreToStgArgs [Expr Var]
args
forall (m :: * -> *) a. Monad m => a -> m a
return ([StgArg]
args', [StgTickish]
ts)
coreToStgArgs (Coercion Coercion
_ : [Expr Var]
args)
= do { ([StgArg]
args', [StgTickish]
ts) <- [Expr Var] -> CtsM ([StgArg], [StgTickish])
coreToStgArgs [Expr Var]
args
; forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> StgArg
StgVarArg Var
coercionTokenId forall a. a -> [a] -> [a]
: [StgArg]
args', [StgTickish]
ts) }
coreToStgArgs (Tick CoreTickish
t Expr Var
e : [Expr Var]
args)
= ASSERT( not (tickishIsCode t) )
do { ([StgArg]
args', [StgTickish]
ts) <- [Expr Var] -> CtsM ([StgArg], [StgTickish])
coreToStgArgs (Expr Var
e forall a. a -> [a] -> [a]
: [Expr Var]
args)
; let !t' :: StgTickish
t' = Type -> CoreTickish -> StgTickish
coreToStgTick (Expr Var -> Type
exprType Expr Var
e) CoreTickish
t
; forall (m :: * -> *) a. Monad m => a -> m a
return ([StgArg]
args', StgTickish
t'forall a. a -> [a] -> [a]
:[StgTickish]
ts) }
coreToStgArgs (Expr Var
arg : [Expr Var]
args) = do
([StgArg]
stg_args, [StgTickish]
ticks) <- [Expr Var] -> CtsM ([StgArg], [StgTickish])
coreToStgArgs [Expr Var]
args
StgExpr
arg' <- Expr Var -> CtsM StgExpr
coreToStgExpr Expr Var
arg
let
([StgTickish]
aticks, StgExpr
arg'') = forall (p :: StgPass).
(StgTickish -> Bool)
-> GenStgExpr p -> ([StgTickish], GenStgExpr p)
stripStgTicksTop forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable StgExpr
arg'
stg_arg :: StgArg
stg_arg = case StgExpr
arg'' of
StgApp Var
v [] -> Var -> StgArg
StgVarArg Var
v
StgConApp DataCon
con XConApp 'Vanilla
_ [] [Type]
_ -> Var -> StgArg
StgVarArg (DataCon -> Var
dataConWorkId DataCon
con)
StgLit Literal
lit -> Literal -> StgArg
StgLitArg Literal
lit
StgExpr
_ -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"coreToStgArgs" (forall a. Outputable a => a -> SDoc
ppr Expr Var
arg)
Platform
platform <- DynFlags -> Platform
targetPlatform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let
arg_rep :: [PrimRep]
arg_rep = HasDebugCallStack => Type -> [PrimRep]
typePrimRep (Expr Var -> Type
exprType Expr Var
arg)
stg_arg_rep :: [PrimRep]
stg_arg_rep = HasDebugCallStack => Type -> [PrimRep]
typePrimRep (StgArg -> Type
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)
WARN( bad_args, text "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" $$ ppr arg )
forall (m :: * -> *) a. Monad m => a -> m a
return (StgArg
stg_arg forall a. a -> [a] -> [a]
: [StgArg]
stg_args, [StgTickish]
ticks forall a. [a] -> [a] -> [a]
++ [StgTickish]
aticks)
coreToStgTick :: Type
-> CoreTickish
-> StgTickish
coreToStgTick :: Type -> CoreTickish -> StgTickish
coreToStgTick Type
_ty (HpcTick Module
m JoinArity
i) = forall (pass :: TickishPass).
Module -> JoinArity -> GenTickish pass
HpcTick Module
m JoinArity
i
coreToStgTick Type
_ty (SourceNote RealSrcSpan
span String
nm) = forall (pass :: TickishPass).
RealSrcSpan -> String -> GenTickish pass
SourceNote RealSrcSpan
span String
nm
coreToStgTick Type
_ty (ProfNote CostCentre
cc Bool
cnt Bool
scope) = forall (pass :: TickishPass).
CostCentre -> Bool -> Bool -> GenTickish pass
ProfNote CostCentre
cc Bool
cnt Bool
scope
coreToStgTick !Type
ty (Breakpoint XBreakpoint 'TickishPassCore
_ JoinArity
bid [XTickishId 'TickishPassCore]
fvs) = forall (pass :: TickishPass).
XBreakpoint pass
-> JoinArity -> [XTickishId pass] -> GenTickish pass
Breakpoint Type
ty JoinArity
bid [XTickishId 'TickishPassCore]
fvs
coreToStgLet
:: CoreBind
-> CoreExpr
-> CtsM StgExpr
coreToStgLet :: CoreBind -> Expr Var -> CtsM StgExpr
coreToStgLet CoreBind
bind Expr Var
body
| NonRec Var
_ Expr Var
rhs <- CoreBind
bind, forall b. Expr b -> Bool
isTyCoArg Expr Var
rhs
= Expr Var -> CtsM StgExpr
coreToStgExpr Expr Var
body
| Bool
otherwise
= do { (StgBinding
bind2, [(Var, HowBound)]
env_ext) <- CoreBind -> CtsM (StgBinding, [(Var, HowBound)])
vars_bind CoreBind
bind
; StgExpr
body2 <- forall a. [(Var, HowBound)] -> CtsM a -> CtsM a
extendVarEnvCts [(Var, HowBound)]
env_ext forall a b. (a -> b) -> a -> b
$
Expr Var -> CtsM StgExpr
coreToStgExpr Expr Var
body
; let new_let :: StgExpr
new_let | CoreBind -> Bool
isJoinBind CoreBind
bind
= forall (pass :: StgPass).
XLetNoEscape pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLetNoEscape NoExtFieldSilent
noExtFieldSilent StgBinding
bind2 StgExpr
body2
| Bool
otherwise
= forall (pass :: StgPass).
XLet pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLet NoExtFieldSilent
noExtFieldSilent StgBinding
bind2 StgExpr
body2
; forall (m :: * -> *) a. Monad m => a -> m a
return StgExpr
new_let }
where
mk_binding :: a -> Expr Var -> (a, HowBound)
mk_binding a
binder Expr Var
rhs
= (a
binder, LetInfo -> JoinArity -> HowBound
LetBound LetInfo
NestedLet (Expr Var -> JoinArity
manifestArity Expr Var
rhs))
vars_bind :: CoreBind
-> CtsM (StgBinding,
[(Id, HowBound)])
vars_bind :: CoreBind -> CtsM (StgBinding, [(Var, HowBound)])
vars_bind (NonRec Var
binder Expr Var
rhs) = do
StgRhs
rhs2 <- (Var, Expr Var) -> CtsM StgRhs
coreToStgRhs (Var
binder,Expr Var
rhs)
let
env_ext_item :: (Var, HowBound)
env_ext_item = forall {a}. a -> Expr Var -> (a, HowBound)
mk_binding Var
binder Expr Var
rhs
forall (m :: * -> *) a. Monad m => a -> m a
return (forall (pass :: StgPass).
BinderP pass -> GenStgRhs pass -> GenStgBinding pass
StgNonRec Var
binder StgRhs
rhs2, [(Var, HowBound)
env_ext_item])
vars_bind (Rec [(Var, Expr Var)]
pairs)
= let
binders :: [Var]
binders = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Var, Expr Var)]
pairs
env_ext :: [(Var, HowBound)]
env_ext = [ forall {a}. a -> Expr Var -> (a, HowBound)
mk_binding Var
b Expr Var
rhs
| (Var
b,Expr Var
rhs) <- [(Var, Expr Var)]
pairs ]
in
forall a. [(Var, HowBound)] -> CtsM a -> CtsM a
extendVarEnvCts [(Var, HowBound)]
env_ext forall a b. (a -> b) -> a -> b
$ do
[StgRhs]
rhss2 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Var, Expr Var) -> CtsM StgRhs
coreToStgRhs [(Var, Expr Var)]
pairs
forall (m :: * -> *) a. Monad m => a -> m a
return (forall (pass :: StgPass).
[(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass
StgRec ([Var]
binders forall a b. [a] -> [b] -> [(a, b)]
`zip` [StgRhs]
rhss2), [(Var, HowBound)]
env_ext)
coreToStgRhs :: (Id,CoreExpr)
-> CtsM StgRhs
coreToStgRhs :: (Var, Expr Var) -> CtsM StgRhs
coreToStgRhs (Var
bndr, Expr Var
rhs) = do
PreStgRhs
new_rhs <- Expr Var -> CtsM PreStgRhs
coreToPreStgRhs Expr Var
rhs
forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> PreStgRhs -> StgRhs
mkStgRhs Var
bndr PreStgRhs
new_rhs)
data PreStgRhs = PreStgRhs [Id] StgExpr
coreToPreStgRhs :: CoreExpr -> CtsM PreStgRhs
coreToPreStgRhs :: Expr Var -> CtsM PreStgRhs
coreToPreStgRhs (Cast Expr Var
expr Coercion
_) = Expr Var -> CtsM PreStgRhs
coreToPreStgRhs Expr Var
expr
coreToPreStgRhs expr :: Expr Var
expr@(Lam Var
_ Expr Var
_) =
let
([Var]
args, Expr Var
body) = Expr Var -> ([Var], Expr Var)
myCollectBinders Expr Var
expr
args' :: [Var]
args' = [Var] -> [Var]
filterStgBinders [Var]
args
in
forall a. [(Var, HowBound)] -> CtsM a -> CtsM a
extendVarEnvCts [ (Var
a, HowBound
LambdaBound) | Var
a <- [Var]
args' ] forall a b. (a -> b) -> a -> b
$ do
StgExpr
body' <- Expr Var -> CtsM StgExpr
coreToStgExpr Expr Var
body
forall (m :: * -> *) a. Monad m => a -> m a
return ([Var] -> StgExpr -> PreStgRhs
PreStgRhs [Var]
args' StgExpr
body')
coreToPreStgRhs Expr Var
expr = [Var] -> StgExpr -> PreStgRhs
PreStgRhs [] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr Var -> CtsM StgExpr
coreToStgExpr Expr Var
expr
mkTopStgRhs :: DynFlags -> Module -> CollectedCCs
-> Id -> PreStgRhs -> (StgRhs, CollectedCCs)
mkTopStgRhs :: DynFlags
-> Module
-> CollectedCCs
-> Var
-> PreStgRhs
-> (StgRhs, CollectedCCs)
mkTopStgRhs DynFlags
dflags Module
this_mod CollectedCCs
ccs Var
bndr (PreStgRhs [Var]
bndrs StgExpr
rhs)
| Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Var]
bndrs)
=
( forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure NoExtFieldSilent
noExtFieldSilent
CostCentreStack
dontCareCCS
UpdateFlag
ReEntrant
[Var]
bndrs StgExpr
rhs
, CollectedCCs
ccs )
| StgConApp DataCon
con XConApp 'Vanilla
mn [StgArg]
args [Type]
_ <- StgExpr
unticked_rhs
,
Bool -> Bool
not (DynFlags -> Module -> DataCon -> [StgArg] -> Bool
isDllConApp DynFlags
dflags Module
this_mod DataCon
con [StgArg]
args)
=
ASSERT2( not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con)
, ppr bndr $$ ppr con $$ ppr args)
( forall (pass :: StgPass).
CostCentreStack
-> DataCon
-> ConstructorNumber
-> [StgTickish]
-> [StgArg]
-> GenStgRhs pass
StgRhsCon CostCentreStack
dontCareCCS DataCon
con XConApp 'Vanilla
mn [StgTickish]
ticks [StgArg]
args, CollectedCCs
ccs )
| GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_AutoSccsOnIndividualCafs DynFlags
dflags
= ( forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure 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
= ( forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure NoExtFieldSilent
noExtFieldSilent
CostCentreStack
all_cafs_ccs
UpdateFlag
upd_flag [] StgExpr
rhs
, CollectedCCs
ccs )
where
([StgTickish]
ticks, StgExpr
unticked_rhs) = forall (p :: StgPass).
(StgTickish -> Bool)
-> GenStgExpr p -> ([StgTickish], GenStgExpr p)
stripStgTicksTop (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode) StgExpr
rhs
upd_flag :: UpdateFlag
upd_flag | Demand -> Bool
isUsedOnceDmd (Var -> Demand
idDemandInfo Var
bndr) = UpdateFlag
SingleEntry
| Bool
otherwise = UpdateFlag
Updatable
caf_cc :: CostCentre
caf_cc = Var -> Module -> CostCentre
mkAutoCC Var
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 (Var -> Name
idName Var
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 :: Var -> PreStgRhs -> StgRhs
mkStgRhs Var
bndr (PreStgRhs [Var]
bndrs StgExpr
rhs)
| Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Var]
bndrs)
= forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure NoExtFieldSilent
noExtFieldSilent
CostCentreStack
currentCCS
UpdateFlag
ReEntrant
[Var]
bndrs StgExpr
rhs
| Var -> Bool
isJoinId Var
bndr
= ASSERT(idJoinArity bndr == 0)
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure NoExtFieldSilent
noExtFieldSilent
CostCentreStack
currentCCS
UpdateFlag
ReEntrant
[] StgExpr
rhs
| StgConApp DataCon
con XConApp 'Vanilla
mn [StgArg]
args [Type]
_ <- StgExpr
unticked_rhs
= forall (pass :: StgPass).
CostCentreStack
-> DataCon
-> ConstructorNumber
-> [StgTickish]
-> [StgArg]
-> GenStgRhs pass
StgRhsCon CostCentreStack
currentCCS DataCon
con XConApp 'Vanilla
mn [StgTickish]
ticks [StgArg]
args
| Bool
otherwise
= forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure NoExtFieldSilent
noExtFieldSilent
CostCentreStack
currentCCS
UpdateFlag
upd_flag [] StgExpr
rhs
where
([StgTickish]
ticks, StgExpr
unticked_rhs) = forall (p :: StgPass).
(StgTickish -> Bool)
-> GenStgExpr p -> ([StgTickish], GenStgExpr p)
stripStgTicksTop (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode) StgExpr
rhs
upd_flag :: UpdateFlag
upd_flag | Demand -> Bool
isUsedOnceDmd (Var -> Demand
idDemandInfo Var
bndr) = UpdateFlag
SingleEntry
| Bool
otherwise = UpdateFlag
Updatable
newtype CtsM a = CtsM
{ forall a. CtsM a -> DynFlags -> IdEnv HowBound -> a
unCtsM :: DynFlags
-> IdEnv HowBound
-> a
}
deriving (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
<$ :: forall a b. a -> CtsM b -> CtsM a
$c<$ :: forall a b. a -> CtsM b -> CtsM a
fmap :: forall a b. (a -> b) -> CtsM a -> CtsM b
$cfmap :: forall a b. (a -> b) -> CtsM a -> CtsM b
Functor)
data HowBound
= ImportBound
| LetBound
LetInfo
Arity
| LambdaBound
deriving (HowBound -> HowBound -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HowBound -> HowBound -> Bool
$c/= :: HowBound -> HowBound -> Bool
== :: HowBound -> HowBound -> Bool
$c== :: HowBound -> HowBound -> Bool
Eq)
data LetInfo
= TopLet
| NestedLet
deriving (LetInfo -> LetInfo -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LetInfo -> LetInfo -> Bool
$c/= :: LetInfo -> LetInfo -> Bool
== :: LetInfo -> LetInfo -> Bool
$c== :: LetInfo -> LetInfo -> Bool
Eq)
initCts :: DynFlags -> IdEnv HowBound -> CtsM a -> a
initCts :: forall a. DynFlags -> IdEnv HowBound -> CtsM a -> a
initCts DynFlags
dflags IdEnv HowBound
env CtsM a
m = forall a. CtsM a -> DynFlags -> IdEnv HowBound -> a
unCtsM CtsM a
m DynFlags
dflags IdEnv HowBound
env
{-# INLINE thenCts #-}
{-# INLINE returnCts #-}
returnCts :: a -> CtsM a
returnCts :: forall a. a -> CtsM a
returnCts a
e = forall a. (DynFlags -> IdEnv HowBound -> a) -> CtsM a
CtsM forall a b. (a -> b) -> a -> b
$ \DynFlags
_ 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 = forall a. (DynFlags -> IdEnv HowBound -> a) -> CtsM a
CtsM forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags IdEnv HowBound
env
-> forall a. CtsM a -> DynFlags -> IdEnv HowBound -> a
unCtsM (a -> CtsM b
k (forall a. CtsM a -> DynFlags -> IdEnv HowBound -> a
unCtsM CtsM a
m DynFlags
dflags IdEnv HowBound
env)) DynFlags
dflags IdEnv HowBound
env
instance Applicative CtsM where
pure :: forall a. a -> CtsM a
pure = forall a. a -> CtsM a
returnCts
<*> :: forall a 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
(>>=) = forall a b. CtsM a -> (a -> CtsM b) -> CtsM b
thenCts
instance HasDynFlags CtsM where
getDynFlags :: CtsM DynFlags
getDynFlags = forall a. (DynFlags -> IdEnv HowBound -> a) -> CtsM a
CtsM forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags IdEnv HowBound
_ -> DynFlags
dflags
extendVarEnvCts :: [(Id, HowBound)] -> CtsM a -> CtsM a
extendVarEnvCts :: forall a. [(Var, HowBound)] -> CtsM a -> CtsM a
extendVarEnvCts [(Var, HowBound)]
ids_w_howbound CtsM a
expr
= forall a. (DynFlags -> IdEnv HowBound -> a) -> CtsM a
CtsM forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags IdEnv HowBound
env
-> forall a. CtsM a -> DynFlags -> IdEnv HowBound -> a
unCtsM CtsM a
expr DynFlags
dflags (forall a. VarEnv a -> [(Var, a)] -> VarEnv a
extendVarEnvList IdEnv HowBound
env [(Var, HowBound)]
ids_w_howbound)
lookupVarCts :: Id -> CtsM HowBound
lookupVarCts :: Var -> CtsM HowBound
lookupVarCts Var
v = forall a. (DynFlags -> IdEnv HowBound -> a) -> CtsM a
CtsM forall a b. (a -> b) -> a -> b
$ \DynFlags
_ IdEnv HowBound
env -> IdEnv HowBound -> Var -> HowBound
lookupBinding IdEnv HowBound
env Var
v
lookupBinding :: IdEnv HowBound -> Id -> HowBound
lookupBinding :: IdEnv HowBound -> Var -> HowBound
lookupBinding IdEnv HowBound
env Var
v = case forall a. VarEnv a -> Var -> Maybe a
lookupVarEnv IdEnv HowBound
env Var
v of
Just HowBound
xx -> HowBound
xx
Maybe HowBound
Nothing -> ASSERT2( isGlobalId v, ppr v ) 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 :: [Var] -> [Var]
filterStgBinders [Var]
bndrs = forall a. (a -> Bool) -> [a] -> [a]
filter Var -> Bool
isId [Var]
bndrs
myCollectBinders :: Expr Var -> ([Var], Expr Var)
myCollectBinders :: Expr Var -> ([Var], Expr Var)
myCollectBinders Expr Var
expr
= forall {a}. [a] -> Expr a -> ([a], Expr a)
go [] Expr Var
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
bforall 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 = (forall a. [a] -> [a]
reverse [a]
bs, Expr a
e)
myCollectArgs :: CoreExpr -> (Id, [CoreArg], [CoreTickish])
myCollectArgs :: Expr Var -> (Var, [Expr Var], [CoreTickish])
myCollectArgs Expr Var
expr
= Expr Var
-> [Expr Var] -> [CoreTickish] -> (Var, [Expr Var], [CoreTickish])
go Expr Var
expr [] []
where
go :: Expr Var
-> [Expr Var] -> [CoreTickish] -> (Var, [Expr Var], [CoreTickish])
go (Var Var
v) [Expr Var]
as [CoreTickish]
ts = (Var
v, [Expr Var]
as, [CoreTickish]
ts)
go (App Expr Var
f Expr Var
a) [Expr Var]
as [CoreTickish]
ts = Expr Var
-> [Expr Var] -> [CoreTickish] -> (Var, [Expr Var], [CoreTickish])
go Expr Var
f (Expr Var
aforall a. a -> [a] -> [a]
:[Expr Var]
as) [CoreTickish]
ts
go (Tick CoreTickish
t Expr Var
e) [Expr Var]
as [CoreTickish]
ts = ASSERT2( not (tickishIsCode t) || all isTypeArg as
, ppr e $$ ppr as $$ ppr ts )
Expr Var
-> [Expr Var] -> [CoreTickish] -> (Var, [Expr Var], [CoreTickish])
go Expr Var
e [Expr Var]
as (CoreTickish
tforall a. a -> [a] -> [a]
:[CoreTickish]
ts)
go (Cast Expr Var
e Coercion
_) [Expr Var]
as [CoreTickish]
ts = Expr Var
-> [Expr Var] -> [CoreTickish] -> (Var, [Expr Var], [CoreTickish])
go Expr Var
e [Expr Var]
as [CoreTickish]
ts
go (Lam Var
b Expr Var
e) [Expr Var]
as [CoreTickish]
ts
| Var -> Bool
isTyVar Var
b = Expr Var
-> [Expr Var] -> [CoreTickish] -> (Var, [Expr Var], [CoreTickish])
go Expr Var
e [Expr Var]
as [CoreTickish]
ts
go Expr Var
_ [Expr Var]
_ [CoreTickish]
_ = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"CoreToStg.myCollectArgs" (forall a. Outputable a => a -> SDoc
ppr Expr Var
expr)
stgArity :: Id -> HowBound -> Arity
stgArity :: Var -> HowBound -> JoinArity
stgArity Var
_ (LetBound LetInfo
_ JoinArity
arity) = JoinArity
arity
stgArity Var
f HowBound
ImportBound = Var -> JoinArity
idArity Var
f
stgArity Var
_ HowBound
LambdaBound = JoinArity
0