{-# LANGUAGE CPP #-}
module GHC.StgToCmm.DataCon (
cgTopRhsCon, buildDynCon, bindConArgs
) where
#include "HsVersions.h"
import GhcPrelude
import StgSyn
import CoreSyn ( 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 CmmExpr
import CmmUtils
import CLabel
import MkGraph
import SMRep
import CostCentre
import Module
import DataCon
import DynFlags
import FastString
import Id
import RepType (countConRepArgs)
import Literal
import PrelInfo
import Outputable
import GHC.Platform
import Util
import MonadUtils (mapMaybeM)
import Control.Monad
import Data.Char
cgTopRhsCon :: DynFlags
-> Id
-> DataCon
-> [NonVoid StgArg]
-> (CgIdInfo, FCode ())
cgTopRhsCon :: DynFlags
-> Id -> DataCon -> [NonVoid StgArg] -> (CgIdInfo, FCode ())
cgTopRhsCon DynFlags
dflags Id
id DataCon
con [NonVoid StgArg]
args =
let id_info :: CgIdInfo
id_info = DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
litIdInfo DynFlags
dflags Id
id (DataCon -> LambdaFormInfo
mkConLFInfo DataCon
con) (CLabel -> CmmLit
CmmLabel CLabel
closure_label)
in (CgIdInfo
id_info, FCode ()
gen_code)
where
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 { Module
this_mod <- FCode Module
getModuleName
; Bool -> FCode () -> FCode ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Platform -> OS
platformOS (DynFlags -> Platform
targetPlatform DynFlags
dflags) OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSMinGW32) (FCode () -> FCode ()) -> FCode () -> FCode ()
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) =
DynFlags
-> ClosureHeader
-> [NonVoid (PrimRep, StgArg)]
-> (Int, Int, [FieldOffOrPadding StgArg])
forall a.
DynFlags
-> ClosureHeader
-> [NonVoid (PrimRep, a)]
-> (Int, Int, [FieldOffOrPadding a])
mkVirtHeapOffsetsWithPadding DynFlags
dflags ClosureHeader
StdHeader ([NonVoid StgArg] -> [NonVoid (PrimRep, StgArg)]
addArgReps [NonVoid StgArg]
args)
mk_payload :: FieldOffOrPadding StgArg -> FCode CmmLit
mk_payload (Padding Int
len Int
_) = CmmLit -> FCode CmmLit
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 -> CmmLit -> FCode CmmLit
forall (m :: * -> *) a. Monad m => a -> m a
return CmmLit
lit
CmmExpr
_ -> String -> FCode CmmLit
forall a. String -> a
panic String
"GHC.StgToCmm.DataCon.cgTopRhsCon"
nonptr_wds :: Int
nonptr_wds = Int
tot_wds Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ptr_wds
info_tbl :: CmmInfoTable
info_tbl = DynFlags -> DataCon -> Bool -> Int -> Int -> CmmInfoTable
mkDataConInfoTable DynFlags
dflags DataCon
con Bool
True Int
ptr_wds Int
nonptr_wds
; [CmmLit]
payload <- (FieldOffOrPadding StgArg -> FCode CmmLit)
-> [FieldOffOrPadding StgArg] -> FCode [CmmLit]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FieldOffOrPadding StgArg -> FCode CmmLit
mk_payload [FieldOffOrPadding StgArg]
nv_args_w_offsets
; let closure_rep :: [CmmLit]
closure_rep = DynFlags
-> CmmInfoTable
-> CostCentreStack
-> CafInfo
-> [CmmLit]
-> [CmmLit]
mkStaticClosureFields
DynFlags
dflags
CmmInfoTable
info_tbl
CostCentreStack
dontCareCCS
CafInfo
caffy
[CmmLit]
payload
; CLabel -> [CmmLit] -> FCode ()
emitDataLits CLabel
closure_label [CmmLit]
closure_rep
; () -> FCode ()
forall (m :: * -> *) a. Monad m => a -> m a
return () }
buildDynCon :: Id
-> Bool
-> CostCentreStack
-> DataCon
-> [NonVoid StgArg]
-> FCode (CgIdInfo, FCode CmmAGraph)
buildDynCon :: Id
-> Bool
-> CostCentreStack
-> DataCon
-> [NonVoid StgArg]
-> FCode (CgIdInfo, FCode CmmAGraph)
buildDynCon Id
binder Bool
actually_bound CostCentreStack
cc DataCon
con [NonVoid StgArg]
args
= do DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
DynFlags
-> Platform
-> Id
-> Bool
-> CostCentreStack
-> DataCon
-> [NonVoid StgArg]
-> FCode (CgIdInfo, FCode CmmAGraph)
buildDynCon' DynFlags
dflags (DynFlags -> Platform
targetPlatform DynFlags
dflags) Id
binder Bool
actually_bound CostCentreStack
cc DataCon
con [NonVoid StgArg]
args
buildDynCon' :: DynFlags
-> Platform
-> Id -> Bool
-> CostCentreStack
-> DataCon
-> [NonVoid StgArg]
-> FCode (CgIdInfo, FCode CmmAGraph)
buildDynCon' :: DynFlags
-> Platform
-> Id
-> Bool
-> CostCentreStack
-> DataCon
-> [NonVoid StgArg]
-> FCode (CgIdInfo, FCode CmmAGraph)
buildDynCon' DynFlags
dflags Platform
_ Id
binder Bool
_ CostCentreStack
_cc DataCon
con []
| DataCon -> Bool
isNullaryRepDataCon DataCon
con
= (CgIdInfo, FCode CmmAGraph) -> FCode (CgIdInfo, FCode CmmAGraph)
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
litIdInfo DynFlags
dflags Id
binder (DataCon -> LambdaFormInfo
mkConLFInfo DataCon
con)
(CLabel -> CmmLit
CmmLabel (Name -> CafInfo -> CLabel
mkClosureLabel (DataCon -> Name
dataConName DataCon
con) (Id -> CafInfo
idCafInfo Id
binder))),
CmmAGraph -> FCode CmmAGraph
forall (m :: * -> *) a. Monad m => a -> m a
return CmmAGraph
mkNop)
buildDynCon' DynFlags
dflags Platform
platform Id
binder Bool
_ CostCentreStack
_cc DataCon
con [NonVoid StgArg
arg]
| DataCon -> Bool
maybeIntLikeCon DataCon
con
, Platform -> OS
platformOS Platform
platform OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
/= OS
OSMinGW32 Bool -> Bool -> Bool
|| Bool -> Bool
not (DynFlags -> Bool
positionIndependent DynFlags
dflags)
, NonVoid (StgLitArg (LitNumber LitNumType
LitNumInt Integer
val Type
_)) <- NonVoid StgArg
arg
, Integer
val Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (DynFlags -> Int
mAX_INTLIKE DynFlags
dflags)
, Integer
val Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (DynFlags -> Int
mIN_INTLIKE DynFlags
dflags)
= do { let intlike_lbl :: CLabel
intlike_lbl = UnitId -> FastString -> CLabel
mkCmmClosureLabel UnitId
rtsUnitId (String -> FastString
fsLit String
"stg_INTLIKE")
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
- DynFlags -> Int
mIN_INTLIKE DynFlags
dflags) Int -> Int -> Int
forall a. Num a => a -> a -> a
* (DynFlags -> Int
fixedHdrSizeW DynFlags
dflags Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
intlike_amode :: CmmLit
intlike_amode = DynFlags -> CLabel -> Int -> CmmLit
cmmLabelOffW DynFlags
dflags CLabel
intlike_lbl Int
offsetW
; (CgIdInfo, FCode CmmAGraph) -> FCode (CgIdInfo, FCode CmmAGraph)
forall (m :: * -> *) a. Monad m => a -> m a
return ( DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
litIdInfo DynFlags
dflags Id
binder (DataCon -> LambdaFormInfo
mkConLFInfo DataCon
con) CmmLit
intlike_amode
, CmmAGraph -> FCode CmmAGraph
forall (m :: * -> *) a. Monad m => a -> m a
return CmmAGraph
mkNop) }
buildDynCon' DynFlags
dflags Platform
platform Id
binder Bool
_ CostCentreStack
_cc DataCon
con [NonVoid StgArg
arg]
| DataCon -> Bool
maybeCharLikeCon DataCon
con
, Platform -> OS
platformOS Platform
platform OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
/= OS
OSMinGW32 Bool -> Bool -> Bool
|| Bool -> Bool
not (DynFlags -> Bool
positionIndependent DynFlags
dflags)
, NonVoid (StgLitArg (LitChar Char
val)) <- NonVoid StgArg
arg
, let val_int :: Int
val_int = Char -> Int
ord Char
val :: Int
, Int
val_int Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= DynFlags -> Int
mAX_CHARLIKE DynFlags
dflags
, Int
val_int Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= DynFlags -> Int
mIN_CHARLIKE DynFlags
dflags
= do { let charlike_lbl :: CLabel
charlike_lbl = UnitId -> FastString -> CLabel
mkCmmClosureLabel UnitId
rtsUnitId (String -> FastString
fsLit String
"stg_CHARLIKE")
offsetW :: Int
offsetW = (Int
val_int Int -> Int -> Int
forall a. Num a => a -> a -> a
- DynFlags -> Int
mIN_CHARLIKE DynFlags
dflags) Int -> Int -> Int
forall a. Num a => a -> a -> a
* (DynFlags -> Int
fixedHdrSizeW DynFlags
dflags Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
charlike_amode :: CmmLit
charlike_amode = DynFlags -> CLabel -> Int -> CmmLit
cmmLabelOffW DynFlags
dflags CLabel
charlike_lbl Int
offsetW
; (CgIdInfo, FCode CmmAGraph) -> FCode (CgIdInfo, FCode CmmAGraph)
forall (m :: * -> *) a. Monad m => a -> m a
return ( DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
litIdInfo DynFlags
dflags Id
binder (DataCon -> LambdaFormInfo
mkConLFInfo DataCon
con) CmmLit
charlike_amode
, CmmAGraph -> FCode CmmAGraph
forall (m :: * -> *) a. Monad m => a -> m a
return CmmAGraph
mkNop) }
buildDynCon' DynFlags
dflags Platform
_ Id
binder 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
; (CgIdInfo, FCode CmmAGraph) -> FCode (CgIdInfo, FCode CmmAGraph)
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 { let (Int
tot_wds, Int
ptr_wds, [(NonVoid StgArg, Int)]
args_w_offsets)
= DynFlags
-> [NonVoid (PrimRep, StgArg)]
-> (Int, Int, [(NonVoid StgArg, Int)])
forall a.
DynFlags
-> [NonVoid (PrimRep, a)] -> (Int, Int, [(NonVoid a, Int)])
mkVirtConstrOffsets DynFlags
dflags ([NonVoid StgArg] -> [NonVoid (PrimRep, StgArg)]
addArgReps [NonVoid StgArg]
args)
nonptr_wds :: Int
nonptr_wds = Int
tot_wds Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ptr_wds
info_tbl :: CmmInfoTable
info_tbl = DynFlags -> DataCon -> Bool -> Int -> Int -> CmmInfoTable
mkDataConInfoTable DynFlags
dflags DataCon
con Bool
False
Int
ptr_wds Int
nonptr_wds
; let ticky_name :: Maybe Id
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
; 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
; CmmAGraph -> FCode CmmAGraph
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph
mkRhsInit DynFlags
dflags LocalReg
reg LambdaFormInfo
lf_info CmmExpr
hp_plus_n) }
where
use_cc :: CmmExpr
use_cc
| CostCentreStack -> Bool
isCurrentCCS CostCentreStack
ccs = CmmExpr
cccsExpr
| Bool
otherwise = String -> CmmExpr
forall a. String -> a
panic String
"buildDynCon: non-current CCS not implemented"
blame_cc :: CmmExpr
blame_cc = CmmExpr
use_cc
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 (isUnboxedTupleCon con))
do DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let (Int
_, Int
_, [(NonVoid Id, Int)]
args_w_offsets) = DynFlags
-> [NonVoid (PrimRep, Id)] -> (Int, Int, [(NonVoid Id, Int)])
forall a.
DynFlags
-> [NonVoid (PrimRep, a)] -> (Int, Int, [(NonVoid a, Int)])
mkVirtConstrOffsets DynFlags
dflags ([NonVoid Id] -> [NonVoid (PrimRep, Id)]
addIdReps [NonVoid Id]
args)
tag :: Int
tag = DynFlags -> DataCon -> Int
tagForCon DynFlags
dflags 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
= Maybe LocalReg -> FCode (Maybe LocalReg)
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
$ DynFlags -> LocalReg -> LocalReg -> Int -> Int -> CmmAGraph
mkTaggedObjectLoad DynFlags
dflags (DynFlags -> NonVoid Id -> LocalReg
idToReg DynFlags
dflags 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 }
((NonVoid Id, Int) -> FCode (Maybe LocalReg))
-> [(NonVoid Id, Int)] -> FCode [LocalReg]
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 []