% % (c) The University of Glasgow 2000-2006 % ByteCodeItbls: Generate infotables for interpreter-made bytecodes \begin{code}

    {-# OPTIONS -optc-DNON_POSIX_SOURCE #-}

    {-# OPTIONS -w #-}
    -- The above warning supression flag is a temporary kludge.
    -- While working on this module you are encouraged to remove it and fix
    -- any warnings in the module. See
    --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
    -- for details

    module ByteCodeItbls ( ItblEnv, ItblPtr(..), itblCode, mkITbls
                         , StgInfoTable(..)
                         ) where

    #include "HsVersions.h"

    import Name		( Name, getName )
    import NameEnv
    import SMRep		( typeCgRep )
    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
    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 Debug.Trace
    import Text.Printf

\end{code} %************************************************************************ %* * \subsection{Manufacturing of info tables for DataCons} %* * %************************************************************************ \begin{code}

    newtype ItblPtr = ItblPtr (Ptr ()) deriving Show

    itblCode :: ItblPtr -> Ptr ()
    itblCode (ItblPtr ptr)
     | ghciTablesNextToCode = castPtr ptr `plusPtr` conInfoTableSizeB
     | otherwise            = castPtr ptr

    -- 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

    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 emptyNameEnv
    mkITbls (tc:tcs) = do itbls  <- mkITbl tc
                          itbls2 <- mkITbls tcs
                          return (itbls `plusNameEnv` itbls2)

    mkITbl :: TyCon -> IO ItblEnv
    mkITbl tc
       | not (isDataTyCon tc)
       = return emptyNameEnv
       | dcs `lengthIs` n -- paranoia; this is an assertion.
       = make_constr_itbls dcs
         where
            dcs = tyConDataCons tc
            n   = tyConFamilySize tc

    #include "../includes/rts/storage/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
       = do is <- mapM mk_dirret_itbl (zip cons [0..])
    	return (mkItblEnv is)
         where
            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 = 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 GHCI_TABLES_NEXT_TO_CODE
                             , code  = code
    #endif
                            }
               qNameCString <- newArray0 0 $ 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 pokeConItbl conInfoTbl
                        --putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl))
                        --putStrLn ("# ptrs  of itbl is " ++ show ptrs)
                        --putStrLn ("# nptrs of itbl is " ++ show nptrs_really)
               return (getName dcon, ItblPtr (castFunPtrToPtr addrCon))

    -- Make code which causes a jump to the given address.  This is the
    -- only arch-dependent bit of the itbl story.  The returned list is
    -- itblCodeLength elements (bytes) long.

    -- For sparc_TARGET_ARCH, i386_TARGET_ARCH, etc.
    #include "nativeGen/NCG.h"

    itblCodeLength :: Int
    itblCodeLength = length (mkJumpToAddr undefined)

    mkJumpToAddr :: Ptr () -> [ItblCode]

    ptrToInt (Ptr a#) = I# (addr2Int# a#)

    #if sparc_TARGET_ARCH
    -- After some consideration, we'll try this, where
    -- 0x55555555 stands in for the address to jump to.
    -- According to includes/rts/MachRegs.h, %g3 is very
    -- likely indeed to be baggable.
    --
    --   0000 07155555              sethi   %hi(0x55555555), %g3
    --   0004 8610E155              or      %g3, %lo(0x55555555), %g3
    --   0008 81C0C000              jmp     %g3
    --   000c 01000000              nop

    type ItblCode = Word32
    mkJumpToAddr a
       = let w32 = fromIntegral (ptrToInt a)

             hi22, lo10 :: Word32 -> Word32
             lo10 x = x .&. 0x3FF
             hi22 x = (x `shiftR` 10) .&. 0x3FFFF

         in  [ 0x07000000 .|. (hi22 w32),
               0x8610E000 .|. (lo10 w32),
               0x81C0C000,
               0x01000000 ]

    #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
    -- B8 ZZ YY XX WW FF E0

    type ItblCode = Word8
    mkJumpToAddr a
       = let w32 = fromIntegral (ptrToInt a) :: Word32
             insnBytes :: [Word8]
             insnBytes
                = [0xB8, byte0 w32, byte1 w32,
                         byte2 w32, byte3 w32,
                   0xFF, 0xE0]
         in
             insnBytes

    #elif x86_64_TARGET_ARCH
    -- Generates:
    -- 	jmpq *.L1(%rip)
    -- 	.align 8
    -- .L1:
    -- 	.quad <addr>
    --
    -- We need a full 64-bit pointer (we can't assume the info table is
    -- allocated in low memory).  Assuming the info pointer is aligned to
    -- an 8-byte boundary, the addr will also be aligned.

    type ItblCode = Word8
    mkJumpToAddr a
       = let w64 = fromIntegral (ptrToInt a) :: Word64
             insnBytes :: [Word8]
             insnBytes
                = [0xff, 0x25, 0x02, 0x00, 0x00, 0x00, 0x00, 0x00,
    	       byte0 w64, byte1 w64, byte2 w64, byte3 w64,
    	       byte4 w64, byte5 w64, byte6 w64, byte7 w64]
         in
             insnBytes

    #elif alpha_TARGET_ARCH
    type ItblCode = Word32
    mkJumpToAddr a
        = [ 0xc3800000      -- br   at, .+4
          , 0xa79c000c      -- ldq  at, 12(at)
          , 0x6bfc0000      -- jmp  (at)    # with zero hint -- oh well
          , 0x47ff041f      -- nop
          , fromIntegral (w64 .&. 0x0000FFFF)
          , fromIntegral ((w64 `shiftR` 32) .&. 0x0000FFFF) ]
        where w64 = fromIntegral (ptrToInt a) :: Word64

    #else
    type ItblCode = Word32
    mkJumpToAddr a
        = undefined
    #endif

    byte0, byte1, byte2, byte3, byte4, byte5, byte6, byte7
       :: (Integral w, Bits w) => w -> Word8
    byte0 w = fromIntegral w
    byte1 w = fromIntegral (w `shiftR` 8)
    byte2 w = fromIntegral (w `shiftR` 16)
    byte3 w = fromIntegral (w `shiftR` 24)
    byte4 w = fromIntegral (w `shiftR` 32)
    byte5 w = fromIntegral (w `shiftR` 40)
    byte6 w = fromIntegral (w `shiftR` 48)
    byte7 w = fromIntegral (w `shiftR` 56)

    #ifndef __HADDOCK__
    -- entry point for direct returns for created constr itbls
    foreign import ccall "&stg_interp_constr_entry" stg_interp_constr_entry :: Ptr ()
    #endif

    -- Ultra-minimalist version specially for constructors
    #if SIZEOF_VOID_P == 8
    type HalfWord = Word32
    #else
    type HalfWord = Word16
    #endif

    data StgConInfoTable = StgConInfoTable {
       conDesc   :: Ptr Word8,
       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 = error "poke(StgConInfoTable): use pokeConItbl instead"

    pokeConItbl :: Ptr StgConInfoTable -> Ptr StgConInfoTable -> StgConInfoTable
                -> IO ()
    pokeConItbl wr_ptr ex_ptr itbl
          = runState (castPtr wr_ptr) $ do
    #ifdef GHCI_TABLES_NEXT_TO_CODE
               store (conDesc itbl `minusPtr` (ex_ptr `plusPtr` conInfoTableSizeB))
    #endif
               store (infoTable itbl)
    #ifndef GHCI_TABLES_NEXT_TO_CODE
               store (conDesc itbl)
    #endif

    data StgInfoTable = StgInfoTable {
    #ifndef GHCI_TABLES_NEXT_TO_CODE
       entry  :: Ptr (),
    #endif
       ptrs   :: HalfWord,
       nptrs  :: HalfWord,
       tipe   :: HalfWord,
       srtlen :: HalfWord
    #ifdef GHCI_TABLES_NEXT_TO_CODE
     , code   :: [ItblCode]
    #endif
      }

    instance Storable StgInfoTable where

       sizeOf itbl
          = sum
            [
    #ifndef GHCI_TABLES_NEXT_TO_CODE
             fieldSz entry itbl,
    #endif
             fieldSz ptrs itbl,
             fieldSz nptrs itbl,
             fieldSz tipe itbl,
             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
    #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
    #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
    #ifdef GHCI_TABLES_NEXT_TO_CODE
                    ,code   = code
    #endif
                  }

    fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int
    fieldSz sel x = sizeOf (sel x)

    newtype State s m a = State (s -> m (s, a))

    instance Monad m => Monad (State s m) where
      return a      = State (\s -> return (s, a))
      State m >>= k = State (\s -> m s >>= \(s', a) -> case k a of State n -> n s')
      fail str      = State (\s -> fail str)

    class (Monad m, Monad (t m)) => MonadT t m where
      lift :: m a -> t m a

    instance Monad m => MonadT (State s) m where
      lift m        = State (\s -> m >>= \a -> return (s, a))

    runState :: (Monad m) => s -> State s m a -> m a
    runState s (State m) = m s >>= return . snd

    type PtrIO = State (Ptr Word8) IO

    advance :: Storable a => PtrIO (Ptr a)
    advance = State adv where
        adv addr = case castPtr addr of { addrCast -> return
            (addr `plusPtr` sizeOfPointee addrCast, addrCast) }

    sizeOfPointee :: (Storable a) => Ptr a -> Int
    sizeOfPointee addr = sizeOf (typeHack addr)
        where typeHack = undefined :: Ptr a -> a

    store :: Storable a => a -> PtrIO ()
    store x = do addr <- advance
                 lift (poke addr x)

    load :: Storable a => PtrIO a
    load = do addr <- advance
              lift (peek addr)

    newExec :: Storable a => (Ptr a -> Ptr a -> a -> IO ()) -> a -> IO (FunPtr ())
    newExec poke_fn obj
       = alloca $ \pcode -> do
            wr_ptr <- _allocateExec (fromIntegral (sizeOf obj)) pcode
            ex_ptr <- peek pcode
            poke_fn wr_ptr ex_ptr obj
            return (castPtrToFunPtr ex_ptr)
       where
       codeSize :: Storable a => a -> [a] -> Int
       codeSize dummy array = sizeOf(dummy) * length array

    foreign import ccall unsafe "allocateExec"
      _allocateExec :: CUInt -> Ptr (Ptr a) -> IO (Ptr a)

\end{code}