X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FByteCodeItbls.lhs;h=696ed0f5644b8d5760ad3fcdcbaa9df6a8f14752;hb=5909e9a896d40a18b4bcf6abb95e0b071bfd7db2;hp=12cd47fede6e39d09ad852c9214f6b1f5c6f6b4c;hpb=7d6dffe542bdad5707a929ae7ac25813c586766d;p=ghc-hetmet.git diff --git a/compiler/ghci/ByteCodeItbls.lhs b/compiler/ghci/ByteCodeItbls.lhs index 12cd47f..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` (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 @@ -76,22 +84,16 @@ 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 -- 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 @@ -118,21 +120,18 @@ 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. - -- 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 @@ -152,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 @@ -261,27 +260,9 @@ byte6 w = fromIntegral (w `shiftR` 48) 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 @@ -295,7 +276,7 @@ type HalfWord = Word16 #endif data StgConInfoTable = StgConInfoTable { - conDesc :: CString, + conDesc :: Ptr Word8, infoTable :: StgInfoTable } @@ -306,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 @@ -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}