X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FByteCodeItbls.lhs;h=5325f8f29e91e439eb22e67f4bbbeff299830842;hb=ceaf8381097ee7587ea60006ed2ee3015a6ee50c;hp=7a42b8d00cccdf58a00f523ef806872d9277491a;hpb=a6e4c7f78c220055768c63ed6098f3ebde36dba7;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/ByteCodeItbls.lhs b/ghc/compiler/ghci/ByteCodeItbls.lhs index 7a42b8d..5325f8f 100644 --- a/ghc/compiler/ghci/ByteCodeItbls.lhs +++ b/ghc/compiler/ghci/ByteCodeItbls.lhs @@ -4,29 +4,33 @@ \section[ByteCodeItbls]{Generate infotables for interpreter-made bytecodes} \begin{code} + +{-# OPTIONS -optc-DNON_POSIX_SOURCE #-} + module ByteCodeItbls ( ItblEnv, ItblPtr, mkITbls ) where #include "HsVersions.h" import Name ( Name, getName ) -import FiniteMap ( FiniteMap, listToFM, emptyFM, plusFM ) +import NameEnv import Type ( typePrimRep ) import DataCon ( DataCon, dataConRepArgTys ) import TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons ) import Constants ( mIN_SIZE_NonUpdHeapObject ) import ClosureInfo ( mkVirtHeapOffsets ) import FastString ( FastString(..) ) +import Util ( lengthIs, listLengthCmp ) -import Foreign ( Storable(..), Word8, Word16, Word32, Word64, Ptr(..), - malloc, castPtr, plusPtr, Addr ) -import Addr ( addrToInt ) -import Bits ( Bits(..), shiftR ) - -import PrelBase ( Int(..) ) -import PrelIOBase ( IO(..) ) - -import Monad ( liftM ) +import Foreign ( Storable(..), Word8, Word16, Word32, Word64, + malloc, castPtr, plusPtr ) +import DATA_BITS ( Bits(..), shiftR ) +import GHC.Exts ( Int(I#), addr2Int# ) +#if __GLASGOW_HASKELL__ < 503 +import Ptr ( Ptr(..) ) +#else +import GHC.Ptr ( Ptr(..) ) +#endif \end{code} %************************************************************************ @@ -36,47 +40,52 @@ import Monad ( liftM ) %************************************************************************ \begin{code} - type ItblPtr = Ptr StgInfoTable -type ItblEnv = FiniteMap Name ItblPtr +type ItblEnv = NameEnv (Name, ItblPtr) + -- We need the Name in the range so we know which + -- elements to filter out when unloading a module + +mkItblEnv :: [(Name,ItblPtr)] -> ItblEnv +mkItblEnv pairs = mkNameEnv [(n, (n,p)) | (n,p) <- pairs] -- Make info tables for the data decls in this module mkITbls :: [TyCon] -> IO ItblEnv -mkITbls [] = return emptyFM +mkITbls [] = return emptyNameEnv mkITbls (tc:tcs) = do itbls <- mkITbl tc itbls2 <- mkITbls tcs - return (itbls `plusFM` itbls2) + return (itbls `plusNameEnv` itbls2) mkITbl :: TyCon -> IO ItblEnv mkITbl tc | not (isDataTyCon tc) - = return emptyFM - | n == length dcs -- paranoia; this is an assertion. + = return emptyNameEnv + | dcs `lengthIs` n -- paranoia; this is an assertion. = make_constr_itbls dcs where dcs = tyConDataCons tc n = tyConFamilySize tc -cONSTR :: Int -cONSTR = 1 -- as defined in ghc/includes/ClosureTypes.h +#include "../includes/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 - | length cons <= 8 + | listLengthCmp cons 8 /= GT -- <= 8 elements in the list = do is <- mapM mk_vecret_itbl (zip cons [0..]) - return (listToFM is) + return (mkItblEnv is) | otherwise = do is <- mapM mk_dirret_itbl (zip cons [0..]) - return (listToFM is) + 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 -> Addr -> IO (Name,ItblPtr) + mk_itbl :: DataCon -> Int -> Ptr () -> IO (Name,ItblPtr) mk_itbl dcon conNo entry_addr = let (tot_wds, ptr_wds, _) = mkVirtHeapOffsets typePrimRep (dataConRepArgTys dcon) @@ -114,7 +123,9 @@ make_constr_itbls cons itblCodeLength :: Int itblCodeLength = length (mkJumpToAddr undefined) -mkJumpToAddr :: Addr -> [ItblCode] +mkJumpToAddr :: Ptr () -> [ItblCode] + +ptrToInt (Ptr a#) = I# (addr2Int# a#) #if sparc_TARGET_ARCH -- After some consideration, we'll try this, where @@ -129,7 +140,7 @@ mkJumpToAddr :: Addr -> [ItblCode] type ItblCode = Word32 mkJumpToAddr a - = let w32 = fromIntegral (addrToInt a) + = let w32 = fromIntegral (ptrToInt a) hi22, lo10 :: Word32 -> Word32 lo10 x = x .&. 0x3FF @@ -139,9 +150,27 @@ mkJumpToAddr a 0x8610E000 .|. (lo10 w32), 0x81C0C000, 0x01000000 ] -#endif -#if i386_TARGET_ARCH +#elif powerpc_TARGET_ARCH +-- We'll use r12, for no particular reason. +-- 0xDEADBEEF stands for the adress: +-- 3D80DEAD lis r12,0xDEAD +-- 618CBEEF ori r12,r12,0xBEEF +-- 7D8903A6 mtctr r12 +-- 4E800420 bctr + +type ItblCode = Word32 +mkJumpToAddr a = + let w32 = fromIntegral (ptrToInt a) + hi16 x = (x `shiftR` 16) .&. 0xFFFF + lo16 x = x .&. 0xFFFF + in [ + 0x3D800000 .|. hi16 w32, + 0x618C0000 .|. lo16 w32, + 0x7D8903A6, 0x4E800420 + ] + +#elif i386_TARGET_ARCH -- Let the address to jump to be 0xWWXXYYZZ. -- Generate movl $0xWWXXYYZZ,%eax ; jmp *%eax -- which is @@ -149,7 +178,7 @@ mkJumpToAddr a type ItblCode = Word8 mkJumpToAddr a - = let w32 = fromIntegral (addrToInt a) + = let w32 = fromIntegral (ptrToInt a) insnBytes :: [Word8] insnBytes = [0xB8, byte 0 w32, byte 1 w32, @@ -157,9 +186,8 @@ mkJumpToAddr a 0xFF, 0xE0] in insnBytes -#endif -#if alpha_TARGET_ARCH +#elif alpha_TARGET_ARCH type ItblCode = Word32 mkJumpToAddr a = [ 0xc3800000 -- br at, .+4 @@ -168,7 +196,12 @@ mkJumpToAddr a , 0x47ff041f -- nop , fromIntegral (w64 .&. 0x0000FFFF) , fromIntegral ((w64 `shiftR` 32) .&. 0x0000FFFF) ] - where w64 = fromIntegral (addrToInt a) :: Word64 + where w64 = fromIntegral (ptrToInt a) :: Word64 + +#else +type ItblCode = Word32 +mkJumpToAddr a + = undefined #endif @@ -189,16 +222,16 @@ vecret_entry 6 = stg_interp_constr7_entry vecret_entry 7 = stg_interp_constr8_entry -- entry point for direct returns for created constr itbls -foreign label "stg_interp_constr_entry" stg_interp_constr_entry :: Addr +foreign label "stg_interp_constr_entry" stg_interp_constr_entry :: Ptr () -- and the 8 vectored ones -foreign label "stg_interp_constr1_entry" stg_interp_constr1_entry :: Addr -foreign label "stg_interp_constr2_entry" stg_interp_constr2_entry :: Addr -foreign label "stg_interp_constr3_entry" stg_interp_constr3_entry :: Addr -foreign label "stg_interp_constr4_entry" stg_interp_constr4_entry :: Addr -foreign label "stg_interp_constr5_entry" stg_interp_constr5_entry :: Addr -foreign label "stg_interp_constr6_entry" stg_interp_constr6_entry :: Addr -foreign label "stg_interp_constr7_entry" stg_interp_constr7_entry :: Addr -foreign label "stg_interp_constr8_entry" stg_interp_constr8_entry :: Addr +foreign label "stg_interp_constr1_entry" stg_interp_constr1_entry :: Ptr () +foreign label "stg_interp_constr2_entry" stg_interp_constr2_entry :: Ptr () +foreign label "stg_interp_constr3_entry" stg_interp_constr3_entry :: Ptr () +foreign label "stg_interp_constr4_entry" stg_interp_constr4_entry :: Ptr () +foreign label "stg_interp_constr5_entry" stg_interp_constr5_entry :: Ptr () +foreign label "stg_interp_constr6_entry" stg_interp_constr6_entry :: Ptr () +foreign label "stg_interp_constr7_entry" stg_interp_constr7_entry :: Ptr () +foreign label "stg_interp_constr8_entry" stg_interp_constr8_entry :: Ptr ()