X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fghci%2FByteCodeItbls.lhs;h=696ed0f5644b8d5760ad3fcdcbaa9df6a8f14752;hp=887f637319560b597fa036d7f61ad4c66ed56a8b;hb=2c8aabcad1d2f2c469cb8a10afa7b66beeaedd45;hpb=89692d034948e58dd461639897690e2d3ab8cd44

diff --git a/compiler/ghci/ByteCodeItbls.lhs b/compiler/ghci/ByteCodeItbls.lhs
index 887f637..696ed0f 100644
--- a/compiler/ghci/ByteCodeItbls.lhs
+++ b/compiler/ghci/ByteCodeItbls.lhs
@@ -6,13 +6,19 @@ ByteCodeItbls: Generate infotables for interpreter-made bytecodes
 \begin{code}
 {-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
 
+{-# OPTIONS -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/Commentary/CodingStyle#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 )
@@ -21,7 +27,8 @@ 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
 import Foreign.C
@@ -30,9 +37,9 @@ import Data.Bits	( Bits(..), shiftR )
 
 import GHC.Exts		( Int(I#), addr2Int# )
 import GHC.Ptr		( Ptr(..) )
-import GHC.Prim
 
-import Outputable
+import Debug.Trace
+import Text.Printf
 \end{code}
 
 %************************************************************************
@@ -46,10 +53,11 @@ newtype ItblPtr = ItblPtr (Ptr ()) deriving Show
 
 itblCode :: ItblPtr -> Ptr ()
 itblCode (ItblPtr ptr)
-   = (castPtr ptr)
-#ifdef GHCI_TABLES_NEXT_TO_CODE
-                 `plusPtr` (3 * wORD_SIZE)
-#endif
+ | ghciTablesNextToCode = castPtr ptr `plusPtr` conInfoTableSizeB
+ | otherwise            = castPtr ptr
+
+-- XXX bogus
+conInfoTableSizeB = 3 * wORD_SIZE
 
 type ItblEnv = NameEnv (Name, ItblPtr)
 	-- We need the Name in the range so we know which
@@ -76,7 +84,7 @@ mkITbl tc
         dcs = tyConDataCons tc
         n   = tyConFamilySize tc
 
-#include "../includes/ClosureTypes.h"
+#include "../includes/rts/storage/ClosureTypes.h"
 cONSTR :: Int	-- Defined in ClosureTypes.h
 cONSTR = CONSTR 
 
@@ -112,14 +120,14 @@ make_constr_itbls cons
                          , code  = code
 #endif
                         }
-           qNameCString <- newCString $ dataConIdentity dcon 
+           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]
+           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)
@@ -143,7 +151,7 @@ ptrToInt (Ptr a#) = I# (addr2Int# a#)
 #if sparc_TARGET_ARCH
 -- After some consideration, we'll try this, where
 -- 0x55555555 stands in for the address to jump to.
--- According to ghc/includes/MachRegs.h, %g3 is very
+-- According to includes/rts/MachRegs.h, %g3 is very
 -- likely indeed to be baggable.
 --
 --   0000 07155555              sethi   %hi(0x55555555), %g3
@@ -268,7 +276,7 @@ type HalfWord = Word16
 #endif
 
 data StgConInfoTable = StgConInfoTable {
-   conDesc   :: CString,
+   conDesc   :: Ptr Word8,
    infoTable :: StgInfoTable
 }
 
@@ -279,17 +287,37 @@ instance Storable StgConInfoTable where
    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 
-              { conDesc   = desc
+              { 
+#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
-           store (conDesc itbl)
+   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` (ex_ptr `plusPtr` conInfoTableSizeB))
+#endif
            store (infoTable itbl)
+#ifndef GHCI_TABLES_NEXT_TO_CODE
+           store (conDesc itbl)
+#endif
 
 data StgInfoTable = StgInfoTable {
 #ifndef GHCI_TABLES_NEXT_TO_CODE
@@ -403,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}