import Name ( Name, getName )
import NameEnv
import SMRep ( typeCgRep )
-import DataCon ( DataCon, dataConRepArgTys )
+import DataCon ( DataCon, dataConRepArgTys, dataConIdentity )
import TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )
import Constants ( mIN_PAYLOAD_SIZE, wORD_SIZE )
import CgHeapery ( mkVirtHeapOffsets )
import Foreign
import Foreign.C
+import Foreign.C.String
import Data.Bits ( Bits(..), shiftR )
import GHC.Exts ( Int(I#), addr2Int# )
import GHC.Ptr ( Ptr(..) )
+import GHC.Prim
+
+import Outputable
\end{code}
%************************************************************************
itblCode (ItblPtr ptr)
= (castPtr ptr)
#ifdef GHCI_TABLES_NEXT_TO_CODE
- `plusPtr` (wORD_SIZE * 2)
+ `plusPtr` (3 * wORD_SIZE)
#endif
type ItblEnv = NameEnv (Name, ItblPtr)
= mk_itbl dcon conNo stg_interp_constr_entry
mk_itbl :: DataCon -> Int -> Ptr () -> IO (Name,ItblPtr)
- mk_itbl dcon conNo entry_addr
- = let rep_args = [ (typeCgRep arg,arg)
- | arg <- dataConRepArgTys dcon ]
- (tot_wds, ptr_wds, _) = mkVirtHeapOffsets False{-not a THUNK-} rep_args
-
- ptrs = ptr_wds
- nptrs = tot_wds - ptr_wds
- nptrs_really
- | ptrs + nptrs >= mIN_PAYLOAD_SIZE = nptrs
- | otherwise = mIN_PAYLOAD_SIZE - ptrs
- itbl = StgInfoTable {
+ mk_itbl dcon conNo entry_addr = do
+ let rep_args = [ (typeCgRep arg,arg) | arg <- dataConRepArgTys dcon ]
+ (tot_wds, ptr_wds, _) = mkVirtHeapOffsets False{-not a THUNK-} rep_args
+
+ ptrs = ptr_wds
+ nptrs = tot_wds - ptr_wds
+ nptrs_really
+ | ptrs + nptrs >= mIN_PAYLOAD_SIZE = nptrs
+ | otherwise = mIN_PAYLOAD_SIZE - ptrs
+ code = mkJumpToAddr entry_addr
+ itbl = StgInfoTable {
#ifndef GHCI_TABLES_NEXT_TO_CODE
entry = entry_addr,
#endif
, code = code
#endif
}
- -- Make a piece of code to jump to "entry_label".
- -- This is the only arch-dependent bit.
- code = mkJumpToAddr entry_addr
- in
- do addr <- newExec [itbl]
+ qNameCString <- newCString $ dataConIdentity dcon
+ let conInfoTbl = StgConInfoTable {
+ conDesc = qNameCString,
+ infoTable = itbl
+ }
+ -- Make a piece of code to jump to "entry_label".
+ -- This is the only arch-dependent bit.
+ addrCon <- newExec [conInfoTbl]
--putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl))
--putStrLn ("# ptrs of itbl is " ++ show ptrs)
--putStrLn ("# nptrs of itbl is " ++ show nptrs_really)
- return (getName dcon, ItblPtr (castFunPtrToPtr addr))
+ return (getName dcon, ItblPtr (castFunPtrToPtr addrCon))
-- Make code which causes a jump to the given address. This is the
type HalfWord = Word16
#endif
+data StgConInfoTable = StgConInfoTable {
+ conDesc :: CString,
+ infoTable :: StgInfoTable
+}
+
+instance Storable StgConInfoTable where
+ sizeOf conInfoTable
+ = sum [ sizeOf (conDesc conInfoTable)
+ , sizeOf (infoTable conInfoTable) ]
+ alignment conInfoTable = SIZEOF_VOID_P
+ peek ptr
+ = runState (castPtr ptr) $ do
+ desc <- load
+ itbl <- load
+ return
+ StgConInfoTable
+ { conDesc = desc
+ , infoTable = itbl
+ }
+ poke ptr itbl
+ = runState (castPtr ptr) $ do
+ store (conDesc itbl)
+ store (infoTable itbl)
+
data StgInfoTable = StgInfoTable {
#ifndef GHCI_TABLES_NEXT_TO_CODE
entry :: Ptr (),