X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FByteCodeItbls.lhs;h=12cd47fede6e39d09ad852c9214f6b1f5c6f6b4c;hb=7d6dffe542bdad5707a929ae7ac25813c586766d;hp=74346c621865ca38215bd14ed06d9ef10bf5049d;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/compiler/ghci/ByteCodeItbls.lhs b/compiler/ghci/ByteCodeItbls.lhs index 74346c6..12cd47f 100644 --- a/compiler/ghci/ByteCodeItbls.lhs +++ b/compiler/ghci/ByteCodeItbls.lhs @@ -1,20 +1,22 @@ % -% (c) The University of Glasgow 2000 +% (c) The University of Glasgow 2000-2006 % -\section[ByteCodeItbls]{Generate infotables for interpreter-made bytecodes} +ByteCodeItbls: Generate infotables for interpreter-made bytecodes \begin{code} - {-# OPTIONS -optc-DNON_POSIX_SOURCE #-} -module ByteCodeItbls ( ItblEnv, ItblPtr, mkITbls ) where +module ByteCodeItbls ( ItblEnv, ItblPtr(..), itblCode, mkITbls + , StgInfoTable(..) + ) where #include "HsVersions.h" +import ByteCodeFFI ( newExec ) import Name ( Name, getName ) import NameEnv import SMRep ( typeCgRep ) -import DataCon ( DataCon, dataConRepArgTys ) +import DataCon ( DataCon, dataConRepArgTys, dataConIdentity ) import TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons ) import Constants ( mIN_PAYLOAD_SIZE, wORD_SIZE ) import CgHeapery ( mkVirtHeapOffsets ) @@ -23,14 +25,14 @@ import Util ( lengthIs, listLengthCmp ) import Foreign import Foreign.C -import DATA_BITS ( Bits(..), shiftR ) +import Foreign.C.String +import Data.Bits ( Bits(..), shiftR ) import GHC.Exts ( Int(I#), addr2Int# ) -#if __GLASGOW_HASKELL__ < 503 -import Ptr ( Ptr(..) ) -#else import GHC.Ptr ( Ptr(..) ) -#endif +import GHC.Prim + +import Outputable \end{code} %************************************************************************ @@ -40,7 +42,15 @@ import GHC.Ptr ( Ptr(..) ) %************************************************************************ \begin{code} -type ItblPtr = Ptr StgInfoTable +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 + type ItblEnv = NameEnv (Name, ItblPtr) -- We need the Name in the range so we know which -- elements to filter out when unloading a module @@ -86,33 +96,43 @@ make_constr_itbls cons = mk_itbl dcon conNo stg_interp_constr_entry mk_itbl :: DataCon -> Int -> Ptr () -> IO (Name,ItblPtr) - mk_itbl dcon conNo entry_addr - = let rep_args = [ (typeCgRep arg,arg) - | arg <- dataConRepArgTys dcon ] - (tot_wds, ptr_wds, _) = mkVirtHeapOffsets False{-not a THUNK-} rep_args - - ptrs = ptr_wds - nptrs = tot_wds - ptr_wds - nptrs_really - | ptrs + nptrs >= mIN_PAYLOAD_SIZE = nptrs - | otherwise = mIN_PAYLOAD_SIZE - ptrs - itbl = StgInfoTable { + mk_itbl dcon conNo entry_addr = do + let rep_args = [ (typeCgRep arg,arg) | arg <- dataConRepArgTys dcon ] + (tot_wds, ptr_wds, _) = mkVirtHeapOffsets False{-not a THUNK-} rep_args + + ptrs = ptr_wds + nptrs = tot_wds - ptr_wds + nptrs_really + | ptrs + nptrs >= mIN_PAYLOAD_SIZE = nptrs + | otherwise = mIN_PAYLOAD_SIZE - ptrs + code = mkJumpToAddr entry_addr + itbl = StgInfoTable { +#ifndef GHCI_TABLES_NEXT_TO_CODE + entry = entry_addr, +#endif ptrs = fromIntegral ptrs, nptrs = fromIntegral nptrs_really, tipe = fromIntegral cONSTR, - srtlen = fromIntegral conNo, - code = code + srtlen = fromIntegral conNo +#ifdef GHCI_TABLES_NEXT_TO_CODE + , code = code +#endif } - -- Make a piece of code to jump to "entry_label". - -- This is the only arch-dependent bit. - code = mkJumpToAddr entry_addr - in - do addr <- malloc_exec (sizeOf itbl) + qNameCString <- newCString $ 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 --putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl)) --putStrLn ("# ptrs of itbl is " ++ show ptrs) --putStrLn ("# nptrs of itbl is " ++ show nptrs_really) - poke addr itbl - return (getName dcon, addr `plusPtr` (2 * wORD_SIZE)) + -- return (getName dcon, ItblPtr (castFunPtrToPtr addr)) + return (getName dcon, ItblPtr addr) -- Make code which causes a jump to the given address. This is the @@ -274,49 +294,102 @@ type HalfWord = Word32 type HalfWord = Word16 #endif +data StgConInfoTable = StgConInfoTable { + conDesc :: CString, + infoTable :: StgInfoTable +} + +instance Storable StgConInfoTable where + sizeOf conInfoTable + = sum [ sizeOf (conDesc conInfoTable) + , sizeOf (infoTable conInfoTable) ] + alignment conInfoTable = SIZEOF_VOID_P + peek ptr + = runState (castPtr ptr) $ do + desc <- load + itbl <- load + return + StgConInfoTable + { conDesc = desc + , infoTable = itbl + } + poke ptr itbl + = runState (castPtr ptr) $ do + store (conDesc itbl) + store (infoTable itbl) + data StgInfoTable = StgInfoTable { +#ifndef GHCI_TABLES_NEXT_TO_CODE + entry :: Ptr (), +#endif ptrs :: HalfWord, nptrs :: HalfWord, tipe :: HalfWord, - srtlen :: HalfWord, - code :: [ItblCode] -} + srtlen :: HalfWord +#ifdef GHCI_TABLES_NEXT_TO_CODE + , code :: [ItblCode] +#endif + } instance Storable StgInfoTable where sizeOf itbl = sum - [fieldSz ptrs itbl, + [ +#ifndef GHCI_TABLES_NEXT_TO_CODE + fieldSz entry itbl, +#endif + fieldSz ptrs itbl, fieldSz nptrs itbl, fieldSz tipe itbl, - fieldSz srtlen itbl, - fieldSz (head.code) itbl * itblCodeLength] + fieldSz srtlen itbl +#ifdef GHCI_TABLES_NEXT_TO_CODE + ,fieldSz (head.code) itbl * itblCodeLength +#endif + ] alignment itbl = SIZEOF_VOID_P poke a0 itbl = runState (castPtr a0) - $ do store (ptrs itbl) + $ do +#ifndef GHCI_TABLES_NEXT_TO_CODE + store (entry itbl) +#endif + store (ptrs itbl) store (nptrs itbl) store (tipe itbl) store (srtlen itbl) +#ifdef GHCI_TABLES_NEXT_TO_CODE sequence_ (map store (code itbl)) +#endif peek a0 = runState (castPtr a0) - $ do ptrs <- load + $ do +#ifndef GHCI_TABLES_NEXT_TO_CODE + entry <- load +#endif + ptrs <- load nptrs <- load tipe <- load srtlen <- load +#ifdef GHCI_TABLES_NEXT_TO_CODE code <- sequence (replicate itblCodeLength load) +#endif return StgInfoTable { +#ifndef GHCI_TABLES_NEXT_TO_CODE + entry = entry, +#endif ptrs = ptrs, nptrs = nptrs, tipe = tipe, - srtlen = srtlen, - code = code + srtlen = srtlen +#ifdef GHCI_TABLES_NEXT_TO_CODE + ,code = code +#endif } fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int @@ -357,10 +430,4 @@ load :: Storable a => PtrIO a load = do addr <- advance lift (peek addr) -foreign import ccall unsafe "stgMallocBytesRWX" - _stgMallocBytesRWX :: CInt -> IO (Ptr a) - -malloc_exec :: Int -> IO (Ptr a) -malloc_exec bytes = _stgMallocBytesRWX (fromIntegral bytes) - \end{code}