X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FByteCodeItbls.lhs;h=12cd47fede6e39d09ad852c9214f6b1f5c6f6b4c;hb=7d6dffe542bdad5707a929ae7ac25813c586766d;hp=863a7b730ecb1d6e543468a7e7a09578d2fc0657;hpb=80564ddc183ea98856994112858f0b9f3e178f94;p=ghc-hetmet.git

diff --git a/compiler/ghci/ByteCodeItbls.lhs b/compiler/ghci/ByteCodeItbls.lhs
index 863a7b7..12cd47f 100644
--- a/compiler/ghci/ByteCodeItbls.lhs
+++ b/compiler/ghci/ByteCodeItbls.lhs
@@ -6,14 +6,17 @@ ByteCodeItbls: Generate infotables for interpreter-made bytecodes
 \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 )
-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 )
@@ -22,10 +25,14 @@ import Util             ( lengthIs, listLengthCmp )
 
 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}
 
 %************************************************************************
@@ -35,7 +42,15 @@ import GHC.Ptr		( Ptr(..) )
 %************************************************************************
 
 \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
@@ -81,17 +96,17 @@ make_constr_itbls cons
            = 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
@@ -103,20 +118,21 @@ make_constr_itbls cons
                          , 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 <- 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.
+           -- addr <- newExec [itbl]
+           addrCon <- newExec [conInfoTbl]
+           let addr = (castFunPtrToPtr addrCon) `plusPtr` 4 -- ToDo: remove magic number
                     --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 GHCI_TABLES_NEXT_TO_CODE
-                                               `plusPtr` (2 * wORD_SIZE)
-#endif
-                           )
+           -- return (getName dcon, ItblPtr (castFunPtrToPtr addr))
+           return (getName dcon, ItblPtr addr)
 
 
 -- Make code which causes a jump to the given address.  This is the
@@ -278,6 +294,30 @@ type HalfWord = Word32
 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 (),
@@ -390,10 +430,4 @@ load :: Storable a => PtrIO a
 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}