module GHC.StgToCmm.DataCon (
cgTopRhsCon, buildDynCon, bindConArgs
) where
import GHC.Prelude
import GHC.Platform
import GHC.Stg.Utils (allowTopLevelConApp)
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.Misc
import GHC.Utils.Monad (mapMaybeM)
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 = () -> FCode ()
forall a. a -> FCode a
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 <- FCode Profile
getProfile
; this_mod <- getModuleName
; massert (allowTopLevelConApp platform (stgToCmmExtDynRefs cfg) this_mod con (map fromNonVoid args))
; massert (args `lengthIs` countConRepArgs con )
; checkConArgsStatic (text "TagCheck failed - Top level con") con (map fromNonVoid args)
; let
(tot_wds,
ptr_wds,
nv_args_w_offsets) =
mkVirtHeapOffsetsWithPadding profile StdHeader (addArgReps args)
; let
fix_padding (x :: FieldOffOrPadding a
x@(Padding Int
n Int
off) : [FieldOffOrPadding a]
rest)
| Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = [FieldOffOrPadding a] -> [FieldOffOrPadding a]
fix_padding [FieldOffOrPadding a]
rest
| Int
n Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
1,Int
2,Int
4,Int
8] = FieldOffOrPadding a
x FieldOffOrPadding a
-> [FieldOffOrPadding a] -> [FieldOffOrPadding a]
forall a. a -> [a] -> [a]
: [FieldOffOrPadding a] -> [FieldOffOrPadding a]
fix_padding [FieldOffOrPadding a]
rest
| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
8 = Int -> [FieldOffOrPadding a]
add_pad Int
8
| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
4 = Int -> [FieldOffOrPadding a]
add_pad Int
4
| Int
n Int -> Int -> Bool
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 = Int -> Int -> FieldOffOrPadding a
forall a. Int -> Int -> FieldOffOrPadding a
Padding Int
m Int
off FieldOffOrPadding a
-> [FieldOffOrPadding a] -> [FieldOffOrPadding a]
forall a. a -> [a] -> [a]
: [FieldOffOrPadding a] -> [FieldOffOrPadding a]
fix_padding (Int -> Int -> FieldOffOrPadding a
forall a. Int -> Int -> FieldOffOrPadding a
Padding (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
m) (Int
offInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
m) FieldOffOrPadding a
-> [FieldOffOrPadding a] -> [FieldOffOrPadding a]
forall a. a -> [a] -> [a]
: [FieldOffOrPadding a]
rest)
fix_padding (FieldOffOrPadding a
x : [FieldOffOrPadding a]
rest) = FieldOffOrPadding a
x FieldOffOrPadding a
-> [FieldOffOrPadding a] -> [FieldOffOrPadding a]
forall a. a -> [a] -> [a]
: [FieldOffOrPadding a] -> [FieldOffOrPadding a]
fix_padding [FieldOffOrPadding a]
rest
fix_padding [] = []
mk_payload (Padding Int
len Int
_) = CmmLit -> FCode CmmLit
forall a. a -> FCode a
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
amode <- NonVoid StgArg -> FCode CmmExpr
getArgAmode NonVoid StgArg
arg
case amode of
CmmLit CmmLit
lit -> CmmLit -> FCode CmmLit
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return CmmLit
lit
CmmExpr
_ -> String -> FCode CmmLit
forall a. HasCallStack => String -> a
panic String
"GHC.StgToCmm.DataCon.cgTopRhsCon"
nonptr_wds = Int
tot_wds Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ptr_wds
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
; payload <- mapM mk_payload (fix_padding nv_args_w_offsets)
; emitDataCon closure_label info_tbl dontCareCCS 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 cfg <- FCode StgToCmmConfig
getStgToCmmConfig
case precomputedStaticConInfo_maybe cfg binder con args of
Just CgIdInfo
cgInfo -> (CgIdInfo, FCode CmmAGraph) -> FCode (CgIdInfo, FCode CmmAGraph)
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return (CgIdInfo
cgInfo, CmmAGraph -> FCode CmmAGraph
forall a. a -> FCode a
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 { (id_info, reg) <- Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg)
rhsIdInfo Id
binder LambdaFormInfo
lf_info
; return (id_info, gen_code reg)
}
where
lf_info :: LambdaFormInfo
lf_info = DataCon -> LambdaFormInfo
mkConLFInfo DataCon
con
gen_code :: LocalReg -> FCode CmmAGraph
gen_code LocalReg
reg
= do { modu <- FCode Module
getModuleName
; cfg <- getStgToCmmConfig
; let platform = StgToCmmConfig -> Platform
stgToCmmPlatform StgToCmmConfig
cfg
profile = StgToCmmConfig -> Profile
stgToCmmProfile StgToCmmConfig
cfg
(tot_wds, ptr_wds, args_w_offsets)
= mkVirtConstrOffsets profile (addArgReps args)
nonptr_wds = Int
tot_wds Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ptr_wds
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 | Bool
actually_bound = Id -> Maybe Id
forall a. a -> Maybe a
Just Id
binder
| Bool
otherwise = Maybe Id
forall a. Maybe a
Nothing
; checkConArgsDyn (hang (text "TagCheck failed on constructor application.") 4 $
text "On binder:" <> ppr binder $$ text "Constructor:" <> ppr con) con (map fromNonVoid args)
; hp_plus_n <- allocDynClosure ticky_name info_tbl lf_info
(use_cc platform) (blame_cc platform)
args_w_offsets
; return (mkRhsInit platform reg lf_info hp_plus_n) }
where
use_cc :: Platform -> CmmExpr
use_cc Platform
platform
| CostCentreStack -> Bool
isCurrentCCS CostCentreStack
ccs = Platform -> CmmExpr
cccsExpr Platform
platform
| Bool
otherwise = String -> CmmExpr
forall a. HasCallStack => String -> a
panic String
"buildDynCon: non-current CCS not implemented"
blame_cc :: Platform -> CmmExpr
blame_cc = Platform -> 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
= CgIdInfo -> Maybe CgIdInfo
forall a. a -> Maybe a
Just (CgIdInfo -> Maybe CgIdInfo) -> CgIdInfo -> Maybe CgIdInfo
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 OS -> OS -> Bool
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 FastString
label
val_int :: Int
val_int = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
val :: Int
offsetW :: Int
offsetW = (Int
val_int Int -> Int -> Int
forall a. Num a => a -> a -> a
- Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
min_static_range) Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Profile -> Int
fixedHdrSizeW Profile
profile Int -> Int -> Int
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 CgIdInfo -> Maybe CgIdInfo
forall a. a -> Maybe a
Just (CgIdInfo -> Maybe CgIdInfo) -> CgIdInfo -> Maybe CgIdInfo
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))) = Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
val
getClosurePayload (NonVoid (StgLitArg (LitChar Char
val))) = Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> (Char -> Int) -> Char -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord (Char -> Integer) -> Char -> Integer
forall a b. (a -> b) -> a -> b
$ Char
val)
getClosurePayload NonVoid StgArg
_ = Maybe Integer
forall a. Maybe a
Nothing
inRange :: Integer -> Bool
inRange :: Integer -> Bool
inRange Integer
val
= Integer
val Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
min_static_range Bool -> Bool -> Bool
&& Integer
val Integer -> Integer -> Bool
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 = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PlatformConstants -> Int
pc_MIN_INTLIKE PlatformConstants
constants)
| Bool
charClosure = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PlatformConstants -> Int
pc_MIN_CHARLIKE PlatformConstants
constants)
| Bool
otherwise = String -> Integer
forall a. HasCallStack => String -> a
panic String
"precomputedStaticConInfo_maybe: Unknown closure type"
max_static_range :: Integer
max_static_range
| Bool
intClosure = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PlatformConstants -> Int
pc_MAX_INTLIKE PlatformConstants
constants)
| Bool
charClosure = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PlatformConstants -> Int
pc_MAX_CHARLIKE PlatformConstants
constants)
| Bool
otherwise = String -> Integer
forall a. HasCallStack => String -> a
panic String
"precomputedStaticConInfo_maybe: Unknown closure type"
label :: FastString
label
| Bool
intClosure = String -> FastString
fsLit String
"stg_INTLIKE"
| Bool
charClosure = String -> FastString
fsLit String
"stg_CHARLIKE"
| Bool
otherwise = String -> FastString
forall a. HasCallStack => String -> a
panic String
"precomputedStaticConInfo_maybe: Unknown closure type"
precomputedStaticConInfo_maybe StgToCmmConfig
_ Id
_ DataCon
_ [NonVoid StgArg]
_ = Maybe CgIdInfo
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
= Bool -> FCode [LocalReg] -> FCode [LocalReg]
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (DataCon -> Bool
isUnboxedTupleDataCon DataCon
con)) (FCode [LocalReg] -> FCode [LocalReg])
-> FCode [LocalReg] -> FCode [LocalReg]
forall a b. (a -> b) -> a -> b
$
do profile <- FCode Profile
getProfile
platform <- getPlatform
let (_, _, args_w_offsets) = mkVirtConstrOffsets profile (addIdReps args)
tag = Platform -> DataCon -> Int
tagForCon Platform
platform DataCon
con
bind_arg :: (NonVoid Id, ByteOff) -> FCode (Maybe LocalReg)
bind_arg (arg :: NonVoid Id
arg@(NonVoid Id
b), Int
offset)
| Id -> Bool
isDeadBinder Id
b
= Maybe LocalReg -> FCode (Maybe LocalReg)
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe LocalReg
forall a. Maybe a
Nothing
| Bool
otherwise
= do { CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> CmmAGraph -> FCode ()
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
; LocalReg -> Maybe LocalReg
forall a. a -> Maybe a
Just (LocalReg -> Maybe LocalReg)
-> FCode LocalReg -> FCode (Maybe LocalReg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonVoid Id -> FCode LocalReg
bindArgToReg NonVoid Id
arg }
mapMaybeM bind_arg args_w_offsets
bindConArgs AltCon
_other_con LocalReg
_base [NonVoid Id]
args
= Bool
-> ([LocalReg] -> FCode [LocalReg])
-> [LocalReg]
-> FCode [LocalReg]
forall a. HasCallStack => Bool -> a -> a
assert ([NonVoid Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [NonVoid Id]
args ) [LocalReg] -> FCode [LocalReg]
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return []