\begin{code}
{-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
-module ByteCodeItbls ( ItblEnv, ItblPtr, mkITbls ) where
+{-# OPTIONS_GHC -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
+-- for details
+
+module ByteCodeItbls ( ItblEnv, ItblPtr(..), itblCode, mkITbls
+ , StgInfoTable(..)
+ ) where
#include "HsVersions.h"
+import ByteCodeFFI ( newExec )
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 FastString ( FastString(..) )
import Util ( lengthIs, listLengthCmp )
+import Outputable
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 Debug.Trace
+import Text.Printf
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-type ItblPtr = Ptr StgInfoTable
+newtype ItblPtr = ItblPtr (Ptr ()) deriving Show
+
+itblCode :: ItblPtr -> Ptr ()
+itblCode (ItblPtr ptr)
+ = (castPtr ptr)
+#ifdef GHCI_TABLES_NEXT_TO_CODE
+ `plusPtr` conInfoTableSizeB
+#endif
+
+-- XXX bogus
+conInfoTableSizeB = 3 * wORD_SIZE
+
type ItblEnv = NameEnv (Name, ItblPtr)
-- We need the Name in the range so we know which
-- elements to filter out when unloading a module
-- Assumes constructors are numbered from zero, not one
make_constr_itbls :: [DataCon] -> IO ItblEnv
make_constr_itbls cons
- | listLengthCmp cons 8 /= GT -- <= 8 elements in the list
- = do is <- mapM mk_vecret_itbl (zip cons [0..])
- return (mkItblEnv is)
- | otherwise
= do is <- mapM mk_dirret_itbl (zip cons [0..])
return (mkItblEnv is)
where
- mk_vecret_itbl (dcon, conNo)
- = mk_itbl dcon conNo (vecret_entry conNo)
mk_dirret_itbl (dcon, conNo)
= 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 {
-#ifndef TABLES_NEXT_TO_CODE
+ 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
ptrs = fromIntegral ptrs,
nptrs = fromIntegral nptrs_really,
tipe = fromIntegral cONSTR,
srtlen = fromIntegral conNo
-#ifdef TABLES_NEXT_TO_CODE
+#ifdef GHCI_TABLES_NEXT_TO_CODE
, 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 <- malloc_exec (sizeOf itbl)
+ qNameCString <- newArray0 0 $ 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)
- poke addr itbl
- return (getName dcon, addr
-#ifdef TABLES_NEXT_TO_CODE
- `plusPtr` (2 * wORD_SIZE)
-#endif
- )
+ return (getName dcon, ItblPtr (castFunPtrToPtr addrCon))
-- Make code which causes a jump to the given address. This is the
byte7 w = fromIntegral (w `shiftR` 56)
-vecret_entry 0 = stg_interp_constr1_entry
-vecret_entry 1 = stg_interp_constr2_entry
-vecret_entry 2 = stg_interp_constr3_entry
-vecret_entry 3 = stg_interp_constr4_entry
-vecret_entry 4 = stg_interp_constr5_entry
-vecret_entry 5 = stg_interp_constr6_entry
-vecret_entry 6 = stg_interp_constr7_entry
-vecret_entry 7 = stg_interp_constr8_entry
-
#ifndef __HADDOCK__
-- entry point for direct returns for created constr itbls
foreign import ccall "&stg_interp_constr_entry" stg_interp_constr_entry :: Ptr ()
--- and the 8 vectored ones
-foreign import ccall "&stg_interp_constr1_entry" stg_interp_constr1_entry :: Ptr ()
-foreign import ccall "&stg_interp_constr2_entry" stg_interp_constr2_entry :: Ptr ()
-foreign import ccall "&stg_interp_constr3_entry" stg_interp_constr3_entry :: Ptr ()
-foreign import ccall "&stg_interp_constr4_entry" stg_interp_constr4_entry :: Ptr ()
-foreign import ccall "&stg_interp_constr5_entry" stg_interp_constr5_entry :: Ptr ()
-foreign import ccall "&stg_interp_constr6_entry" stg_interp_constr6_entry :: Ptr ()
-foreign import ccall "&stg_interp_constr7_entry" stg_interp_constr7_entry :: Ptr ()
-foreign import ccall "&stg_interp_constr8_entry" stg_interp_constr8_entry :: Ptr ()
#endif
type HalfWord = Word16
#endif
+data StgConInfoTable = StgConInfoTable {
+ conDesc :: Ptr Word8,
+ 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
+#ifdef GHCI_TABLES_NEXT_TO_CODE
+ desc <- load
+#endif
+ itbl <- load
+#ifndef GHCI_TABLES_NEXT_TO_CODE
+ desc <- load
+#endif
+ return
+ StgConInfoTable
+ {
+#ifdef GHCI_TABLES_NEXT_TO_CODE
+ conDesc = castPtr $ ptr `plusPtr` conInfoTableSizeB `plusPtr` desc
+#else
+ conDesc = desc
+#endif
+ , infoTable = itbl
+ }
+ poke ptr itbl
+ = runState (castPtr ptr) $ do
+#ifdef GHCI_TABLES_NEXT_TO_CODE
+ store (conDesc itbl `minusPtr` (ptr `plusPtr` conInfoTableSizeB))
+#endif
+ store (infoTable itbl)
+#ifndef GHCI_TABLES_NEXT_TO_CODE
+ store (conDesc itbl)
+#endif
+
data StgInfoTable = StgInfoTable {
-#ifndef TABLES_NEXT_TO_CODE
+#ifndef GHCI_TABLES_NEXT_TO_CODE
entry :: Ptr (),
#endif
ptrs :: HalfWord,
nptrs :: HalfWord,
tipe :: HalfWord,
srtlen :: HalfWord
-#ifdef TABLES_NEXT_TO_CODE
+#ifdef GHCI_TABLES_NEXT_TO_CODE
, code :: [ItblCode]
#endif
}
sizeOf itbl
= sum
[
-#ifndef TABLES_NEXT_TO_CODE
+#ifndef GHCI_TABLES_NEXT_TO_CODE
fieldSz entry itbl,
#endif
fieldSz ptrs itbl,
fieldSz nptrs itbl,
fieldSz tipe itbl,
fieldSz srtlen itbl
-#ifdef TABLES_NEXT_TO_CODE
+#ifdef GHCI_TABLES_NEXT_TO_CODE
,fieldSz (head.code) itbl * itblCodeLength
#endif
]
poke a0 itbl
= runState (castPtr a0)
$ do
-#ifndef TABLES_NEXT_TO_CODE
+#ifndef GHCI_TABLES_NEXT_TO_CODE
store (entry itbl)
#endif
store (ptrs itbl)
store (nptrs itbl)
store (tipe itbl)
store (srtlen itbl)
-#ifdef TABLES_NEXT_TO_CODE
+#ifdef GHCI_TABLES_NEXT_TO_CODE
sequence_ (map store (code itbl))
#endif
peek a0
= runState (castPtr a0)
$ do
-#ifndef TABLES_NEXT_TO_CODE
+#ifndef GHCI_TABLES_NEXT_TO_CODE
entry <- load
#endif
ptrs <- load
nptrs <- load
tipe <- load
srtlen <- load
-#ifdef TABLES_NEXT_TO_CODE
+#ifdef GHCI_TABLES_NEXT_TO_CODE
code <- sequence (replicate itblCodeLength load)
#endif
return
StgInfoTable {
-#ifndef TABLES_NEXT_TO_CODE
+#ifndef GHCI_TABLES_NEXT_TO_CODE
entry = entry,
#endif
ptrs = ptrs,
nptrs = nptrs,
tipe = tipe,
srtlen = srtlen
-#ifdef TABLES_NEXT_TO_CODE
+#ifdef GHCI_TABLES_NEXT_TO_CODE
,code = code
#endif
}
load = do addr <- advance
lift (peek addr)
-foreign import ccall unsafe "allocateExec"
- _allocateExec :: CUInt -> IO (Ptr a)
-
-malloc_exec :: Int -> IO (Ptr a)
-malloc_exec bytes = _allocateExec (fromIntegral bytes)
-
\end{code}
projects / ghc-hetmet.git / blobdiff