{-# LANGUAGE CPP #-}
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 :: DynFlags
-> Id
-> DataCon
-> ConstructorNumber
-> [NonVoid StgArg]
-> (CgIdInfo, FCode ())
cgTopRhsCon DynFlags
dflags Id
id DataCon
con ConstructorNumber
mn [NonVoid StgArg]
args
| Just CgIdInfo
static_info <- DynFlags -> Id -> DataCon -> [NonVoid StgArg] -> Maybe CgIdInfo
precomputedStaticConInfo_maybe DynFlags
dflags 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 = DynFlags -> Platform
targetPlatform DynFlags
dflags
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
$
MASSERT( not (isDllConApp dflags this_mod con (map fromNonVoid args)) )
; ASSERT( args `lengthIs` countConRepArgs con ) return ()
; 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 DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
DynFlags
-> Id
-> ConstructorNumber
-> Bool
-> CostCentreStack
-> DataCon
-> [NonVoid StgArg]
-> FCode (CgIdInfo, FCode CmmAGraph)
buildDynCon' DynFlags
dflags Id
binder ConstructorNumber
mn Bool
actually_bound CostCentreStack
cc DataCon
con [NonVoid StgArg]
args
buildDynCon' :: DynFlags
-> Id -> ConstructorNumber
-> Bool
-> CostCentreStack
-> DataCon
-> [NonVoid StgArg]
-> FCode (CgIdInfo, FCode CmmAGraph)
buildDynCon' :: DynFlags
-> Id
-> ConstructorNumber
-> Bool
-> CostCentreStack
-> DataCon
-> [NonVoid StgArg]
-> FCode (CgIdInfo, FCode CmmAGraph)
buildDynCon' DynFlags
dflags Id
binder ConstructorNumber
_ Bool
_ CostCentreStack
_cc DataCon
con [NonVoid StgArg]
args
| Just CgIdInfo
cgInfo <- DynFlags -> Id -> DataCon -> [NonVoid StgArg] -> Maybe CgIdInfo
precomputedStaticConInfo_maybe DynFlags
dflags Id
binder DataCon
con [NonVoid StgArg]
args
= forall (m :: * -> *) a. Monad m => a -> m a
return (CgIdInfo
cgInfo, forall (m :: * -> *) a. Monad m => a -> m a
return CmmAGraph
mkNop)
buildDynCon' DynFlags
_ 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
; Profile
profile <- FCode Profile
getProfile
; let platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
(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
; 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 :: DynFlags -> Id -> DataCon -> [NonVoid StgArg] -> Maybe CgIdInfo
precomputedStaticConInfo_maybe :: DynFlags -> Id -> DataCon -> [NonVoid StgArg] -> Maybe CgIdInfo
precomputedStaticConInfo_maybe DynFlags
dflags 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 (DynFlags -> Platform
targetPlatform DynFlags
dflags) Id
binder (DataCon -> LambdaFormInfo
mkConLFInfo DataCon
con)
(CLabel -> CmmLit
CmmLabel (Name -> CafInfo -> CLabel
mkClosureLabel (DataCon -> Name
dataConName DataCon
con) CafInfo
NoCafRefs))
precomputedStaticConInfo_maybe DynFlags
dflags 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 (DynFlags -> Bool
positionIndependent DynFlags
dflags)
, 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 = DynFlags -> Profile
targetProfile DynFlags
dflags
platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
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. (a -> b) -> a -> b
$ (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 DynFlags
_ 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
= ASSERT(not (isUnboxedTupleDataCon con))
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
= ASSERT( null args ) return []