Fix to new executable allocation code (fixed print002 etc.)

The problem here is caused by the fact that info tables include a
relative offset to the string naming the constructor.  Executable
memory now resides at two places in the address space: one for writing
and one for executing.  In the info tables generated by GHCi, we were
calculating the offset relative to the writable instance, rather than
the executable instance, which meant that the GHCi debugger couldn't
find the names for constructors it found in the heap.

diff --git a/compiler/ghci/ByteCodeFFI.lhs b/compiler/ghci/ByteCodeFFI.lhs
index 649efc0..0f149c3 100644 (file)
--- a/compiler/ghci/ByteCodeFFI.lhs
+++ b/compiler/ghci/ByteCodeFFI.lhs
@@ -5,12 +5,11 @@
 ByteCodeGen: Generate machine-code sequences for foreign import
 
 \begin{code}
-module ByteCodeFFI ( moan64, newExec ) where
+module ByteCodeFFI ( moan64 ) where
 
 import Outputable
 import System.IO
 import Foreign
-import Foreign.C
 
 moan64 :: String -> SDoc -> a
 moan64 msg pp_rep
@@ -25,19 +24,5 @@ moan64 msg pp_rep
      )
      `seq`
      pprPanic msg pp_rep
-
-newExec :: Storable a => [a] -> IO (FunPtr ())
-newExec code
-   = alloca $ \pcode -> do
-        ptr <- _allocateExec (fromIntegral $ codeSize undefined code) pcode
-        pokeArray ptr code
-        code <- peek pcode
-        return (castPtrToFunPtr code)
-   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}
 

diff --git a/compiler/ghci/ByteCodeItbls.lhs b/compiler/ghci/ByteCodeItbls.lhs
index fd39e44..61644b2 100644 (file)
--- a/compiler/ghci/ByteCodeItbls.lhs
+++ b/compiler/ghci/ByteCodeItbls.lhs
@@ -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 )
@@ -128,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)
@@ -305,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
@@ -427,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}