\begin{code}
{-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
-{-# OPTIONS_GHC -w #-}
+{-# 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/WorkingConventions#Warnings
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
module ByteCodeItbls ( ItblEnv, ItblPtr(..), itblCode, mkITbls
#include "HsVersions.h"
-import ByteCodeFFI ( newExec )
import Name ( Name, getName )
import NameEnv
import SMRep ( typeCgRep )
import Constants ( mIN_PAYLOAD_SIZE, wORD_SIZE )
import CgHeapery ( mkVirtHeapOffsets )
import FastString ( FastString(..) )
-import Util ( lengthIs, listLengthCmp )
+import Util
import Outputable
import Foreign
import GHC.Exts ( Int(I#), addr2Int# )
import GHC.Ptr ( Ptr(..) )
-import GHC.Prim
import Debug.Trace
import Text.Printf
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
dcs = tyConDataCons tc
n = tyConFamilySize tc
-#include "../includes/ClosureTypes.h"
+#include "../includes/rts/storage/ClosureTypes.h"
cONSTR :: Int -- Defined in ClosureTypes.h
cONSTR = CONSTR
}
-- 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)
#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
#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
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}