X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fghci%2FByteCodeItbls.lhs;h=9b2dac0618d6801b3ee6ce27badeef3b09154f53;hp=cd075155832dd5c75c845160dae4ca6f2569862e;hb=cdce647711c0f46f5799b24de087622cb77e647f;hpb=8c2549461d624ad5cfec9be3266bdfd016371658 diff --git a/compiler/ghci/ByteCodeItbls.lhs b/compiler/ghci/ByteCodeItbls.lhs index cd07515..9b2dac0 100644 --- a/compiler/ghci/ByteCodeItbls.lhs +++ b/compiler/ghci/ByteCodeItbls.lhs @@ -6,26 +6,35 @@ 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 ) import FastString ( FastString(..) ) import Util ( lengthIs, listLengthCmp ) +import Outputable import Foreign import Foreign.C +import Foreign.C.String import Data.Bits ( Bits(..), shiftR ) import GHC.Exts ( Int(I#), addr2Int# ) import GHC.Ptr ( Ptr(..) ) +import GHC.Prim + +import Debug.Trace +import Text.Printf \end{code} %************************************************************************ @@ -35,7 +44,18 @@ 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` conInfoTableSizeB +#endif + +-- XXX bogus +conInfoTableSizeB = 3 * wORD_SIZE + type ItblEnv = NameEnv (Name, ItblPtr) -- We need the Name in the range so we know which -- elements to filter out when unloading a module @@ -68,55 +88,47 @@ 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 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 { -#ifndef TABLES_NEXT_TO_CODE + 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 -#ifdef TABLES_NEXT_TO_CODE +#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. + addrCon <- newExec [conInfoTbl] --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 -#ifdef TABLES_NEXT_TO_CODE - `plusPtr` (2 * wORD_SIZE) -#endif - ) + return (getName dcon, ItblPtr (castFunPtrToPtr addrCon)) -- Make code which causes a jump to the given address. This is the @@ -245,27 +257,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 @@ -278,15 +272,54 @@ 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 +#ifdef GHCI_TABLES_NEXT_TO_CODE + desc <- load +#endif + itbl <- load +#ifndef GHCI_TABLES_NEXT_TO_CODE + desc <- load +#endif + return + StgConInfoTable + { +#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 +#ifdef GHCI_TABLES_NEXT_TO_CODE + store (conDesc itbl `minusPtr` (ptr `plusPtr` conInfoTableSizeB)) +#endif + store (infoTable itbl) +#ifndef GHCI_TABLES_NEXT_TO_CODE + store (conDesc itbl) +#endif + data StgInfoTable = StgInfoTable { -#ifndef TABLES_NEXT_TO_CODE +#ifndef GHCI_TABLES_NEXT_TO_CODE entry :: Ptr (), #endif ptrs :: HalfWord, nptrs :: HalfWord, tipe :: HalfWord, srtlen :: HalfWord -#ifdef TABLES_NEXT_TO_CODE +#ifdef GHCI_TABLES_NEXT_TO_CODE , code :: [ItblCode] #endif } @@ -296,14 +329,14 @@ instance Storable StgInfoTable where sizeOf itbl = sum [ -#ifndef TABLES_NEXT_TO_CODE +#ifndef GHCI_TABLES_NEXT_TO_CODE fieldSz entry itbl, #endif fieldSz ptrs itbl, fieldSz nptrs itbl, fieldSz tipe itbl, fieldSz srtlen itbl -#ifdef TABLES_NEXT_TO_CODE +#ifdef GHCI_TABLES_NEXT_TO_CODE ,fieldSz (head.code) itbl * itblCodeLength #endif ] @@ -314,40 +347,40 @@ instance Storable StgInfoTable where poke a0 itbl = runState (castPtr a0) $ do -#ifndef TABLES_NEXT_TO_CODE +#ifndef GHCI_TABLES_NEXT_TO_CODE store (entry itbl) #endif store (ptrs itbl) store (nptrs itbl) store (tipe itbl) store (srtlen itbl) -#ifdef TABLES_NEXT_TO_CODE +#ifdef GHCI_TABLES_NEXT_TO_CODE sequence_ (map store (code itbl)) #endif peek a0 = runState (castPtr a0) $ do -#ifndef TABLES_NEXT_TO_CODE +#ifndef GHCI_TABLES_NEXT_TO_CODE entry <- load #endif ptrs <- load nptrs <- load tipe <- load srtlen <- load -#ifdef TABLES_NEXT_TO_CODE +#ifdef GHCI_TABLES_NEXT_TO_CODE code <- sequence (replicate itblCodeLength load) #endif return StgInfoTable { -#ifndef TABLES_NEXT_TO_CODE +#ifndef GHCI_TABLES_NEXT_TO_CODE entry = entry, #endif ptrs = ptrs, nptrs = nptrs, tipe = tipe, srtlen = srtlen -#ifdef TABLES_NEXT_TO_CODE +#ifdef GHCI_TABLES_NEXT_TO_CODE ,code = code #endif } @@ -390,10 +423,4 @@ load :: Storable a => PtrIO a load = do addr <- advance lift (peek addr) -foreign import ccall unsafe "allocateExec" - _allocateExec :: CUInt -> IO (Ptr a) - -malloc_exec :: Int -> IO (Ptr a) -malloc_exec bytes = _allocateExec (fromIntegral bytes) - \end{code}