ghc/compiler/ghci/ByteCodeItbls.lhs

   1 %
   2 % (c) The University of Glasgow 2000
   3 %
   4 \section[ByteCodeItbls]{Generate infotables for interpreter-made bytecodes}
   5
   6 \begin{code}
   7 module ByteCodeItbls ( ItblEnv, mkITbls ) where
   8
   9 #include "HsVersions.h"
  10
  11 import Name             ( Name, getName )
  12 import FiniteMap        ( FiniteMap, listToFM, emptyFM, plusFM )
  13 import Type             ( typePrimRep )
  14 import DataCon          ( DataCon, dataConRepArgTys )
  15 import TyCon            ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )
  16 import Constants        ( mIN_SIZE_NonUpdHeapObject )
  17 import ClosureInfo      ( mkVirtHeapOffsets )
  18 import FastString       ( FastString(..) )
  19
  20 import Foreign          ( Storable(..), Word8, Word16, Word32, Ptr(..),
  21                           malloc, castPtr, plusPtr )
  22 import Addr             ( addrToInt )
  23 import Bits             ( Bits(..), shiftR )
  24
  25 import PrelBase         ( Int(..) )
  26 import PrelAddr         ( Addr(..) )
  27 import PrelIOBase       ( IO(..) )
  28
  29 \end{code}
  30
  31 %************************************************************************
  32 %*                                                                      *
  33 \subsection{Manufacturing of info tables for DataCons}
  34 %*                                                                      *
  35 %************************************************************************
  36
  37 \begin{code}
  38
  39 type ItblEnv = FiniteMap Name (Ptr StgInfoTable)
  40
  41 #if __GLASGOW_HASKELL__ <= 408
  42 type ItblPtr = Addr
  43 #else
  44 type ItblPtr = Ptr StgInfoTable
  45 #endif
  46
  47 -- Make info tables for the data decls in this module
  48 mkITbls :: [TyCon] -> IO ItblEnv
  49 mkITbls [] = return emptyFM
  50 mkITbls (tc:tcs) = do itbls  <- mkITbl tc
  51                       itbls2 <- mkITbls tcs
  52                       return (itbls `plusFM` itbls2)
  53
  54 mkITbl :: TyCon -> IO ItblEnv
  55 mkITbl tc
  56    | not (isDataTyCon tc)
  57    = return emptyFM
  58    | n == length dcs  -- paranoia; this is an assertion.
  59    = make_constr_itbls dcs
  60      where
  61         dcs = tyConDataCons tc
  62         n   = tyConFamilySize tc
  63
  64 cONSTR :: Int
  65 cONSTR = 1  -- as defined in ghc/includes/ClosureTypes.h
  66
  67 -- Assumes constructors are numbered from zero, not one
  68 make_constr_itbls :: [DataCon] -> IO ItblEnv
  69 make_constr_itbls cons
  70    | length cons <= 8
  71    = do is <- mapM mk_vecret_itbl (zip cons [0..])
  72         return (listToFM is)
  73    | otherwise
  74    = do is <- mapM mk_dirret_itbl (zip cons [0..])
  75         return (listToFM is)
  76      where
  77         mk_vecret_itbl (dcon, conNo)
  78            = mk_itbl dcon conNo (vecret_entry conNo)
  79         mk_dirret_itbl (dcon, conNo)
  80            = mk_itbl dcon conNo stg_interp_constr_entry
  81
  82         mk_itbl :: DataCon -> Int -> Addr -> IO (Name,ItblPtr)
  83         mk_itbl dcon conNo entry_addr
  84            = let (tot_wds, ptr_wds, _)
  85                     = mkVirtHeapOffsets typePrimRep (dataConRepArgTys dcon)
  86                  ptrs  = ptr_wds
  87                  nptrs = tot_wds - ptr_wds
  88                  nptrs_really
  89                     | ptrs + nptrs >= mIN_SIZE_NonUpdHeapObject = nptrs
  90                     | otherwise = mIN_SIZE_NonUpdHeapObject - ptrs
  91                  itbl  = StgInfoTable {
  92                            ptrs  = fromIntegral ptrs,
  93                            nptrs = fromIntegral nptrs_really,
  94                            tipe  = fromIntegral cONSTR,
  95                            srtlen = fromIntegral conNo,
  96                            code0 = fromIntegral code0, code1 = fromIntegral code1,
  97                            code2 = fromIntegral code2, code3 = fromIntegral code3,
  98                            code4 = fromIntegral code4, code5 = fromIntegral code5,
  99                            code6 = fromIntegral code6, code7 = fromIntegral code7
 100                         }
 101                  -- Make a piece of code to jump to "entry_label".
 102                  -- This is the only arch-dependent bit.
 103                  -- On x86, if entry_label has an address 0xWWXXYYZZ,
 104                  -- emit   movl $0xWWXXYYZZ,%eax  ;  jmp *%eax
 105                  -- which is
 106                  -- B8 ZZ YY XX WW FF E0
 107                  (code0,code1,code2,code3,code4,code5,code6,code7)
 108                     = (0xB8, byte 0 entry_addr_w, byte 1 entry_addr_w,
 109                              byte 2 entry_addr_w, byte 3 entry_addr_w,
 110                        0xFF, 0xE0,
 111                        0x90 {-nop-})
 112
 113                  entry_addr_w :: Word32
 114                  entry_addr_w = fromIntegral (addrToInt entry_addr)
 115              in
 116                  do addr <- malloc
 117                     --putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl))
 118                     --putStrLn ("# ptrs  of itbl is " ++ show ptrs)
 119                     --putStrLn ("# nptrs of itbl is " ++ show nptrs_really)
 120                     poke addr itbl
 121                     return (getName dcon, addr `plusPtr` 8)
 122
 123
 124 byte :: Int -> Word32 -> Word32
 125 byte 0 w = w .&. 0xFF
 126 byte 1 w = (w `shiftR` 8) .&. 0xFF
 127 byte 2 w = (w `shiftR` 16) .&. 0xFF
 128 byte 3 w = (w `shiftR` 24) .&. 0xFF
 129
 130
 131 vecret_entry 0 = stg_interp_constr1_entry
 132 vecret_entry 1 = stg_interp_constr2_entry
 133 vecret_entry 2 = stg_interp_constr3_entry
 134 vecret_entry 3 = stg_interp_constr4_entry
 135 vecret_entry 4 = stg_interp_constr5_entry
 136 vecret_entry 5 = stg_interp_constr6_entry
 137 vecret_entry 6 = stg_interp_constr7_entry
 138 vecret_entry 7 = stg_interp_constr8_entry
 139
 140 -- entry point for direct returns for created constr itbls
 141 foreign label "stg_interp_constr_entry" stg_interp_constr_entry :: Addr
 142 -- and the 8 vectored ones
 143 foreign label "stg_interp_constr1_entry" stg_interp_constr1_entry :: Addr
 144 foreign label "stg_interp_constr2_entry" stg_interp_constr2_entry :: Addr
 145 foreign label "stg_interp_constr3_entry" stg_interp_constr3_entry :: Addr
 146 foreign label "stg_interp_constr4_entry" stg_interp_constr4_entry :: Addr
 147 foreign label "stg_interp_constr5_entry" stg_interp_constr5_entry :: Addr
 148 foreign label "stg_interp_constr6_entry" stg_interp_constr6_entry :: Addr
 149 foreign label "stg_interp_constr7_entry" stg_interp_constr7_entry :: Addr
 150 foreign label "stg_interp_constr8_entry" stg_interp_constr8_entry :: Addr
 151
 152
 153
 154
 155
 156 -- Ultra-minimalist version specially for constructors
 157 data StgInfoTable = StgInfoTable {
 158    ptrs :: Word16,
 159    nptrs :: Word16,
 160    srtlen :: Word16,
 161    tipe :: Word16,
 162    code0, code1, code2, code3, code4, code5, code6, code7 :: Word8
 163 }
 164
 165
 166 instance Storable StgInfoTable where
 167
 168    sizeOf itbl
 169       = (sum . map (\f -> f itbl))
 170         [fieldSz ptrs, fieldSz nptrs, fieldSz srtlen, fieldSz tipe,
 171          fieldSz code0, fieldSz code1, fieldSz code2, fieldSz code3,
 172          fieldSz code4, fieldSz code5, fieldSz code6, fieldSz code7]
 173
 174    alignment itbl
 175       = (sum . map (\f -> f itbl))
 176         [fieldAl ptrs, fieldAl nptrs, fieldAl srtlen, fieldAl tipe,
 177          fieldAl code0, fieldAl code1, fieldAl code2, fieldAl code3,
 178          fieldAl code4, fieldAl code5, fieldAl code6, fieldAl code7]
 179
 180    poke a0 itbl
 181       = do a1 <- store (ptrs   itbl) (castPtr a0)
 182            a2 <- store (nptrs  itbl) a1
 183            a3 <- store (tipe   itbl) a2
 184            a4 <- store (srtlen itbl) a3
 185            a5 <- store (code0  itbl) a4
 186            a6 <- store (code1  itbl) a5
 187            a7 <- store (code2  itbl) a6
 188            a8 <- store (code3  itbl) a7
 189            a9 <- store (code4  itbl) a8
 190            aA <- store (code5  itbl) a9
 191            aB <- store (code6  itbl) aA
 192            aC <- store (code7  itbl) aB
 193            return ()
 194
 195    peek a0
 196       = do (a1,ptrs)   <- load (castPtr a0)
 197            (a2,nptrs)  <- load a1
 198            (a3,tipe)   <- load a2
 199            (a4,srtlen) <- load a3
 200            (a5,code0)  <- load a4
 201            (a6,code1)  <- load a5
 202            (a7,code2)  <- load a6
 203            (a8,code3)  <- load a7
 204            (a9,code4)  <- load a8
 205            (aA,code5)  <- load a9
 206            (aB,code6)  <- load aA
 207            (aC,code7)  <- load aB
 208            return StgInfoTable { ptrs = ptrs, nptrs = nptrs,
 209                                  srtlen = srtlen, tipe = tipe,
 210                                  code0 = code0, code1 = code1, code2 = code2,
 211                                  code3 = code3, code4 = code4, code5 = code5,
 212                                  code6 = code6, code7 = code7 }
 213
 214 fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int
 215 fieldSz sel x = sizeOf (sel x)
 216
 217 fieldAl :: (Storable a, Storable b) => (a -> b) -> a -> Int
 218 fieldAl sel x = alignment (sel x)
 219
 220 store :: Storable a => a -> Ptr a -> IO (Ptr b)
 221 store x addr = do poke addr x
 222                   return (castPtr (addr `plusPtr` sizeOf x))
 223
 224 load :: Storable a => Ptr a -> IO (Ptr b, a)
 225 load addr = do x <- peek addr
 226                return (castPtr (addr `plusPtr` sizeOf x), x)
 227
 228 \end{code}