\begin{code}
{-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
-module ByteCodeItbls ( ItblEnv, ItblPtr, mkITbls ) where
+module ByteCodeItbls ( ItblEnv, ItblPtr(..), itblCode, mkITbls
+ , StgInfoTable(..)
+ ) where
#include "HsVersions.h"
+import ByteCodeFFI ( newExec )
import Name ( Name, getName )
import NameEnv
import SMRep ( typeCgRep )
%************************************************************************
\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` (wORD_SIZE * 2)
+#endif
+
type ItblEnv = NameEnv (Name, ItblPtr)
-- We need the Name in the range so we know which
-- elements to filter out when unloading a module
| ptrs + nptrs >= mIN_PAYLOAD_SIZE = nptrs
| otherwise = mIN_PAYLOAD_SIZE - ptrs
itbl = StgInfoTable {
-#ifndef TABLES_NEXT_TO_CODE
+#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
}
-- This is the only arch-dependent bit.
code = mkJumpToAddr entry_addr
in
- do addr <- malloc_exec (sizeOf itbl)
+ do addr <- newExec [itbl]
--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 addr))
-- Make code which causes a jump to the given address. This is the
#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}