X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FByteCodeItbls.lhs;h=c44e562bc091a6cad1d59402eb39453b414c99a5;hb=423d477bfecd490de1449c59325c8776f91d7aac;hp=ae1f35b89129296dd58fb51fa5639e17bf296cdf;hpb=bc5c802181b513216bc88f0d1ec9574157ee05fe;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/ByteCodeItbls.lhs b/ghc/compiler/ghci/ByteCodeItbls.lhs index ae1f35b..c44e562 100644 --- a/ghc/compiler/ghci/ByteCodeItbls.lhs +++ b/ghc/compiler/ghci/ByteCodeItbls.lhs @@ -12,24 +12,25 @@ module ByteCodeItbls ( ItblEnv, ItblPtr, mkITbls ) where #include "HsVersions.h" import Name ( Name, getName ) -import FiniteMap ( FiniteMap, listToFM, emptyFM, plusFM ) -import Type ( typePrimRep ) +import NameEnv +import SMRep ( typeCgRep ) import DataCon ( DataCon, dataConRepArgTys ) import TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons ) import Constants ( mIN_SIZE_NonUpdHeapObject ) -import ClosureInfo ( mkVirtHeapOffsets ) +import CgHeapery ( 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} %************************************************************************ @@ -39,50 +40,57 @@ 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) + = let rep_args = [ (typeCgRep arg,arg) + | arg <- dataConRepArgTys dcon ] + (tot_wds, ptr_wds, _) = mkVirtHeapOffsets rep_args + ptrs = ptr_wds nptrs = tot_wds - ptr_wds nptrs_really @@ -117,7 +125,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 @@ -132,7 +142,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 @@ -142,9 +152,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 @@ -152,7 +180,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, @@ -160,9 +188,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 @@ -171,7 +198,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 @@ -192,16 +224,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 ()