X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FByteCodeItbls.lhs;h=61644b2a8123d0e8a78f8b3c3693c9b5c67224b3;hb=ee26207114635c480dbc7518c0510545a6f62611;hp=73b58cd2227b0e061bc90547844c7db8dbc8373e;hpb=ad94d40948668032189ad22a0ad741ac1f645f50;p=ghc-hetmet.git

diff --git a/compiler/ghci/ByteCodeItbls.lhs b/compiler/ghci/ByteCodeItbls.lhs
index 73b58cd..61644b2 100644
--- a/compiler/ghci/ByteCodeItbls.lhs
+++ b/compiler/ghci/ByteCodeItbls.lhs
@@ -10,7 +10,7 @@ ByteCodeItbls: Generate infotables for interpreter-made bytecodes
 -- 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/CodingStyle#Warnings
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
 -- for details
 
 module ByteCodeItbls ( ItblEnv, ItblPtr(..), itblCode, mkITbls
@@ -19,7 +19,6 @@ module ByteCodeItbls ( ItblEnv, ItblPtr(..), itblCode, mkITbls
 
 #include "HsVersions.h"
 
-import ByteCodeFFI	( newExec )
 import Name		( Name, getName )
 import NameEnv
 import SMRep		( typeCgRep )
@@ -28,7 +27,7 @@ import TyCon		( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )
 import Constants	( mIN_PAYLOAD_SIZE, wORD_SIZE )
 import CgHeapery	( mkVirtHeapOffsets )
 import FastString	( FastString(..) )
-import Util             ( lengthIs, listLengthCmp )
+import Util
 import Outputable
 
 import Foreign
@@ -38,7 +37,6 @@ import Data.Bits	( Bits(..), shiftR )
 
 import GHC.Exts		( Int(I#), addr2Int# )
 import GHC.Ptr		( Ptr(..) )
-import GHC.Prim
 
 import Debug.Trace
 import Text.Printf
@@ -55,10 +53,8 @@ newtype ItblPtr = ItblPtr (Ptr ()) deriving Show
 
 itblCode :: ItblPtr -> Ptr ()
 itblCode (ItblPtr ptr)
-   = (castPtr ptr)
-#ifdef GHCI_TABLES_NEXT_TO_CODE
-                 `plusPtr` conInfoTableSizeB
-#endif
+ | ghciTablesNextToCode = castPtr ptr `plusPtr` conInfoTableSizeB
+ | otherwise            = castPtr ptr
 
 -- XXX bogus
 conInfoTableSizeB = 3 * wORD_SIZE
@@ -131,7 +127,7 @@ make_constr_itbls cons
                             }
                -- Make a piece of code to jump to "entry_label".
                -- This is the only arch-dependent bit.
-           addrCon <- newExec [conInfoTbl]
+           addrCon <- newExec pokeConItbl conInfoTbl
                     --putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl))
                     --putStrLn ("# ptrs  of itbl is " ++ show ptrs)
                     --putStrLn ("# nptrs of itbl is " ++ show nptrs_really)
@@ -308,10 +304,15 @@ instance Storable StgConInfoTable where
 #endif
               , infoTable = itbl
               }
-   poke ptr itbl 
-      = runState (castPtr ptr) $ do
+   poke = error "poke(StgConInfoTable): use pokeConItbl instead"
+
+
+pokeConItbl :: Ptr StgConInfoTable -> Ptr StgConInfoTable -> StgConInfoTable
+            -> IO ()
+pokeConItbl wr_ptr ex_ptr itbl 
+      = runState (castPtr wr_ptr) $ do
 #ifdef GHCI_TABLES_NEXT_TO_CODE
-           store (conDesc itbl `minusPtr` (ptr `plusPtr` conInfoTableSizeB))
+           store (conDesc itbl `minusPtr` (ex_ptr `plusPtr` conInfoTableSizeB))
 #endif
            store (infoTable itbl)
 #ifndef GHCI_TABLES_NEXT_TO_CODE
@@ -430,4 +431,18 @@ load :: Storable a => PtrIO a
 load = do addr <- advance
           lift (peek addr)
 
+
+newExec :: Storable a => (Ptr a -> Ptr a -> a -> IO ()) -> a -> IO (FunPtr ())
+newExec poke_fn obj
+   = alloca $ \pcode -> do
+        wr_ptr <- _allocateExec (fromIntegral (sizeOf obj)) pcode
+        ex_ptr <- peek pcode
+        poke_fn wr_ptr ex_ptr obj
+        return (castPtrToFunPtr ex_ptr)
+   where
+   codeSize :: Storable a => a -> [a] -> Int
+   codeSize dummy array = sizeOf(dummy) * length array
+
+foreign import ccall unsafe "allocateExec"
+  _allocateExec :: CUInt -> Ptr (Ptr a) -> IO (Ptr a)  
 \end{code}