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