{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
module GHC.ByteCode.InfoTable ( mkITbls ) where
import GHC.Prelude
import GHC.Platform
import GHC.Platform.Profile
import GHC.ByteCode.Types
import GHC.Runtime.Interpreter
import GHC.Types.Name ( Name, getName )
import GHC.Types.Name.Env
import GHC.Types.RepType
import GHC.Core.DataCon ( DataCon, dataConRepArgTys, dataConIdentity )
import GHC.Core.TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )
import GHC.Core.Multiplicity ( scaledThing )
import GHC.StgToCmm.Layout ( mkVirtConstrSizes )
import GHC.StgToCmm.Closure ( tagForCon, NonVoid (..) )
import GHC.Utils.Misc
import GHC.Utils.Panic
mkITbls :: Interp -> Profile -> [TyCon] -> IO ItblEnv
mkITbls :: Interp -> Profile -> [TyCon] -> IO ItblEnv
mkITbls Interp
interp Profile
profile [TyCon]
tcs =
(ItblEnv -> ItblEnv -> ItblEnv) -> ItblEnv -> [ItblEnv] -> ItblEnv
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ItblEnv -> ItblEnv -> ItblEnv
forall a. NameEnv a -> NameEnv a -> NameEnv a
plusNameEnv ItblEnv
forall a. NameEnv a
emptyNameEnv ([ItblEnv] -> ItblEnv) -> IO [ItblEnv] -> IO ItblEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
(TyCon -> IO ItblEnv) -> [TyCon] -> IO [ItblEnv]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyCon -> IO ItblEnv
mkITbl ((TyCon -> Bool) -> [TyCon] -> [TyCon]
forall a. (a -> Bool) -> [a] -> [a]
filter TyCon -> Bool
isDataTyCon [TyCon]
tcs)
where
mkITbl :: TyCon -> IO ItblEnv
mkITbl :: TyCon -> IO ItblEnv
mkITbl TyCon
tc
| [DataCon]
dcs [DataCon] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` Int
n
= Interp -> Profile -> [DataCon] -> IO ItblEnv
make_constr_itbls Interp
interp Profile
profile [DataCon]
dcs
where
dcs :: [DataCon]
dcs = TyCon -> [DataCon]
tyConDataCons TyCon
tc
n :: Int
n = TyCon -> Int
tyConFamilySize TyCon
tc
mkITbl TyCon
_ = String -> IO ItblEnv
forall a. String -> a
panic String
"mkITbl"
mkItblEnv :: [(Name,ItblPtr)] -> ItblEnv
mkItblEnv :: [(Name, ItblPtr)] -> ItblEnv
mkItblEnv [(Name, ItblPtr)]
pairs = [(Name, (Name, ItblPtr))] -> ItblEnv
forall a. [(Name, a)] -> NameEnv a
mkNameEnv [(Name
n, (Name
n,ItblPtr
p)) | (Name
n,ItblPtr
p) <- [(Name, ItblPtr)]
pairs]
make_constr_itbls :: Interp -> Profile -> [DataCon] -> IO ItblEnv
make_constr_itbls :: Interp -> Profile -> [DataCon] -> IO ItblEnv
make_constr_itbls Interp
interp Profile
profile [DataCon]
cons =
[(Name, ItblPtr)] -> ItblEnv
mkItblEnv ([(Name, ItblPtr)] -> ItblEnv)
-> IO [(Name, ItblPtr)] -> IO ItblEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((DataCon, Int) -> IO (Name, ItblPtr))
-> [(DataCon, Int)] -> IO [(Name, ItblPtr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((DataCon -> Int -> IO (Name, ItblPtr))
-> (DataCon, Int) -> IO (Name, ItblPtr)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry DataCon -> Int -> IO (Name, ItblPtr)
mk_itbl) ([DataCon] -> [Int] -> [(DataCon, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [DataCon]
cons [Int
0..])
where
mk_itbl :: DataCon -> Int -> IO (Name,ItblPtr)
mk_itbl :: DataCon -> Int -> IO (Name, ItblPtr)
mk_itbl DataCon
dcon Int
conNo = do
let rep_args :: [NonVoid PrimRep]
rep_args = [ PrimRep -> NonVoid PrimRep
forall a. a -> NonVoid a
NonVoid PrimRep
prim_rep
| Scaled Type
arg <- DataCon -> [Scaled Type]
dataConRepArgTys DataCon
dcon
, PrimRep
prim_rep <- HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep (Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
arg) ]
(Int
tot_wds, Int
ptr_wds) =
Profile -> [NonVoid PrimRep] -> (Int, Int)
mkVirtConstrSizes Profile
profile [NonVoid PrimRep]
rep_args
ptrs' :: Int
ptrs' = Int
ptr_wds
nptrs' :: Int
nptrs' = Int
tot_wds Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ptr_wds
nptrs_really :: Int
nptrs_really
| Int
ptrs' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
nptrs' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= PlatformConstants -> Int
pc_MIN_PAYLOAD_SIZE PlatformConstants
constants = Int
nptrs'
| Bool
otherwise = PlatformConstants -> Int
pc_MIN_PAYLOAD_SIZE PlatformConstants
constants Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ptrs'
descr :: ByteString
descr = DataCon -> ByteString
dataConIdentity DataCon
dcon
platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
constants :: PlatformConstants
constants = Platform -> PlatformConstants
platformConstants Platform
platform
tables_next_to_code :: Bool
tables_next_to_code = Platform -> Bool
platformTablesNextToCode Platform
platform
RemotePtr StgInfoTable
r <- Interp
-> Message (RemotePtr StgInfoTable) -> IO (RemotePtr StgInfoTable)
forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (Bool
-> Int
-> Int
-> Int
-> Int
-> ByteString
-> Message (RemotePtr StgInfoTable)
MkConInfoTable Bool
tables_next_to_code Int
ptrs' Int
nptrs_really
Int
conNo (Platform -> DataCon -> Int
tagForCon Platform
platform DataCon
dcon) ByteString
descr)
(Name, ItblPtr) -> IO (Name, ItblPtr)
forall (m :: * -> *) a. Monad m => a -> m a
return (DataCon -> Name
forall a. NamedThing a => a -> Name
getName DataCon
dcon, RemotePtr StgInfoTable -> ItblPtr
ItblPtr RemotePtr StgInfoTable
r)