{-# LANGUAGE CPP, RecordWildCards #-}
module GHC.StgToCmm.Closure (
DynTag, tagForCon, isSmallFamily,
idPrimRep, isVoidRep, isGcPtrRep, addIdReps, addArgReps,
argPrimRep,
NonVoid(..), fromNonVoid, nonVoidIds, nonVoidStgArgs,
assertNonVoidIds, assertNonVoidStgArgs,
LambdaFormInfo,
StandardFormInfo,
mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo,
mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,
mkLFStringLit,
lfDynTag,
isLFThunk, isLFReEntrant, lfUpdatable,
CgLoc(..), SelfLoopInfo, CallMethod(..),
nodeMustPointToIt, isKnownFun, funTag, tagForArity, getCallMethod,
ClosureInfo,
mkClosureInfo,
mkCmmInfo,
closureLFInfo, closureName,
closureInfoLabel, staticClosureLabel,
closureSlowEntryLabel, closureLocalEntryLabel,
closureUpdReqd, closureSingleEntry,
closureReEntrant, closureFunInfo,
isToplevClosure,
blackHoleOnEntry,
isStaticClosure,
mkDataConInfoTable,
cafBlackHoleInfoTable,
indStaticInfoTable,
staticClosureNeedsLink,
) where
#include "HsVersions.h"
import GhcPrelude
import StgSyn
import SMRep
import Cmm
import PprCmmExpr()
import CostCentre
import BlockId
import CLabel
import Id
import IdInfo
import DataCon
import Name
import Type
import TyCoRep
import TcType
import TyCon
import RepType
import BasicTypes
import Outputable
import DynFlags
import Util
import Data.Coerce (coerce)
import qualified Data.ByteString.Char8 as BS8
data CgLoc
= CmmLoc CmmExpr
| LneLoc BlockId [LocalReg]
instance Outputable CgLoc where
ppr :: CgLoc -> SDoc
ppr (CmmLoc CmmExpr
e) = String -> SDoc
text String
"cmm" SDoc -> SDoc -> SDoc
<+> CmmExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmExpr
e
ppr (LneLoc BlockId
b [LocalReg]
rs) = String -> SDoc
text String
"lne" SDoc -> SDoc -> SDoc
<+> BlockId -> SDoc
forall a. Outputable a => a -> SDoc
ppr BlockId
b SDoc -> SDoc -> SDoc
<+> [LocalReg] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LocalReg]
rs
type SelfLoopInfo = (Id, BlockId, [LocalReg])
isKnownFun :: LambdaFormInfo -> Bool
isKnownFun :: LambdaFormInfo -> Bool
isKnownFun LFReEntrant{} = Bool
True
isKnownFun LambdaFormInfo
LFLetNoEscape = Bool
True
isKnownFun LambdaFormInfo
_ = Bool
False
newtype NonVoid a = NonVoid a
deriving (NonVoid a -> NonVoid a -> Bool
(NonVoid a -> NonVoid a -> Bool)
-> (NonVoid a -> NonVoid a -> Bool) -> Eq (NonVoid a)
forall a. Eq a => NonVoid a -> NonVoid a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NonVoid a -> NonVoid a -> Bool
$c/= :: forall a. Eq a => NonVoid a -> NonVoid a -> Bool
== :: NonVoid a -> NonVoid a -> Bool
$c== :: forall a. Eq a => NonVoid a -> NonVoid a -> Bool
Eq, Int -> NonVoid a -> ShowS
[NonVoid a] -> ShowS
NonVoid a -> String
(Int -> NonVoid a -> ShowS)
-> (NonVoid a -> String)
-> ([NonVoid a] -> ShowS)
-> Show (NonVoid a)
forall a. Show a => Int -> NonVoid a -> ShowS
forall a. Show a => [NonVoid a] -> ShowS
forall a. Show a => NonVoid a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NonVoid a] -> ShowS
$cshowList :: forall a. Show a => [NonVoid a] -> ShowS
show :: NonVoid a -> String
$cshow :: forall a. Show a => NonVoid a -> String
showsPrec :: Int -> NonVoid a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> NonVoid a -> ShowS
Show)
fromNonVoid :: NonVoid a -> a
fromNonVoid :: NonVoid a -> a
fromNonVoid (NonVoid a
a) = a
a
instance (Outputable a) => Outputable (NonVoid a) where
ppr :: NonVoid a -> SDoc
ppr (NonVoid a
a) = a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
a
nonVoidIds :: [Id] -> [NonVoid Id]
nonVoidIds :: [Id] -> [NonVoid Id]
nonVoidIds [Id]
ids = [Id -> NonVoid Id
forall a. a -> NonVoid a
NonVoid Id
id | Id
id <- [Id]
ids, Bool -> Bool
not (Type -> Bool
isVoidTy (Id -> Type
idType Id
id))]
assertNonVoidIds :: [Id] -> [NonVoid Id]
assertNonVoidIds :: [Id] -> [NonVoid Id]
assertNonVoidIds [Id]
ids = ASSERT(not (any (isVoidTy . idType) ids))
[Id] -> [NonVoid Id]
coerce [Id]
ids
nonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]
nonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]
nonVoidStgArgs [StgArg]
args = [StgArg -> NonVoid StgArg
forall a. a -> NonVoid a
NonVoid StgArg
arg | StgArg
arg <- [StgArg]
args, Bool -> Bool
not (Type -> Bool
isVoidTy (StgArg -> Type
stgArgType StgArg
arg))]
assertNonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]
assertNonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]
assertNonVoidStgArgs [StgArg]
args = ASSERT(not (any (isVoidTy . stgArgType) args))
[StgArg] -> [NonVoid StgArg]
coerce [StgArg]
args
idPrimRep :: Id -> PrimRep
idPrimRep :: Id -> PrimRep
idPrimRep Id
id = HasDebugCallStack => Type -> PrimRep
Type -> PrimRep
typePrimRep1 (Id -> Type
idType Id
id)
addIdReps :: [NonVoid Id] -> [NonVoid (PrimRep, Id)]
addIdReps :: [NonVoid Id] -> [NonVoid (PrimRep, Id)]
addIdReps = (NonVoid Id -> NonVoid (PrimRep, Id))
-> [NonVoid Id] -> [NonVoid (PrimRep, Id)]
forall a b. (a -> b) -> [a] -> [b]
map (\NonVoid Id
id -> let id' :: Id
id' = NonVoid Id -> Id
forall a. NonVoid a -> a
fromNonVoid NonVoid Id
id
in (PrimRep, Id) -> NonVoid (PrimRep, Id)
forall a. a -> NonVoid a
NonVoid (Id -> PrimRep
idPrimRep Id
id', Id
id'))
addArgReps :: [NonVoid StgArg] -> [NonVoid (PrimRep, StgArg)]
addArgReps :: [NonVoid StgArg] -> [NonVoid (PrimRep, StgArg)]
addArgReps = (NonVoid StgArg -> NonVoid (PrimRep, StgArg))
-> [NonVoid StgArg] -> [NonVoid (PrimRep, StgArg)]
forall a b. (a -> b) -> [a] -> [b]
map (\NonVoid StgArg
arg -> let arg' :: StgArg
arg' = NonVoid StgArg -> StgArg
forall a. NonVoid a -> a
fromNonVoid NonVoid StgArg
arg
in (PrimRep, StgArg) -> NonVoid (PrimRep, StgArg)
forall a. a -> NonVoid a
NonVoid (StgArg -> PrimRep
argPrimRep StgArg
arg', StgArg
arg'))
argPrimRep :: StgArg -> PrimRep
argPrimRep :: StgArg -> PrimRep
argPrimRep StgArg
arg = HasDebugCallStack => Type -> PrimRep
Type -> PrimRep
typePrimRep1 (StgArg -> Type
stgArgType StgArg
arg)
data LambdaFormInfo
= LFReEntrant
TopLevelFlag
OneShotInfo
!RepArity
!Bool
ArgDescr
| LFThunk
TopLevelFlag
!Bool
!Bool
StandardFormInfo
!Bool
| LFCon
DataCon
| LFUnknown
!Bool
| LFUnlifted
| LFLetNoEscape
data StandardFormInfo
= NonStandardThunk
| SelectorThunk
WordOff
| ApThunk
RepArity
mkLFArgument :: Id -> LambdaFormInfo
mkLFArgument :: Id -> LambdaFormInfo
mkLFArgument Id
id
| HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType Type
ty = LambdaFormInfo
LFUnlifted
| Type -> Bool
might_be_a_function Type
ty = Bool -> LambdaFormInfo
LFUnknown Bool
True
| Bool
otherwise = Bool -> LambdaFormInfo
LFUnknown Bool
False
where
ty :: Type
ty = Id -> Type
idType Id
id
mkLFLetNoEscape :: LambdaFormInfo
mkLFLetNoEscape :: LambdaFormInfo
mkLFLetNoEscape = LambdaFormInfo
LFLetNoEscape
mkLFReEntrant :: TopLevelFlag
-> [Id]
-> [Id]
-> ArgDescr
-> LambdaFormInfo
mkLFReEntrant :: TopLevelFlag -> [Id] -> [Id] -> ArgDescr -> LambdaFormInfo
mkLFReEntrant TopLevelFlag
_ [Id]
_ [] ArgDescr
_
= String -> SDoc -> LambdaFormInfo
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkLFReEntrant" SDoc
empty
mkLFReEntrant TopLevelFlag
top [Id]
fvs [Id]
args ArgDescr
arg_descr
= TopLevelFlag
-> OneShotInfo -> Int -> Bool -> ArgDescr -> LambdaFormInfo
LFReEntrant TopLevelFlag
top OneShotInfo
os_info ([Id] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
args) ([Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
fvs) ArgDescr
arg_descr
where os_info :: OneShotInfo
os_info = Id -> OneShotInfo
idOneShotInfo ([Id] -> Id
forall a. [a] -> a
head [Id]
args)
mkLFThunk :: Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LambdaFormInfo
mkLFThunk :: Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LambdaFormInfo
mkLFThunk Type
thunk_ty TopLevelFlag
top [Id]
fvs UpdateFlag
upd_flag
= ASSERT( not (isUpdatable upd_flag) || not (isUnliftedType thunk_ty) )
TopLevelFlag
-> Bool -> Bool -> StandardFormInfo -> Bool -> LambdaFormInfo
LFThunk TopLevelFlag
top ([Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
fvs)
(UpdateFlag -> Bool
isUpdatable UpdateFlag
upd_flag)
StandardFormInfo
NonStandardThunk
(Type -> Bool
might_be_a_function Type
thunk_ty)
might_be_a_function :: Type -> Bool
might_be_a_function :: Type -> Bool
might_be_a_function Type
ty
| [PrimRep
LiftedRep] <- HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
ty
, Just TyCon
tc <- Type -> Maybe TyCon
tyConAppTyCon_maybe (Type -> Type
unwrapType Type
ty)
, TyCon -> Bool
isDataTyCon TyCon
tc
= Bool
False
| Bool
otherwise
= Bool
True
mkConLFInfo :: DataCon -> LambdaFormInfo
mkConLFInfo :: DataCon -> LambdaFormInfo
mkConLFInfo DataCon
con = DataCon -> LambdaFormInfo
LFCon DataCon
con
mkSelectorLFInfo :: Id -> Int -> Bool -> LambdaFormInfo
mkSelectorLFInfo :: Id -> Int -> Bool -> LambdaFormInfo
mkSelectorLFInfo Id
id Int
offset Bool
updatable
= TopLevelFlag
-> Bool -> Bool -> StandardFormInfo -> Bool -> LambdaFormInfo
LFThunk TopLevelFlag
NotTopLevel Bool
False Bool
updatable (Int -> StandardFormInfo
SelectorThunk Int
offset)
(Type -> Bool
might_be_a_function (Id -> Type
idType Id
id))
mkApLFInfo :: Id -> UpdateFlag -> Arity -> LambdaFormInfo
mkApLFInfo :: Id -> UpdateFlag -> Int -> LambdaFormInfo
mkApLFInfo Id
id UpdateFlag
upd_flag Int
arity
= TopLevelFlag
-> Bool -> Bool -> StandardFormInfo -> Bool -> LambdaFormInfo
LFThunk TopLevelFlag
NotTopLevel (Int
arity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (UpdateFlag -> Bool
isUpdatable UpdateFlag
upd_flag) (Int -> StandardFormInfo
ApThunk Int
arity)
(Type -> Bool
might_be_a_function (Id -> Type
idType Id
id))
mkLFImported :: Id -> LambdaFormInfo
mkLFImported :: Id -> LambdaFormInfo
mkLFImported Id
id
| Just DataCon
con <- Id -> Maybe DataCon
isDataConWorkId_maybe Id
id
, DataCon -> Bool
isNullaryRepDataCon DataCon
con
= DataCon -> LambdaFormInfo
LFCon DataCon
con
| Int
arity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
= TopLevelFlag
-> OneShotInfo -> Int -> Bool -> ArgDescr -> LambdaFormInfo
LFReEntrant TopLevelFlag
TopLevel OneShotInfo
noOneShotInfo Int
arity Bool
True (String -> ArgDescr
forall a. String -> a
panic String
"arg_descr")
| Bool
otherwise
= Id -> LambdaFormInfo
mkLFArgument Id
id
where
arity :: Int
arity = Id -> Int
idFunRepArity Id
id
mkLFStringLit :: LambdaFormInfo
mkLFStringLit :: LambdaFormInfo
mkLFStringLit = LambdaFormInfo
LFUnlifted
type DynTag = Int
isSmallFamily :: DynFlags -> Int -> Bool
isSmallFamily :: DynFlags -> Int -> Bool
isSmallFamily DynFlags
dflags Int
fam_size = Int
fam_size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= DynFlags -> Int
mAX_PTR_TAG DynFlags
dflags
tagForCon :: DynFlags -> DataCon -> DynTag
tagForCon :: DynFlags -> DataCon -> Int
tagForCon DynFlags
dflags DataCon
con = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (DataCon -> Int
dataConTag DataCon
con) (DynFlags -> Int
mAX_PTR_TAG DynFlags
dflags)
tagForArity :: DynFlags -> RepArity -> DynTag
tagForArity :: DynFlags -> Int -> Int
tagForArity DynFlags
dflags Int
arity
| DynFlags -> Int -> Bool
isSmallFamily DynFlags
dflags Int
arity = Int
arity
| Bool
otherwise = Int
0
lfDynTag :: DynFlags -> LambdaFormInfo -> DynTag
lfDynTag :: DynFlags -> LambdaFormInfo -> Int
lfDynTag DynFlags
dflags (LFCon DataCon
con) = DynFlags -> DataCon -> Int
tagForCon DynFlags
dflags DataCon
con
lfDynTag DynFlags
dflags (LFReEntrant TopLevelFlag
_ OneShotInfo
_ Int
arity Bool
_ ArgDescr
_) = DynFlags -> Int -> Int
tagForArity DynFlags
dflags Int
arity
lfDynTag DynFlags
_ LambdaFormInfo
_other = Int
0
isLFThunk :: LambdaFormInfo -> Bool
isLFThunk :: LambdaFormInfo -> Bool
isLFThunk (LFThunk {}) = Bool
True
isLFThunk LambdaFormInfo
_ = Bool
False
isLFReEntrant :: LambdaFormInfo -> Bool
isLFReEntrant :: LambdaFormInfo -> Bool
isLFReEntrant (LFReEntrant {}) = Bool
True
isLFReEntrant LambdaFormInfo
_ = Bool
False
lfClosureType :: LambdaFormInfo -> ClosureTypeInfo
lfClosureType :: LambdaFormInfo -> ClosureTypeInfo
lfClosureType (LFReEntrant TopLevelFlag
_ OneShotInfo
_ Int
arity Bool
_ ArgDescr
argd) = Int -> ArgDescr -> ClosureTypeInfo
Fun Int
arity ArgDescr
argd
lfClosureType (LFCon DataCon
con) = Int -> ConstrDescription -> ClosureTypeInfo
Constr (DataCon -> Int
dataConTagZ DataCon
con)
(DataCon -> ConstrDescription
dataConIdentity DataCon
con)
lfClosureType (LFThunk TopLevelFlag
_ Bool
_ Bool
_ StandardFormInfo
is_sel Bool
_) = StandardFormInfo -> ClosureTypeInfo
thunkClosureType StandardFormInfo
is_sel
lfClosureType LambdaFormInfo
_ = String -> ClosureTypeInfo
forall a. String -> a
panic String
"lfClosureType"
thunkClosureType :: StandardFormInfo -> ClosureTypeInfo
thunkClosureType :: StandardFormInfo -> ClosureTypeInfo
thunkClosureType (SelectorThunk Int
off) = Int -> ClosureTypeInfo
ThunkSelector Int
off
thunkClosureType StandardFormInfo
_ = ClosureTypeInfo
Thunk
nodeMustPointToIt :: DynFlags -> LambdaFormInfo -> Bool
nodeMustPointToIt :: DynFlags -> LambdaFormInfo -> Bool
nodeMustPointToIt DynFlags
_ (LFReEntrant TopLevelFlag
top OneShotInfo
_ Int
_ Bool
no_fvs ArgDescr
_)
= Bool -> Bool
not Bool
no_fvs
Bool -> Bool -> Bool
|| TopLevelFlag -> Bool
isNotTopLevel TopLevelFlag
top
nodeMustPointToIt DynFlags
dflags (LFThunk TopLevelFlag
top Bool
no_fvs Bool
updatable StandardFormInfo
NonStandardThunk Bool
_)
= Bool -> Bool
not Bool
no_fvs
Bool -> Bool -> Bool
|| TopLevelFlag -> Bool
isNotTopLevel TopLevelFlag
top
Bool -> Bool -> Bool
|| Bool
updatable
Bool -> Bool -> Bool
|| GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SccProfilingOn DynFlags
dflags
nodeMustPointToIt DynFlags
_ (LFThunk {})
= Bool
True
nodeMustPointToIt DynFlags
_ (LFCon DataCon
_) = Bool
True
nodeMustPointToIt DynFlags
_ (LFUnknown Bool
_) = Bool
True
nodeMustPointToIt DynFlags
_ LambdaFormInfo
LFUnlifted = Bool
False
nodeMustPointToIt DynFlags
_ LambdaFormInfo
LFLetNoEscape = Bool
False
data CallMethod
= EnterIt
| JumpToIt BlockId [LocalReg]
| ReturnIt
| SlowCall
| DirectEntry
CLabel
RepArity
getCallMethod :: DynFlags
-> Name
-> Id
-> LambdaFormInfo
-> RepArity
-> RepArity
-> CgLoc
-> Maybe SelfLoopInfo
-> CallMethod
getCallMethod :: DynFlags
-> Name
-> Id
-> LambdaFormInfo
-> Int
-> Int
-> CgLoc
-> Maybe SelfLoopInfo
-> CallMethod
getCallMethod DynFlags
dflags Name
_ Id
id LambdaFormInfo
_ Int
n_args Int
v_args CgLoc
_cg_loc
(Just (Id
self_loop_id, BlockId
block_id, [LocalReg]
args))
| GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Loopification DynFlags
dflags
, Id
id Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
self_loop_id
, [LocalReg]
args [LocalReg] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` (Int
n_args Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
v_args)
= BlockId -> [LocalReg] -> CallMethod
JumpToIt BlockId
block_id [LocalReg]
args
getCallMethod DynFlags
dflags Name
name Id
id (LFReEntrant TopLevelFlag
_ OneShotInfo
_ Int
arity Bool
_ ArgDescr
_) Int
n_args Int
_v_args CgLoc
_cg_loc
Maybe SelfLoopInfo
_self_loop_info
| Int
n_args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
Bool -> Bool -> Bool
&& Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SccProfilingOn DynFlags
dflags)
= ASSERT( arity /= 0 ) ReturnIt
| Int
n_args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
arity = CallMethod
SlowCall
| Bool
otherwise = CLabel -> Int -> CallMethod
DirectEntry (DynFlags -> Name -> CafInfo -> CLabel
enterIdLabel DynFlags
dflags Name
name (Id -> CafInfo
idCafInfo Id
id)) Int
arity
getCallMethod DynFlags
_ Name
_name Id
_ LambdaFormInfo
LFUnlifted Int
n_args Int
_v_args CgLoc
_cg_loc Maybe SelfLoopInfo
_self_loop_info
= ASSERT( n_args == 0 ) ReturnIt
getCallMethod DynFlags
_ Name
_name Id
_ (LFCon DataCon
_) Int
n_args Int
_v_args CgLoc
_cg_loc Maybe SelfLoopInfo
_self_loop_info
= ASSERT( n_args == 0 ) ReturnIt
getCallMethod DynFlags
dflags Name
name Id
id (LFThunk TopLevelFlag
_ Bool
_ Bool
updatable StandardFormInfo
std_form_info Bool
is_fun)
Int
n_args Int
_v_args CgLoc
_cg_loc Maybe SelfLoopInfo
_self_loop_info
| Bool
is_fun
= CallMethod
SlowCall
| Bool
updatable Bool -> Bool -> Bool
|| GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Ticky DynFlags
dflags
= CallMethod
EnterIt
| SelectorThunk{} <- StandardFormInfo
std_form_info
= CallMethod
EnterIt
| Bool
otherwise
= ASSERT( n_args == 0 )
CLabel -> Int -> CallMethod
DirectEntry (DynFlags -> Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel
thunkEntryLabel DynFlags
dflags Name
name (Id -> CafInfo
idCafInfo Id
id) StandardFormInfo
std_form_info
Bool
updatable) Int
0
getCallMethod DynFlags
_ Name
_name Id
_ (LFUnknown Bool
True) Int
_n_arg Int
_v_args CgLoc
_cg_locs Maybe SelfLoopInfo
_self_loop_info
= CallMethod
SlowCall
getCallMethod DynFlags
_ Name
name Id
_ (LFUnknown Bool
False) Int
n_args Int
_v_args CgLoc
_cg_loc Maybe SelfLoopInfo
_self_loop_info
= ASSERT2( n_args == 0, ppr name <+> ppr n_args )
CallMethod
EnterIt
getCallMethod DynFlags
_ Name
_name Id
_ LambdaFormInfo
LFLetNoEscape Int
_n_args Int
_v_args (LneLoc BlockId
blk_id [LocalReg]
lne_regs)
Maybe SelfLoopInfo
_self_loop_info
= BlockId -> [LocalReg] -> CallMethod
JumpToIt BlockId
blk_id [LocalReg]
lne_regs
getCallMethod DynFlags
_ Name
_ Id
_ LambdaFormInfo
_ Int
_ Int
_ CgLoc
_ Maybe SelfLoopInfo
_ = String -> CallMethod
forall a. String -> a
panic String
"Unknown call method"
data ClosureInfo
= ClosureInfo {
ClosureInfo -> Name
closureName :: !Name,
ClosureInfo -> LambdaFormInfo
closureLFInfo :: !LambdaFormInfo,
ClosureInfo -> CLabel
closureInfoLabel :: !CLabel,
ClosureInfo -> SMRep
closureSMRep :: !SMRep,
ClosureInfo -> ProfilingInfo
closureProf :: !ProfilingInfo
}
mkCmmInfo :: ClosureInfo -> Id -> CostCentreStack -> CmmInfoTable
mkCmmInfo :: ClosureInfo -> Id -> CostCentreStack -> CmmInfoTable
mkCmmInfo ClosureInfo {Name
SMRep
CLabel
ProfilingInfo
LambdaFormInfo
closureProf :: ProfilingInfo
closureSMRep :: SMRep
closureInfoLabel :: CLabel
closureLFInfo :: LambdaFormInfo
closureName :: Name
closureProf :: ClosureInfo -> ProfilingInfo
closureSMRep :: ClosureInfo -> SMRep
closureInfoLabel :: ClosureInfo -> CLabel
closureName :: ClosureInfo -> Name
closureLFInfo :: ClosureInfo -> LambdaFormInfo
..} Id
id CostCentreStack
ccs
= CmmInfoTable :: CLabel
-> SMRep
-> ProfilingInfo
-> Maybe CLabel
-> Maybe (Id, CostCentreStack)
-> CmmInfoTable
CmmInfoTable { cit_lbl :: CLabel
cit_lbl = CLabel
closureInfoLabel
, cit_rep :: SMRep
cit_rep = SMRep
closureSMRep
, cit_prof :: ProfilingInfo
cit_prof = ProfilingInfo
closureProf
, cit_srt :: Maybe CLabel
cit_srt = Maybe CLabel
forall a. Maybe a
Nothing
, cit_clo :: Maybe (Id, CostCentreStack)
cit_clo = if SMRep -> Bool
isStaticRep SMRep
closureSMRep
then (Id, CostCentreStack) -> Maybe (Id, CostCentreStack)
forall a. a -> Maybe a
Just (Id
id,CostCentreStack
ccs)
else Maybe (Id, CostCentreStack)
forall a. Maybe a
Nothing }
mkClosureInfo :: DynFlags
-> Bool
-> Id
-> LambdaFormInfo
-> Int -> Int
-> String
-> ClosureInfo
mkClosureInfo :: DynFlags
-> Bool
-> Id
-> LambdaFormInfo
-> Int
-> Int
-> String
-> ClosureInfo
mkClosureInfo DynFlags
dflags Bool
is_static Id
id LambdaFormInfo
lf_info Int
tot_wds Int
ptr_wds String
val_descr
= ClosureInfo :: Name
-> LambdaFormInfo
-> CLabel
-> SMRep
-> ProfilingInfo
-> ClosureInfo
ClosureInfo { closureName :: Name
closureName = Name
name
, closureLFInfo :: LambdaFormInfo
closureLFInfo = LambdaFormInfo
lf_info
, closureInfoLabel :: CLabel
closureInfoLabel = CLabel
info_lbl
, closureSMRep :: SMRep
closureSMRep = SMRep
sm_rep
, closureProf :: ProfilingInfo
closureProf = ProfilingInfo
prof }
where
name :: Name
name = Id -> Name
idName Id
id
sm_rep :: SMRep
sm_rep = DynFlags -> Bool -> Int -> Int -> ClosureTypeInfo -> SMRep
mkHeapRep DynFlags
dflags Bool
is_static Int
ptr_wds Int
nonptr_wds (LambdaFormInfo -> ClosureTypeInfo
lfClosureType LambdaFormInfo
lf_info)
prof :: ProfilingInfo
prof = DynFlags -> Id -> String -> ProfilingInfo
mkProfilingInfo DynFlags
dflags Id
id String
val_descr
nonptr_wds :: Int
nonptr_wds = Int
tot_wds Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ptr_wds
info_lbl :: CLabel
info_lbl = Id -> LambdaFormInfo -> CLabel
mkClosureInfoTableLabel Id
id LambdaFormInfo
lf_info
blackHoleOnEntry :: ClosureInfo -> Bool
blackHoleOnEntry :: ClosureInfo -> Bool
blackHoleOnEntry ClosureInfo
cl_info
| SMRep -> Bool
isStaticRep (ClosureInfo -> SMRep
closureSMRep ClosureInfo
cl_info)
= Bool
False
| Bool
otherwise
= case ClosureInfo -> LambdaFormInfo
closureLFInfo ClosureInfo
cl_info of
LFReEntrant {} -> Bool
False
LambdaFormInfo
LFLetNoEscape -> Bool
False
LFThunk TopLevelFlag
_ Bool
_no_fvs Bool
upd StandardFormInfo
_ Bool
_ -> Bool
upd
LambdaFormInfo
_other -> String -> Bool
forall a. String -> a
panic String
"blackHoleOnEntry"
isStaticClosure :: ClosureInfo -> Bool
isStaticClosure :: ClosureInfo -> Bool
isStaticClosure ClosureInfo
cl_info = SMRep -> Bool
isStaticRep (ClosureInfo -> SMRep
closureSMRep ClosureInfo
cl_info)
closureUpdReqd :: ClosureInfo -> Bool
closureUpdReqd :: ClosureInfo -> Bool
closureUpdReqd ClosureInfo{ closureLFInfo :: ClosureInfo -> LambdaFormInfo
closureLFInfo = LambdaFormInfo
lf_info } = LambdaFormInfo -> Bool
lfUpdatable LambdaFormInfo
lf_info
lfUpdatable :: LambdaFormInfo -> Bool
lfUpdatable :: LambdaFormInfo -> Bool
lfUpdatable (LFThunk TopLevelFlag
_ Bool
_ Bool
upd StandardFormInfo
_ Bool
_) = Bool
upd
lfUpdatable LambdaFormInfo
_ = Bool
False
closureSingleEntry :: ClosureInfo -> Bool
closureSingleEntry :: ClosureInfo -> Bool
closureSingleEntry (ClosureInfo { closureLFInfo :: ClosureInfo -> LambdaFormInfo
closureLFInfo = LFThunk TopLevelFlag
_ Bool
_ Bool
upd StandardFormInfo
_ Bool
_}) = Bool -> Bool
not Bool
upd
closureSingleEntry (ClosureInfo { closureLFInfo :: ClosureInfo -> LambdaFormInfo
closureLFInfo = LFReEntrant TopLevelFlag
_ OneShotInfo
OneShotLam Int
_ Bool
_ ArgDescr
_}) = Bool
True
closureSingleEntry ClosureInfo
_ = Bool
False
closureReEntrant :: ClosureInfo -> Bool
closureReEntrant :: ClosureInfo -> Bool
closureReEntrant (ClosureInfo { closureLFInfo :: ClosureInfo -> LambdaFormInfo
closureLFInfo = LFReEntrant {} }) = Bool
True
closureReEntrant ClosureInfo
_ = Bool
False
closureFunInfo :: ClosureInfo -> Maybe (RepArity, ArgDescr)
closureFunInfo :: ClosureInfo -> Maybe (Int, ArgDescr)
closureFunInfo (ClosureInfo { closureLFInfo :: ClosureInfo -> LambdaFormInfo
closureLFInfo = LambdaFormInfo
lf_info }) = LambdaFormInfo -> Maybe (Int, ArgDescr)
lfFunInfo LambdaFormInfo
lf_info
lfFunInfo :: LambdaFormInfo -> Maybe (RepArity, ArgDescr)
lfFunInfo :: LambdaFormInfo -> Maybe (Int, ArgDescr)
lfFunInfo (LFReEntrant TopLevelFlag
_ OneShotInfo
_ Int
arity Bool
_ ArgDescr
arg_desc) = (Int, ArgDescr) -> Maybe (Int, ArgDescr)
forall a. a -> Maybe a
Just (Int
arity, ArgDescr
arg_desc)
lfFunInfo LambdaFormInfo
_ = Maybe (Int, ArgDescr)
forall a. Maybe a
Nothing
funTag :: DynFlags -> ClosureInfo -> DynTag
funTag :: DynFlags -> ClosureInfo -> Int
funTag DynFlags
dflags (ClosureInfo { closureLFInfo :: ClosureInfo -> LambdaFormInfo
closureLFInfo = LambdaFormInfo
lf_info })
= DynFlags -> LambdaFormInfo -> Int
lfDynTag DynFlags
dflags LambdaFormInfo
lf_info
isToplevClosure :: ClosureInfo -> Bool
isToplevClosure :: ClosureInfo -> Bool
isToplevClosure (ClosureInfo { closureLFInfo :: ClosureInfo -> LambdaFormInfo
closureLFInfo = LambdaFormInfo
lf_info })
= case LambdaFormInfo
lf_info of
LFReEntrant TopLevelFlag
TopLevel OneShotInfo
_ Int
_ Bool
_ ArgDescr
_ -> Bool
True
LFThunk TopLevelFlag
TopLevel Bool
_ Bool
_ StandardFormInfo
_ Bool
_ -> Bool
True
LambdaFormInfo
_other -> Bool
False
staticClosureLabel :: ClosureInfo -> CLabel
staticClosureLabel :: ClosureInfo -> CLabel
staticClosureLabel = CLabel -> CLabel
toClosureLbl (CLabel -> CLabel)
-> (ClosureInfo -> CLabel) -> ClosureInfo -> CLabel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClosureInfo -> CLabel
closureInfoLabel
closureSlowEntryLabel :: ClosureInfo -> CLabel
closureSlowEntryLabel :: ClosureInfo -> CLabel
closureSlowEntryLabel = CLabel -> CLabel
toSlowEntryLbl (CLabel -> CLabel)
-> (ClosureInfo -> CLabel) -> ClosureInfo -> CLabel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClosureInfo -> CLabel
closureInfoLabel
closureLocalEntryLabel :: DynFlags -> ClosureInfo -> CLabel
closureLocalEntryLabel :: DynFlags -> ClosureInfo -> CLabel
closureLocalEntryLabel DynFlags
dflags
| DynFlags -> Bool
tablesNextToCode DynFlags
dflags = CLabel -> CLabel
toInfoLbl (CLabel -> CLabel)
-> (ClosureInfo -> CLabel) -> ClosureInfo -> CLabel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClosureInfo -> CLabel
closureInfoLabel
| Bool
otherwise = CLabel -> CLabel
toEntryLbl (CLabel -> CLabel)
-> (ClosureInfo -> CLabel) -> ClosureInfo -> CLabel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClosureInfo -> CLabel
closureInfoLabel
mkClosureInfoTableLabel :: Id -> LambdaFormInfo -> CLabel
mkClosureInfoTableLabel :: Id -> LambdaFormInfo -> CLabel
mkClosureInfoTableLabel Id
id LambdaFormInfo
lf_info
= case LambdaFormInfo
lf_info of
LFThunk TopLevelFlag
_ Bool
_ Bool
upd_flag (SelectorThunk Int
offset) Bool
_
-> Bool -> Int -> CLabel
mkSelectorInfoLabel Bool
upd_flag Int
offset
LFThunk TopLevelFlag
_ Bool
_ Bool
upd_flag (ApThunk Int
arity) Bool
_
-> Bool -> Int -> CLabel
mkApInfoTableLabel Bool
upd_flag Int
arity
LFThunk{} -> Name -> CafInfo -> CLabel
std_mk_lbl Name
name CafInfo
cafs
LFReEntrant{} -> Name -> CafInfo -> CLabel
std_mk_lbl Name
name CafInfo
cafs
LambdaFormInfo
_other -> String -> CLabel
forall a. String -> a
panic String
"closureInfoTableLabel"
where
name :: Name
name = Id -> Name
idName Id
id
std_mk_lbl :: Name -> CafInfo -> CLabel
std_mk_lbl | Bool
is_local = Name -> CafInfo -> CLabel
mkLocalInfoTableLabel
| Bool
otherwise = Name -> CafInfo -> CLabel
mkInfoTableLabel
cafs :: CafInfo
cafs = Id -> CafInfo
idCafInfo Id
id
is_local :: Bool
is_local = Id -> Bool
isDataConWorkId Id
id
thunkEntryLabel :: DynFlags -> Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel
thunkEntryLabel :: DynFlags -> Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel
thunkEntryLabel DynFlags
dflags Name
_thunk_id CafInfo
_ (ApThunk Int
arity) Bool
upd_flag
= DynFlags -> Bool -> Int -> CLabel
enterApLabel DynFlags
dflags Bool
upd_flag Int
arity
thunkEntryLabel DynFlags
dflags Name
_thunk_id CafInfo
_ (SelectorThunk Int
offset) Bool
upd_flag
= DynFlags -> Bool -> Int -> CLabel
enterSelectorLabel DynFlags
dflags Bool
upd_flag Int
offset
thunkEntryLabel DynFlags
dflags Name
thunk_id CafInfo
c StandardFormInfo
_ Bool
_
= DynFlags -> Name -> CafInfo -> CLabel
enterIdLabel DynFlags
dflags Name
thunk_id CafInfo
c
enterApLabel :: DynFlags -> Bool -> Arity -> CLabel
enterApLabel :: DynFlags -> Bool -> Int -> CLabel
enterApLabel DynFlags
dflags Bool
is_updatable Int
arity
| DynFlags -> Bool
tablesNextToCode DynFlags
dflags = Bool -> Int -> CLabel
mkApInfoTableLabel Bool
is_updatable Int
arity
| Bool
otherwise = Bool -> Int -> CLabel
mkApEntryLabel Bool
is_updatable Int
arity
enterSelectorLabel :: DynFlags -> Bool -> WordOff -> CLabel
enterSelectorLabel :: DynFlags -> Bool -> Int -> CLabel
enterSelectorLabel DynFlags
dflags Bool
upd_flag Int
offset
| DynFlags -> Bool
tablesNextToCode DynFlags
dflags = Bool -> Int -> CLabel
mkSelectorInfoLabel Bool
upd_flag Int
offset
| Bool
otherwise = Bool -> Int -> CLabel
mkSelectorEntryLabel Bool
upd_flag Int
offset
enterIdLabel :: DynFlags -> Name -> CafInfo -> CLabel
enterIdLabel :: DynFlags -> Name -> CafInfo -> CLabel
enterIdLabel DynFlags
dflags Name
id CafInfo
c
| DynFlags -> Bool
tablesNextToCode DynFlags
dflags = Name -> CafInfo -> CLabel
mkInfoTableLabel Name
id CafInfo
c
| Bool
otherwise = Name -> CafInfo -> CLabel
mkEntryLabel Name
id CafInfo
c
mkProfilingInfo :: DynFlags -> Id -> String -> ProfilingInfo
mkProfilingInfo :: DynFlags -> Id -> String -> ProfilingInfo
mkProfilingInfo DynFlags
dflags Id
id String
val_descr
| Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SccProfilingOn DynFlags
dflags) = ProfilingInfo
NoProfilingInfo
| Bool
otherwise = ConstrDescription -> ConstrDescription -> ProfilingInfo
ProfilingInfo ConstrDescription
ty_descr_w8 (String -> ConstrDescription
BS8.pack String
val_descr)
where
ty_descr_w8 :: ConstrDescription
ty_descr_w8 = String -> ConstrDescription
BS8.pack (Type -> String
getTyDescription (Id -> Type
idType Id
id))
getTyDescription :: Type -> String
getTyDescription :: Type -> String
getTyDescription Type
ty
= case (Type -> ([Id], ThetaType, Type)
tcSplitSigmaTy Type
ty) of { ([Id]
_, ThetaType
_, Type
tau_ty) ->
case Type
tau_ty of
TyVarTy Id
_ -> String
"*"
AppTy Type
fun Type
_ -> Type -> String
getTyDescription Type
fun
TyConApp TyCon
tycon ThetaType
_ -> TyCon -> String
forall a. NamedThing a => a -> String
getOccString TyCon
tycon
FunTy {} -> Char
'-' Char -> ShowS
forall a. a -> [a] -> [a]
: Type -> String
fun_result Type
tau_ty
ForAllTy TyCoVarBinder
_ Type
ty -> Type -> String
getTyDescription Type
ty
LitTy TyLit
n -> TyLit -> String
getTyLitDescription TyLit
n
CastTy Type
ty KindCoercion
_ -> Type -> String
getTyDescription Type
ty
CoercionTy KindCoercion
co -> String -> SDoc -> String
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getTyDescription" (KindCoercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr KindCoercion
co)
}
where
fun_result :: Type -> String
fun_result (FunTy { ft_res :: Type -> Type
ft_res = Type
res }) = Char
'>' Char -> ShowS
forall a. a -> [a] -> [a]
: Type -> String
fun_result Type
res
fun_result Type
other = Type -> String
getTyDescription Type
other
getTyLitDescription :: TyLit -> String
getTyLitDescription :: TyLit -> String
getTyLitDescription TyLit
l =
case TyLit
l of
NumTyLit Integer
n -> Integer -> String
forall a. Show a => a -> String
show Integer
n
StrTyLit FastString
n -> FastString -> String
forall a. Show a => a -> String
show FastString
n
mkDataConInfoTable :: DynFlags -> DataCon -> Bool -> Int -> Int -> CmmInfoTable
mkDataConInfoTable :: DynFlags -> DataCon -> Bool -> Int -> Int -> CmmInfoTable
mkDataConInfoTable DynFlags
dflags DataCon
data_con Bool
is_static Int
ptr_wds Int
nonptr_wds
= CmmInfoTable :: CLabel
-> SMRep
-> ProfilingInfo
-> Maybe CLabel
-> Maybe (Id, CostCentreStack)
-> CmmInfoTable
CmmInfoTable { cit_lbl :: CLabel
cit_lbl = CLabel
info_lbl
, cit_rep :: SMRep
cit_rep = SMRep
sm_rep
, cit_prof :: ProfilingInfo
cit_prof = ProfilingInfo
prof
, cit_srt :: Maybe CLabel
cit_srt = Maybe CLabel
forall a. Maybe a
Nothing
, cit_clo :: Maybe (Id, CostCentreStack)
cit_clo = Maybe (Id, CostCentreStack)
forall a. Maybe a
Nothing }
where
name :: Name
name = DataCon -> Name
dataConName DataCon
data_con
info_lbl :: CLabel
info_lbl = Name -> CafInfo -> CLabel
mkConInfoTableLabel Name
name CafInfo
NoCafRefs
sm_rep :: SMRep
sm_rep = DynFlags -> Bool -> Int -> Int -> ClosureTypeInfo -> SMRep
mkHeapRep DynFlags
dflags Bool
is_static Int
ptr_wds Int
nonptr_wds ClosureTypeInfo
cl_type
cl_type :: ClosureTypeInfo
cl_type = Int -> ConstrDescription -> ClosureTypeInfo
Constr (DataCon -> Int
dataConTagZ DataCon
data_con) (DataCon -> ConstrDescription
dataConIdentity DataCon
data_con)
prof :: ProfilingInfo
prof | Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SccProfilingOn DynFlags
dflags) = ProfilingInfo
NoProfilingInfo
| Bool
otherwise = ConstrDescription -> ConstrDescription -> ProfilingInfo
ProfilingInfo ConstrDescription
ty_descr ConstrDescription
val_descr
ty_descr :: ConstrDescription
ty_descr = String -> ConstrDescription
BS8.pack (String -> ConstrDescription) -> String -> ConstrDescription
forall a b. (a -> b) -> a -> b
$ OccName -> String
occNameString (OccName -> String) -> OccName -> String
forall a b. (a -> b) -> a -> b
$ TyCon -> OccName
forall a. NamedThing a => a -> OccName
getOccName (TyCon -> OccName) -> TyCon -> OccName
forall a b. (a -> b) -> a -> b
$ DataCon -> TyCon
dataConTyCon DataCon
data_con
val_descr :: ConstrDescription
val_descr = String -> ConstrDescription
BS8.pack (String -> ConstrDescription) -> String -> ConstrDescription
forall a b. (a -> b) -> a -> b
$ OccName -> String
occNameString (OccName -> String) -> OccName -> String
forall a b. (a -> b) -> a -> b
$ DataCon -> OccName
forall a. NamedThing a => a -> OccName
getOccName DataCon
data_con
cafBlackHoleInfoTable :: CmmInfoTable
cafBlackHoleInfoTable :: CmmInfoTable
cafBlackHoleInfoTable
= CmmInfoTable :: CLabel
-> SMRep
-> ProfilingInfo
-> Maybe CLabel
-> Maybe (Id, CostCentreStack)
-> CmmInfoTable
CmmInfoTable { cit_lbl :: CLabel
cit_lbl = CLabel
mkCAFBlackHoleInfoTableLabel
, cit_rep :: SMRep
cit_rep = SMRep
blackHoleRep
, cit_prof :: ProfilingInfo
cit_prof = ProfilingInfo
NoProfilingInfo
, cit_srt :: Maybe CLabel
cit_srt = Maybe CLabel
forall a. Maybe a
Nothing
, cit_clo :: Maybe (Id, CostCentreStack)
cit_clo = Maybe (Id, CostCentreStack)
forall a. Maybe a
Nothing }
indStaticInfoTable :: CmmInfoTable
indStaticInfoTable :: CmmInfoTable
indStaticInfoTable
= CmmInfoTable :: CLabel
-> SMRep
-> ProfilingInfo
-> Maybe CLabel
-> Maybe (Id, CostCentreStack)
-> CmmInfoTable
CmmInfoTable { cit_lbl :: CLabel
cit_lbl = CLabel
mkIndStaticInfoLabel
, cit_rep :: SMRep
cit_rep = SMRep
indStaticRep
, cit_prof :: ProfilingInfo
cit_prof = ProfilingInfo
NoProfilingInfo
, cit_srt :: Maybe CLabel
cit_srt = Maybe CLabel
forall a. Maybe a
Nothing
, cit_clo :: Maybe (Id, CostCentreStack)
cit_clo = Maybe (Id, CostCentreStack)
forall a. Maybe a
Nothing }
staticClosureNeedsLink :: Bool -> CmmInfoTable -> Bool
staticClosureNeedsLink :: Bool -> CmmInfoTable -> Bool
staticClosureNeedsLink Bool
has_srt CmmInfoTable{ cit_rep :: CmmInfoTable -> SMRep
cit_rep = SMRep
smrep }
| SMRep -> Bool
isConRep SMRep
smrep = Bool -> Bool
not (SMRep -> Bool
isStaticNoCafCon SMRep
smrep)
| Bool
otherwise = Bool
has_srt