[project @ 2002-09-03 15:32:16 by simonmar]

[ghc-hetmet.git] / ghc / compiler / ghci / ByteCodeItbls.lhs

diff --git a/ghc/compiler/ghci/ByteCodeItbls.lhs b/ghc/compiler/ghci/ByteCodeItbls.lhs
index 7a42b8d..c7f829e 100644 (file)
--- a/ghc/compiler/ghci/ByteCodeItbls.lhs
+++ b/ghc/compiler/ghci/ByteCodeItbls.lhs
@@ -4,6 +4,9 @@
 \section[ByteCodeItbls]{Generate infotables for interpreter-made bytecodes}
 
 \begin{code}
+
+{-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
+
 module ByteCodeItbls ( ItblEnv, ItblPtr, mkITbls ) where
 
 #include "HsVersions.h"
@@ -16,17 +19,16 @@ 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 Foreign         ( Storable(..), Word8, Word16, Word32, Word64,
+                         malloc, castPtr, plusPtr )
 import Bits            ( Bits(..), shiftR )
 
-import PrelBase                ( Int(..) )
-import PrelIOBase      ( IO(..) )
-
 import Monad           ( liftM )
 
+import GHC.Exts                ( Int(I#), addr2Int# )
+import GHC.Ptr         ( Ptr(..) )
 \end{code}
 
 %************************************************************************
@@ -52,7 +54,7 @@ mkITbl :: TyCon -> IO ItblEnv
 mkITbl tc
    | not (isDataTyCon tc) 
    = return emptyFM
-   | n == length dcs  -- paranoia; this is an assertion.
+   | dcs `lengthIs` n -- paranoia; this is an assertion.
    = make_constr_itbls dcs
      where
         dcs = tyConDataCons tc
@@ -64,7 +66,7 @@ cONSTR = 1  -- as defined in ghc/includes/ClosureTypes.h
 -- 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)
    | otherwise
@@ -76,7 +78,7 @@ make_constr_itbls cons
         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 +116,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 +133,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 +143,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 +171,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 +179,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 +189,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 +215,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 ()