\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 )
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
import GHC.Exts ( Int(I#), addr2Int# )
import GHC.Ptr ( Ptr(..) )
-import GHC.Prim
-import Outputable
+import Debug.Trace
+import Text.Printf
\end{code}
%************************************************************************
itblCode :: ItblPtr -> Ptr ()
itblCode (ItblPtr ptr)
- = (castPtr ptr)
-#ifdef GHCI_TABLES_NEXT_TO_CODE
- `plusPtr` (wORD_SIZE * 2)
-#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
dcs = tyConDataCons tc
n = tyConFamilySize tc
-#include "../includes/ClosureTypes.h"
+#include "../includes/rts/storage/ClosureTypes.h"
cONSTR :: Int -- Defined in ClosureTypes.h
cONSTR = CONSTR
-- Assumes constructors are numbered from zero, not one
make_constr_itbls :: [DataCon] -> IO ItblEnv
make_constr_itbls cons
- | listLengthCmp cons 8 /= GT -- <= 8 elements in the list
- = do is <- mapM mk_vecret_itbl (zip cons [0..])
- return (mkItblEnv is)
- | otherwise
= do is <- mapM mk_dirret_itbl (zip cons [0..])
return (mkItblEnv is)
where
- mk_vecret_itbl (dcon, conNo)
- = mk_itbl dcon conNo (vecret_entry conNo)
mk_dirret_itbl (dcon, conNo)
= mk_itbl dcon conNo stg_interp_constr_entry
, 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.
- -- addr <- newExec [itbl]
- addrCon <- newExec [conInfoTbl]
- let addr = (castFunPtrToPtr addrCon) `plusPtr` 4 -- ToDo: remove magic number
+ 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)
- -- return (getName dcon, ItblPtr (castFunPtrToPtr addr))
- return (getName dcon, ItblPtr addr)
+ return (getName dcon, ItblPtr (castFunPtrToPtr addrCon))
-- Make code which causes a jump to the given address. This is the
#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
byte7 w = fromIntegral (w `shiftR` 56)
-vecret_entry 0 = stg_interp_constr1_entry
-vecret_entry 1 = stg_interp_constr2_entry
-vecret_entry 2 = stg_interp_constr3_entry
-vecret_entry 3 = stg_interp_constr4_entry
-vecret_entry 4 = stg_interp_constr5_entry
-vecret_entry 5 = stg_interp_constr6_entry
-vecret_entry 6 = stg_interp_constr7_entry
-vecret_entry 7 = stg_interp_constr8_entry
-
#ifndef __HADDOCK__
-- entry point for direct returns for created constr itbls
foreign import ccall "&stg_interp_constr_entry" stg_interp_constr_entry :: Ptr ()
--- and the 8 vectored ones
-foreign import ccall "&stg_interp_constr1_entry" stg_interp_constr1_entry :: Ptr ()
-foreign import ccall "&stg_interp_constr2_entry" stg_interp_constr2_entry :: Ptr ()
-foreign import ccall "&stg_interp_constr3_entry" stg_interp_constr3_entry :: Ptr ()
-foreign import ccall "&stg_interp_constr4_entry" stg_interp_constr4_entry :: Ptr ()
-foreign import ccall "&stg_interp_constr5_entry" stg_interp_constr5_entry :: Ptr ()
-foreign import ccall "&stg_interp_constr6_entry" stg_interp_constr6_entry :: Ptr ()
-foreign import ccall "&stg_interp_constr7_entry" stg_interp_constr7_entry :: Ptr ()
-foreign import ccall "&stg_interp_constr8_entry" stg_interp_constr8_entry :: Ptr ()
#endif
#endif
data StgConInfoTable = StgConInfoTable {
- conDesc :: CString,
+ conDesc :: Ptr Word8,
infoTable :: StgInfoTable
}
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
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}
projects / ghc-hetmet.git / blobdiff