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 cfg id con mn args
| Just static_info <- precomputedStaticConInfo_maybe cfg id con args
, let static_code | isInternalName name = pure ()
| otherwise = gen_code
=
(static_info, static_code)
| otherwise
= (id_Info, gen_code)
where
platform = stgToCmmPlatform cfg
id_Info = litIdInfo platform id (mkConLFInfo con) (CmmLabel closure_label)
name = idName id
caffy = idCafInfo id
closure_label = mkClosureLabel name caffy
gen_code =
do { profile <- getProfile
; this_mod <- getModuleName
; when (platformOS platform == OSMinGW32) $
massert (not (isDllConApp platform (stgToCmmExtDynRefs cfg) this_mod con (map fromNonVoid args)))
; assert (args `lengthIs` countConRepArgs con ) return ()
; 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@(Padding n off) : rest)
| n == 0 = fix_padding rest
| n `elem` [1,2,4,8] = x : fix_padding rest
| n > 8 = add_pad 8
| n > 4 = add_pad 4
| n > 2 = add_pad 2
| otherwise = add_pad 1
where add_pad m = Padding m off : fix_padding (Padding (nm) (off+m) : rest)
fix_padding (x : rest) = x : fix_padding rest
fix_padding [] = []
mk_payload (Padding len _) = return (CmmInt 0 (widthFromBytes len))
mk_payload (FieldOff arg _) = do
amode <- getArgAmode arg
case amode of
CmmLit lit -> return lit
_ -> panic "GHC.StgToCmm.DataCon.cgTopRhsCon"
nonptr_wds = tot_wds ptr_wds
info_tbl = mkDataConInfoTable profile con (addModuleLoc this_mod mn) True ptr_wds nonptr_wds
; payload <- mapM mk_payload (fix_padding nv_args_w_offsets)
; emitDataCon closure_label info_tbl dontCareCCS payload }
addModuleLoc :: Module -> ConstructorNumber -> ConInfoTableLocation
addModuleLoc this_mod mn = do
case mn of
NoNumber -> DefinitionSite
Numbered n -> UsageSite this_mod n
buildDynCon :: Id
-> ConstructorNumber
-> Bool
-> CostCentreStack
-> DataCon
-> [NonVoid StgArg]
-> FCode (CgIdInfo, FCode CmmAGraph)
buildDynCon binder mn actually_bound cc con args
= do cfg <- getStgToCmmConfig
case precomputedStaticConInfo_maybe cfg binder con args of
Just cgInfo -> return (cgInfo, return mkNop)
Nothing -> buildDynCon' binder mn actually_bound cc con args
buildDynCon' :: Id
-> ConstructorNumber
-> Bool
-> CostCentreStack
-> DataCon
-> [NonVoid StgArg]
-> FCode (CgIdInfo, FCode CmmAGraph)
buildDynCon' binder mn actually_bound ccs con args
= do { (id_info, reg) <- rhsIdInfo binder lf_info
; return (id_info, gen_code reg)
}
where
lf_info = mkConLFInfo con
gen_code reg
= do { modu <- getModuleName
; cfg <- getStgToCmmConfig
; let platform = stgToCmmPlatform cfg
profile = stgToCmmProfile cfg
(tot_wds, ptr_wds, args_w_offsets)
= mkVirtConstrOffsets profile (addArgReps args)
nonptr_wds = tot_wds ptr_wds
info_tbl = mkDataConInfoTable profile con (addModuleLoc modu mn) False
ptr_wds nonptr_wds
; let ticky_name | actually_bound = Just binder
| otherwise = 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 blame_cc args_w_offsets
; return (mkRhsInit platform reg lf_info hp_plus_n) }
where
use_cc
| isCurrentCCS ccs = cccsExpr
| otherwise = panic "buildDynCon: non-current CCS not implemented"
blame_cc = use_cc
precomputedStaticConInfo_maybe :: StgToCmmConfig -> Id -> DataCon -> [NonVoid StgArg] -> Maybe CgIdInfo
precomputedStaticConInfo_maybe cfg binder con []
| isNullaryRepDataCon con
= Just $ litIdInfo (stgToCmmPlatform cfg) binder (mkConLFInfo con)
(CmmLabel (mkClosureLabel (dataConName con) NoCafRefs))
precomputedStaticConInfo_maybe cfg binder con [arg]
| intClosure || charClosure
, platformOS platform /= OSMinGW32 || not (stgToCmmPIE cfg || stgToCmmPIC cfg)
, Just val <- getClosurePayload arg
, inRange val
= let intlike_lbl = mkCmmClosureLabel rtsUnitId (fsLit label)
val_int = fromIntegral val :: Int
offsetW = (val_int fromIntegral min_static_range) * (fixedHdrSizeW profile + 1)
static_amode = cmmLabelOffW platform intlike_lbl offsetW
in Just $ litIdInfo platform binder (mkConLFInfo con) static_amode
where
profile = stgToCmmProfile cfg
platform = stgToCmmPlatform cfg
intClosure = maybeIntLikeCon con
charClosure = maybeCharLikeCon con
getClosurePayload (NonVoid (StgLitArg (LitNumber LitNumInt val))) = Just val
getClosurePayload (NonVoid (StgLitArg (LitChar val))) = Just (fromIntegral . ord $ val)
getClosurePayload _ = Nothing
inRange :: Integer -> Bool
inRange val
= val >= min_static_range && val <= max_static_range
constants = platformConstants platform
min_static_range :: Integer
min_static_range
| intClosure = fromIntegral (pc_MIN_INTLIKE constants)
| charClosure = fromIntegral (pc_MIN_CHARLIKE constants)
| otherwise = panic "precomputedStaticConInfo_maybe: Unknown closure type"
max_static_range
| intClosure = fromIntegral (pc_MAX_INTLIKE constants)
| charClosure = fromIntegral (pc_MAX_CHARLIKE constants)
| otherwise = panic "precomputedStaticConInfo_maybe: Unknown closure type"
label
| intClosure = "stg_INTLIKE"
| charClosure = "stg_CHARLIKE"
| otherwise = panic "precomputedStaticConInfo_maybe: Unknown closure type"
precomputedStaticConInfo_maybe _ _ _ _ = Nothing
bindConArgs :: AltCon -> LocalReg -> [NonVoid Id] -> FCode [LocalReg]
bindConArgs (DataAlt con) base args
= assert (not (isUnboxedTupleDataCon con)) $
do profile <- getProfile
platform <- getPlatform
let (_, _, args_w_offsets) = mkVirtConstrOffsets profile (addIdReps args)
tag = tagForCon platform con
bind_arg :: (NonVoid Id, ByteOff) -> FCode (Maybe LocalReg)
bind_arg (arg@(NonVoid b), offset)
| isDeadBinder b
= return Nothing
| otherwise
= do { emit $ mkTaggedObjectLoad platform (idToReg platform arg)
base offset tag
; Just <$> bindArgToReg arg }
mapMaybeM bind_arg args_w_offsets
bindConArgs _other_con _base args
= assert (null args ) return []