module GHC.StgToCmm.DataCon (
cgTopRhsCon, buildDynCon, bindConArgs
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Platform
import GHC.Platform.Profile
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.Driver.Session
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 Control.Monad
import Data.Char
cgTopRhsCon :: DynFlags
-> Id
-> DataCon
-> ConstructorNumber
-> [NonVoid StgArg]
-> (CgIdInfo, FCode ())
cgTopRhsCon dflags id con mn args
| Just static_info <- precomputedStaticConInfo_maybe dflags id con args
, let static_code | isInternalName name = pure ()
| otherwise = gen_code
=
(static_info, static_code)
| otherwise
= (id_Info, gen_code)
where
platform = targetPlatform dflags
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 dflags this_mod con (map fromNonVoid args)) )
; ASSERT( args `lengthIs` countConRepArgs con ) return ()
; 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 dflags <- getDynFlags
buildDynCon' dflags binder mn actually_bound cc con args
buildDynCon' :: DynFlags
-> Id -> ConstructorNumber
-> Bool
-> CostCentreStack
-> DataCon
-> [NonVoid StgArg]
-> FCode (CgIdInfo, FCode CmmAGraph)
buildDynCon' dflags binder _ _ _cc con args
| Just cgInfo <- precomputedStaticConInfo_maybe dflags binder con args
= return (cgInfo, return mkNop)
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
; profile <- getProfile
; let platform = profilePlatform profile
(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
; 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 :: DynFlags -> Id -> DataCon -> [NonVoid StgArg] -> Maybe CgIdInfo
precomputedStaticConInfo_maybe dflags binder con []
| isNullaryRepDataCon con
= Just $ litIdInfo (targetPlatform dflags) binder (mkConLFInfo con)
(CmmLabel (mkClosureLabel (dataConName con) NoCafRefs))
precomputedStaticConInfo_maybe dflags binder con [arg]
| intClosure || charClosure
, platformOS platform /= OSMinGW32 || not (positionIndependent dflags)
, 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 = targetProfile dflags
platform = profilePlatform profile
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 []