module GHC.StgToCmm.DataCon (
cgTopRhsCon, buildDynCon, bindConArgs
) where
import GHC.Prelude
import GHC.Platform
import GHC.Stg.Syntax
import GHC.Core ( AltCon(..) )
import GHC.StgToCmm.Monad
import GHC.StgToCmm.Env
import GHC.StgToCmm.Heap
import GHC.StgToCmm.Layout
import GHC.StgToCmm.Utils
import GHC.StgToCmm.Closure
import GHC.Cmm.Expr
import GHC.Cmm.Utils
import GHC.Cmm.CLabel
import GHC.Cmm.Graph
import GHC.Runtime.Heap.Layout
import GHC.Types.CostCentre
import GHC.Unit
import GHC.Core.DataCon
import GHC.Data.FastString
import GHC.Types.Id
import GHC.Types.Id.Info( CafInfo( NoCafRefs ) )
import GHC.Types.Name (isInternalName)
import GHC.Types.RepType (countConRepArgs)
import GHC.Types.Literal
import GHC.Builtin.Utils
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
import GHC.Utils.Monad (mapMaybeM)
import Control.Monad
import Data.Char
import GHC.StgToCmm.Config (stgToCmmPlatform)
import GHC.StgToCmm.TagCheck (checkConArgsStatic, checkConArgsDyn)
import GHC.Utils.Outputable
cgTopRhsCon :: StgToCmmConfig
-> Id
-> DataCon
-> ConstructorNumber
-> [NonVoid StgArg]
-> (CgIdInfo, FCode ())
cgTopRhsCon :: StgToCmmConfig
-> Id
-> DataCon
-> ConstructorNumber
-> [NonVoid StgArg]
-> (CgIdInfo, FCode ())
cgTopRhsCon StgToCmmConfig
cfg Id
id DataCon
con ConstructorNumber
mn [NonVoid StgArg]
args
| Just CgIdInfo
static_info <- StgToCmmConfig
-> Id -> DataCon -> [NonVoid StgArg] -> Maybe CgIdInfo
precomputedStaticConInfo_maybe StgToCmmConfig
cfg Id
id DataCon
con [NonVoid StgArg]
args
, let static_code :: FCode ()
static_code | Name -> Bool
isInternalName Name
name = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
| Bool
otherwise = FCode ()
gen_code
=
(CgIdInfo
static_info, FCode ()
static_code)
| Bool
otherwise
= (CgIdInfo
id_Info, FCode ()
gen_code)
where
platform :: Platform
platform = StgToCmmConfig -> Platform
stgToCmmPlatform StgToCmmConfig
cfg
id_Info :: CgIdInfo
id_Info = Platform -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
litIdInfo Platform
platform Id
id (DataCon -> LambdaFormInfo
mkConLFInfo DataCon
con) (CLabel -> CmmLit
CmmLabel CLabel
closure_label)
name :: Name
name = Id -> Name
idName Id
id
caffy :: CafInfo
caffy = Id -> CafInfo
idCafInfo Id
id
closure_label :: CLabel
closure_label = Name -> CafInfo -> CLabel
mkClosureLabel Name
name CafInfo
caffy
gen_code :: FCode ()
gen_code =
do { Profile
profile <- FCode Profile
getProfile
; Module
this_mod <- FCode Module
getModuleName
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Platform -> OS
platformOS Platform
platform forall a. Eq a => a -> a -> Bool
== OS
OSMinGW32) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (Bool -> Bool
not (Platform -> Bool -> Module -> DataCon -> [StgArg] -> Bool
isDllConApp Platform
platform (StgToCmmConfig -> Bool
stgToCmmExtDynRefs StgToCmmConfig
cfg) Module
this_mod DataCon
con (forall a b. (a -> b) -> [a] -> [b]
map forall a. NonVoid a -> a
fromNonVoid [NonVoid StgArg]
args)))
; forall a. HasCallStack => Bool -> a -> a
assert ([NonVoid StgArg]
args forall a. [a] -> Int -> Bool
`lengthIs` DataCon -> Int
countConRepArgs DataCon
con ) forall (m :: * -> *) a. Monad m => a -> m a
return ()
; SDoc -> DataCon -> [StgArg] -> FCode ()
checkConArgsStatic (String -> SDoc
text String
"TagCheck failed - Top level con") DataCon
con (forall a b. (a -> b) -> [a] -> [b]
map forall a. NonVoid a -> a
fromNonVoid [NonVoid StgArg]
args)
; let
(Int
tot_wds,
Int
ptr_wds,
[FieldOffOrPadding StgArg]
nv_args_w_offsets) =
forall a.
Profile
-> ClosureHeader
-> [NonVoid (PrimRep, a)]
-> (Int, Int, [FieldOffOrPadding a])
mkVirtHeapOffsetsWithPadding Profile
profile ClosureHeader
StdHeader ([NonVoid StgArg] -> [NonVoid (PrimRep, StgArg)]
addArgReps [NonVoid StgArg]
args)
; let
fix_padding :: [FieldOffOrPadding a] -> [FieldOffOrPadding a]
fix_padding (x :: FieldOffOrPadding a
x@(Padding Int
n Int
off) : [FieldOffOrPadding a]
rest)
| Int
n forall a. Eq a => a -> a -> Bool
== Int
0 = [FieldOffOrPadding a] -> [FieldOffOrPadding a]
fix_padding [FieldOffOrPadding a]
rest
| Int
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
1,Int
2,Int
4,Int
8] = FieldOffOrPadding a
x forall a. a -> [a] -> [a]
: [FieldOffOrPadding a] -> [FieldOffOrPadding a]
fix_padding [FieldOffOrPadding a]
rest
| Int
n forall a. Ord a => a -> a -> Bool
> Int
8 = Int -> [FieldOffOrPadding a]
add_pad Int
8
| Int
n forall a. Ord a => a -> a -> Bool
> Int
4 = Int -> [FieldOffOrPadding a]
add_pad Int
4
| Int
n forall a. Ord a => a -> a -> Bool
> Int
2 = Int -> [FieldOffOrPadding a]
add_pad Int
2
| Bool
otherwise = Int -> [FieldOffOrPadding a]
add_pad Int
1
where add_pad :: Int -> [FieldOffOrPadding a]
add_pad Int
m = forall a. Int -> Int -> FieldOffOrPadding a
Padding Int
m Int
off forall a. a -> [a] -> [a]
: [FieldOffOrPadding a] -> [FieldOffOrPadding a]
fix_padding (forall a. Int -> Int -> FieldOffOrPadding a
Padding (Int
nforall a. Num a => a -> a -> a
-Int
m) (Int
offforall a. Num a => a -> a -> a
+Int
m) forall a. a -> [a] -> [a]
: [FieldOffOrPadding a]
rest)
fix_padding (FieldOffOrPadding a
x : [FieldOffOrPadding a]
rest) = FieldOffOrPadding a
x forall a. a -> [a] -> [a]
: [FieldOffOrPadding a] -> [FieldOffOrPadding a]
fix_padding [FieldOffOrPadding a]
rest
fix_padding [] = []
mk_payload :: FieldOffOrPadding StgArg -> FCode CmmLit
mk_payload (Padding Int
len Int
_) = forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Width -> CmmLit
CmmInt Integer
0 (Int -> Width
widthFromBytes Int
len))
mk_payload (FieldOff NonVoid StgArg
arg Int
_) = do
CmmExpr
amode <- NonVoid StgArg -> FCode CmmExpr
getArgAmode NonVoid StgArg
arg
case CmmExpr
amode of
CmmLit CmmLit
lit -> forall (m :: * -> *) a. Monad m => a -> m a
return CmmLit
lit
CmmExpr
_ -> forall a. String -> a
panic String
"GHC.StgToCmm.DataCon.cgTopRhsCon"
nonptr_wds :: Int
nonptr_wds = Int
tot_wds forall a. Num a => a -> a -> a
- Int
ptr_wds
info_tbl :: CmmInfoTable
info_tbl = Profile
-> DataCon
-> ConInfoTableLocation
-> Bool
-> Int
-> Int
-> CmmInfoTable
mkDataConInfoTable Profile
profile DataCon
con (Module -> ConstructorNumber -> ConInfoTableLocation
addModuleLoc Module
this_mod ConstructorNumber
mn) Bool
True Int
ptr_wds Int
nonptr_wds
; [CmmLit]
payload <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FieldOffOrPadding StgArg -> FCode CmmLit
mk_payload (forall {a}. [FieldOffOrPadding a] -> [FieldOffOrPadding a]
fix_padding [FieldOffOrPadding StgArg]
nv_args_w_offsets)
; CLabel -> CmmInfoTable -> CostCentreStack -> [CmmLit] -> FCode ()
emitDataCon CLabel
closure_label CmmInfoTable
info_tbl CostCentreStack
dontCareCCS [CmmLit]
payload }
addModuleLoc :: Module -> ConstructorNumber -> ConInfoTableLocation
addModuleLoc :: Module -> ConstructorNumber -> ConInfoTableLocation
addModuleLoc Module
this_mod ConstructorNumber
mn = do
case ConstructorNumber
mn of
ConstructorNumber
NoNumber -> ConInfoTableLocation
DefinitionSite
Numbered Int
n -> Module -> Int -> ConInfoTableLocation
UsageSite Module
this_mod Int
n
buildDynCon :: Id
-> ConstructorNumber
-> Bool
-> CostCentreStack
-> DataCon
-> [NonVoid StgArg]
-> FCode (CgIdInfo, FCode CmmAGraph)
buildDynCon :: Id
-> ConstructorNumber
-> Bool
-> CostCentreStack
-> DataCon
-> [NonVoid StgArg]
-> FCode (CgIdInfo, FCode CmmAGraph)
buildDynCon Id
binder ConstructorNumber
mn Bool
actually_bound CostCentreStack
cc DataCon
con [NonVoid StgArg]
args
= do StgToCmmConfig
cfg <- FCode StgToCmmConfig
getStgToCmmConfig
case StgToCmmConfig
-> Id -> DataCon -> [NonVoid StgArg] -> Maybe CgIdInfo
precomputedStaticConInfo_maybe StgToCmmConfig
cfg Id
binder DataCon
con [NonVoid StgArg]
args of
Just CgIdInfo
cgInfo -> forall (m :: * -> *) a. Monad m => a -> m a
return (CgIdInfo
cgInfo, forall (m :: * -> *) a. Monad m => a -> m a
return CmmAGraph
mkNop)
Maybe CgIdInfo
Nothing -> Id
-> ConstructorNumber
-> Bool
-> CostCentreStack
-> DataCon
-> [NonVoid StgArg]
-> FCode (CgIdInfo, FCode CmmAGraph)
buildDynCon' Id
binder ConstructorNumber
mn Bool
actually_bound CostCentreStack
cc DataCon
con [NonVoid StgArg]
args
buildDynCon' :: Id
-> ConstructorNumber
-> Bool
-> CostCentreStack
-> DataCon
-> [NonVoid StgArg]
-> FCode (CgIdInfo, FCode CmmAGraph)
buildDynCon' :: Id
-> ConstructorNumber
-> Bool
-> CostCentreStack
-> DataCon
-> [NonVoid StgArg]
-> FCode (CgIdInfo, FCode CmmAGraph)
buildDynCon' Id
binder ConstructorNumber
mn Bool
actually_bound CostCentreStack
ccs DataCon
con [NonVoid StgArg]
args
= do { (CgIdInfo
id_info, LocalReg
reg) <- Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg)
rhsIdInfo Id
binder LambdaFormInfo
lf_info
; forall (m :: * -> *) a. Monad m => a -> m a
return (CgIdInfo
id_info, LocalReg -> FCode CmmAGraph
gen_code LocalReg
reg)
}
where
lf_info :: LambdaFormInfo
lf_info = DataCon -> LambdaFormInfo
mkConLFInfo DataCon
con
gen_code :: LocalReg -> FCode CmmAGraph
gen_code LocalReg
reg
= do { Module
modu <- FCode Module
getModuleName
; StgToCmmConfig
cfg <- FCode StgToCmmConfig
getStgToCmmConfig
; let platform :: Platform
platform = StgToCmmConfig -> Platform
stgToCmmPlatform StgToCmmConfig
cfg
profile :: Profile
profile = StgToCmmConfig -> Profile
stgToCmmProfile StgToCmmConfig
cfg
(Int
tot_wds, Int
ptr_wds, [(NonVoid StgArg, Int)]
args_w_offsets)
= forall a.
Profile -> [NonVoid (PrimRep, a)] -> (Int, Int, [(NonVoid a, Int)])
mkVirtConstrOffsets Profile
profile ([NonVoid StgArg] -> [NonVoid (PrimRep, StgArg)]
addArgReps [NonVoid StgArg]
args)
nonptr_wds :: Int
nonptr_wds = Int
tot_wds forall a. Num a => a -> a -> a
- Int
ptr_wds
info_tbl :: CmmInfoTable
info_tbl = Profile
-> DataCon
-> ConInfoTableLocation
-> Bool
-> Int
-> Int
-> CmmInfoTable
mkDataConInfoTable Profile
profile DataCon
con (Module -> ConstructorNumber -> ConInfoTableLocation
addModuleLoc Module
modu ConstructorNumber
mn) Bool
False
Int
ptr_wds Int
nonptr_wds
; let ticky_name :: Maybe Id
ticky_name | Bool
actually_bound = forall a. a -> Maybe a
Just Id
binder
| Bool
otherwise = forall a. Maybe a
Nothing
; SDoc -> DataCon -> [StgArg] -> FCode ()
checkConArgsDyn (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"TagCheck failed on constructor application.") Int
4 forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"On binder:" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Id
binder SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"Constructor:" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr DataCon
con) DataCon
con (forall a b. (a -> b) -> [a] -> [b]
map forall a. NonVoid a -> a
fromNonVoid [NonVoid StgArg]
args)
; CmmExpr
hp_plus_n <- Maybe Id
-> CmmInfoTable
-> LambdaFormInfo
-> CmmExpr
-> CmmExpr
-> [(NonVoid StgArg, Int)]
-> FCode CmmExpr
allocDynClosure Maybe Id
ticky_name CmmInfoTable
info_tbl LambdaFormInfo
lf_info
CmmExpr
use_cc CmmExpr
blame_cc [(NonVoid StgArg, Int)]
args_w_offsets
; forall (m :: * -> *) a. Monad m => a -> m a
return (Platform -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph
mkRhsInit Platform
platform LocalReg
reg LambdaFormInfo
lf_info CmmExpr
hp_plus_n) }
where
use_cc :: CmmExpr
use_cc
| CostCentreStack -> Bool
isCurrentCCS CostCentreStack
ccs = CmmExpr
cccsExpr
| Bool
otherwise = forall a. String -> a
panic String
"buildDynCon: non-current CCS not implemented"
blame_cc :: CmmExpr
blame_cc = CmmExpr
use_cc
precomputedStaticConInfo_maybe :: StgToCmmConfig -> Id -> DataCon -> [NonVoid StgArg] -> Maybe CgIdInfo
precomputedStaticConInfo_maybe :: StgToCmmConfig
-> Id -> DataCon -> [NonVoid StgArg] -> Maybe CgIdInfo
precomputedStaticConInfo_maybe StgToCmmConfig
cfg Id
binder DataCon
con []
| DataCon -> Bool
isNullaryRepDataCon DataCon
con
= forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Platform -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
litIdInfo (StgToCmmConfig -> Platform
stgToCmmPlatform StgToCmmConfig
cfg) Id
binder (DataCon -> LambdaFormInfo
mkConLFInfo DataCon
con)
(CLabel -> CmmLit
CmmLabel (Name -> CafInfo -> CLabel
mkClosureLabel (DataCon -> Name
dataConName DataCon
con) CafInfo
NoCafRefs))
precomputedStaticConInfo_maybe StgToCmmConfig
cfg Id
binder DataCon
con [NonVoid StgArg
arg]
| Bool
intClosure Bool -> Bool -> Bool
|| Bool
charClosure
, Platform -> OS
platformOS Platform
platform forall a. Eq a => a -> a -> Bool
/= OS
OSMinGW32 Bool -> Bool -> Bool
|| Bool -> Bool
not (StgToCmmConfig -> Bool
stgToCmmPIE StgToCmmConfig
cfg Bool -> Bool -> Bool
|| StgToCmmConfig -> Bool
stgToCmmPIC StgToCmmConfig
cfg)
, Just Integer
val <- NonVoid StgArg -> Maybe Integer
getClosurePayload NonVoid StgArg
arg
, Integer -> Bool
inRange Integer
val
= let intlike_lbl :: CLabel
intlike_lbl = UnitId -> FastString -> CLabel
mkCmmClosureLabel UnitId
rtsUnitId (String -> FastString
fsLit String
label)
val_int :: Int
val_int = forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
val :: Int
offsetW :: Int
offsetW = (Int
val_int forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
min_static_range) forall a. Num a => a -> a -> a
* (Profile -> Int
fixedHdrSizeW Profile
profile forall a. Num a => a -> a -> a
+ Int
1)
static_amode :: CmmLit
static_amode = Platform -> CLabel -> Int -> CmmLit
cmmLabelOffW Platform
platform CLabel
intlike_lbl Int
offsetW
in forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Platform -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
litIdInfo Platform
platform Id
binder (DataCon -> LambdaFormInfo
mkConLFInfo DataCon
con) CmmLit
static_amode
where
profile :: Profile
profile = StgToCmmConfig -> Profile
stgToCmmProfile StgToCmmConfig
cfg
platform :: Platform
platform = StgToCmmConfig -> Platform
stgToCmmPlatform StgToCmmConfig
cfg
intClosure :: Bool
intClosure = DataCon -> Bool
maybeIntLikeCon DataCon
con
charClosure :: Bool
charClosure = DataCon -> Bool
maybeCharLikeCon DataCon
con
getClosurePayload :: NonVoid StgArg -> Maybe Integer
getClosurePayload (NonVoid (StgLitArg (LitNumber LitNumType
LitNumInt Integer
val))) = forall a. a -> Maybe a
Just Integer
val
getClosurePayload (NonVoid (StgLitArg (LitChar Char
val))) = forall a. a -> Maybe a
Just (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord forall a b. (a -> b) -> a -> b
$ Char
val)
getClosurePayload NonVoid StgArg
_ = forall a. Maybe a
Nothing
inRange :: Integer -> Bool
inRange :: Integer -> Bool
inRange Integer
val
= Integer
val forall a. Ord a => a -> a -> Bool
>= Integer
min_static_range Bool -> Bool -> Bool
&& Integer
val forall a. Ord a => a -> a -> Bool
<= Integer
max_static_range
constants :: PlatformConstants
constants = Platform -> PlatformConstants
platformConstants Platform
platform
min_static_range :: Integer
min_static_range :: Integer
min_static_range
| Bool
intClosure = forall a b. (Integral a, Num b) => a -> b
fromIntegral (PlatformConstants -> Int
pc_MIN_INTLIKE PlatformConstants
constants)
| Bool
charClosure = forall a b. (Integral a, Num b) => a -> b
fromIntegral (PlatformConstants -> Int
pc_MIN_CHARLIKE PlatformConstants
constants)
| Bool
otherwise = forall a. String -> a
panic String
"precomputedStaticConInfo_maybe: Unknown closure type"
max_static_range :: Integer
max_static_range
| Bool
intClosure = forall a b. (Integral a, Num b) => a -> b
fromIntegral (PlatformConstants -> Int
pc_MAX_INTLIKE PlatformConstants
constants)
| Bool
charClosure = forall a b. (Integral a, Num b) => a -> b
fromIntegral (PlatformConstants -> Int
pc_MAX_CHARLIKE PlatformConstants
constants)
| Bool
otherwise = forall a. String -> a
panic String
"precomputedStaticConInfo_maybe: Unknown closure type"
label :: String
label
| Bool
intClosure = String
"stg_INTLIKE"
| Bool
charClosure = String
"stg_CHARLIKE"
| Bool
otherwise = forall a. String -> a
panic String
"precomputedStaticConInfo_maybe: Unknown closure type"
precomputedStaticConInfo_maybe StgToCmmConfig
_ Id
_ DataCon
_ [NonVoid StgArg]
_ = forall a. Maybe a
Nothing
bindConArgs :: AltCon -> LocalReg -> [NonVoid Id] -> FCode [LocalReg]
bindConArgs :: AltCon -> LocalReg -> [NonVoid Id] -> FCode [LocalReg]
bindConArgs (DataAlt DataCon
con) LocalReg
base [NonVoid Id]
args
= forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (DataCon -> Bool
isUnboxedTupleDataCon DataCon
con)) forall a b. (a -> b) -> a -> b
$
do Profile
profile <- FCode Profile
getProfile
Platform
platform <- FCode Platform
getPlatform
let (Int
_, Int
_, [(NonVoid Id, Int)]
args_w_offsets) = forall a.
Profile -> [NonVoid (PrimRep, a)] -> (Int, Int, [(NonVoid a, Int)])
mkVirtConstrOffsets Profile
profile ([NonVoid Id] -> [NonVoid (PrimRep, Id)]
addIdReps [NonVoid Id]
args)
tag :: Int
tag = Platform -> DataCon -> Int
tagForCon Platform
platform DataCon
con
bind_arg :: (NonVoid Id, ByteOff) -> FCode (Maybe LocalReg)
bind_arg :: (NonVoid Id, Int) -> FCode (Maybe LocalReg)
bind_arg (arg :: NonVoid Id
arg@(NonVoid Id
b), Int
offset)
| Id -> Bool
isDeadBinder Id
b
= forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
| Bool
otherwise
= do { CmmAGraph -> FCode ()
emit forall a b. (a -> b) -> a -> b
$ Platform -> LocalReg -> LocalReg -> Int -> Int -> CmmAGraph
mkTaggedObjectLoad Platform
platform (Platform -> NonVoid Id -> LocalReg
idToReg Platform
platform NonVoid Id
arg)
LocalReg
base Int
offset Int
tag
; forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonVoid Id -> FCode LocalReg
bindArgToReg NonVoid Id
arg }
forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (NonVoid Id, Int) -> FCode (Maybe LocalReg)
bind_arg [(NonVoid Id, Int)]
args_w_offsets
bindConArgs AltCon
_other_con LocalReg
_base [NonVoid Id]
args
= forall a. HasCallStack => Bool -> a -> a
assert (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [NonVoid Id]
args ) forall (m :: * -> *) a. Monad m => a -> m a
return []