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                            code8 = fromIntegral code8, code9 = fromIntegral code9,
  96                            codeA = fromIntegral codeA, codeB = fromIntegral codeB,
  97                            codeC = fromIntegral codeC, codeD = fromIntegral codeD,
  98                            codeE = fromIntegral codeE, codeF = fromIntegral codeF
  99                         }
 100                  -- Make a piece of code to jump to "entry_label".
 101                  -- This is the only arch-dependent bit.
 102                  [code0,code1,code2,code3,code4,code5,code6,code7,
 103                   code8,code9,codeA,codeB,codeC,codeD,codeE,codeF]
 104                     = mkJumpToAddr entry_addr
 105              in
 106                  do addr <- malloc
 107                     --putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl))
 108                     --putStrLn ("# ptrs  of itbl is " ++ show ptrs)
 109                     --putStrLn ("# nptrs of itbl is " ++ show nptrs_really)
 110                     poke addr itbl
 111                     return (getName dcon, addr `plusPtr` 8)
 112
 113
 114 -- Make code which causes a jump to the given address.  This is the
 115 -- only arch-dependent bit of the itbl story.  The returned list is
 116 -- 16 elements long, since on sparc 4 words (i.e. 4 insns) are needed.
 117
 118 -- For sparc_TARGET_ARCH, i386_TARGET_ARCH, etc.
 119 #include "nativeGen/NCG.h"
 120
 121 mkJumpToAddr :: Addr -> [Word8]
 122
 123 #if sparc_TARGET_ARCH
 124 -- After some consideration, we'll try this, where
 125 -- 0x55555555 stands in for the address to jump to.
 126 -- According to ghc/includes/MachRegs.h, %g3 is very
 127 -- likely indeed to be baggable.
 128 --
 129 --   0000 07155555              sethi   %hi(0x55555555), %g3
 130 --   0004 8610E155              or      %g3, %lo(0x55555555), %g3
 131 --   0008 81C0C000              jmp     %g3
 132 --   000c 01000000              nop
 133
 134 mkJumpToAddr a
 135    = let w32 = fromIntegral (addrToInt a)
 136          insn1 = 0x07000000 .|. (hi22 w32)
 137          insn2 = 0x8610E000 .|. (lo10 w32)
 138          insn3 = 0x81C0C000
 139          insn4 = 0x01000000
 140
 141          -- big-endianly ...
 142          w2bytes :: Word32 -> [Word8]
 143          w2bytes w
 144             = map fromIntegral [byte 3 w, byte 2 w, byte 1 w, byte 0 w]
 145
 146          hi22, lo10 :: Word32 -> Word32
 147          lo10 x = x .&. 0x3FF
 148          hi22 x = (x `shiftR` 10) .&. 0x3FFFF
 149
 150          insnBytes
 151             = concat (map w2bytes [insn1, insn2, insn3, insn4])
 152      in
 153          insnBytes
 154 #endif
 155
 156 #if i386_TARGET_ARCH
 157 -- Let the address to jump to be 0xWWXXYYZZ.
 158 -- Generate   movl $0xWWXXYYZZ,%eax  ;  jmp *%eax
 159 -- which is
 160 -- B8 ZZ YY XX WW FF E0
 161 mkJumpToAddr a
 162    = let w32 = fromIntegral (addrToInt a)
 163          insnBytes :: [Word8]
 164          insnBytes
 165             = map fromIntegral (take 16 (
 166                  [0xB8, byte 0 w32, byte 1 w32,
 167                         byte 2 w32, byte 3 w32,
 168                   0xFF, 0xE0]
 169                  ++ let nops = 0x90 : nops in nops
 170               ))
 171      in
 172          insnBytes
 173 #endif
 174
 175
 176 byte :: Int -> Word32 -> Word32
 177 byte 0 w = w .&. 0xFF
 178 byte 1 w = (w `shiftR` 8) .&. 0xFF
 179 byte 2 w = (w `shiftR` 16) .&. 0xFF
 180 byte 3 w = (w `shiftR` 24) .&. 0xFF
 181
 182
 183 vecret_entry 0 = stg_interp_constr1_entry
 184 vecret_entry 1 = stg_interp_constr2_entry
 185 vecret_entry 2 = stg_interp_constr3_entry
 186 vecret_entry 3 = stg_interp_constr4_entry
 187 vecret_entry 4 = stg_interp_constr5_entry
 188 vecret_entry 5 = stg_interp_constr6_entry
 189 vecret_entry 6 = stg_interp_constr7_entry
 190 vecret_entry 7 = stg_interp_constr8_entry
 191
 192 -- entry point for direct returns for created constr itbls
 193 foreign label "stg_interp_constr_entry" stg_interp_constr_entry :: Addr
 194 -- and the 8 vectored ones
 195 foreign label "stg_interp_constr1_entry" stg_interp_constr1_entry :: Addr
 196 foreign label "stg_interp_constr2_entry" stg_interp_constr2_entry :: Addr
 197 foreign label "stg_interp_constr3_entry" stg_interp_constr3_entry :: Addr
 198 foreign label "stg_interp_constr4_entry" stg_interp_constr4_entry :: Addr
 199 foreign label "stg_interp_constr5_entry" stg_interp_constr5_entry :: Addr
 200 foreign label "stg_interp_constr6_entry" stg_interp_constr6_entry :: Addr
 201 foreign label "stg_interp_constr7_entry" stg_interp_constr7_entry :: Addr
 202 foreign label "stg_interp_constr8_entry" stg_interp_constr8_entry :: Addr
 203
 204
 205
 206
 207
 208 -- Ultra-minimalist version specially for constructors
 209 data StgInfoTable = StgInfoTable {
 210    ptrs   :: Word16,
 211    nptrs  :: Word16,
 212    srtlen :: Word16,
 213    tipe   :: Word16,
 214    code0, code1, code2, code3, code4, code5, code6, code7,
 215    code8, code9, codeA, codeB, codeC, codeD, codeE, codeF :: Word8
 216 }
 217
 218
 219 instance Storable StgInfoTable where
 220
 221    sizeOf itbl
 222       = (sum . map (\f -> f itbl))
 223         [fieldSz ptrs, fieldSz nptrs, fieldSz srtlen, fieldSz tipe,
 224          fieldSz code0, fieldSz code1, fieldSz code2, fieldSz code3,
 225          fieldSz code4, fieldSz code5, fieldSz code6, fieldSz code7,
 226          fieldSz code8, fieldSz code9, fieldSz codeA, fieldSz codeB,
 227          fieldSz codeC, fieldSz codeD, fieldSz codeE, fieldSz codeF]
 228
 229    alignment itbl
 230       = (sum . map (\f -> f itbl))
 231         [fieldAl ptrs, fieldAl nptrs, fieldAl srtlen, fieldAl tipe,
 232          fieldAl code0, fieldAl code1, fieldAl code2, fieldAl code3,
 233          fieldAl code4, fieldAl code5, fieldAl code6, fieldAl code7,
 234          fieldAl code8, fieldAl code9, fieldAl codeA, fieldAl codeB,
 235          fieldAl codeC, fieldAl codeD, fieldAl codeE, fieldAl codeF]
 236
 237    poke a0 itbl
 238       = do a1  <- store (ptrs   itbl) (castPtr a0)
 239            a2  <- store (nptrs  itbl) a1
 240            a3  <- store (tipe   itbl) a2
 241            a4  <- store (srtlen itbl) a3
 242            a5  <- store (code0  itbl) a4
 243            a6  <- store (code1  itbl) a5
 244            a7  <- store (code2  itbl) a6
 245            a8  <- store (code3  itbl) a7
 246            a9  <- store (code4  itbl) a8
 247            aA  <- store (code5  itbl) a9
 248            aB  <- store (code6  itbl) aA
 249            aC  <- store (code7  itbl) aB
 250            aD  <- store (code8  itbl) aC
 251            aE  <- store (code9  itbl) aD
 252            aF  <- store (codeA  itbl) aE
 253            a10 <- store (codeB  itbl) aF
 254            a11 <- store (codeC  itbl) a10
 255            a12 <- store (codeD  itbl) a11
 256            a13 <- store (codeE  itbl) a12
 257            a14 <- store (codeF  itbl) a13
 258            return ()
 259
 260    peek a0
 261       = do (a1, ptrs)   <- load (castPtr a0)
 262            (a2, nptrs)  <- load a1
 263            (a3, tipe)   <- load a2
 264            (a4, srtlen) <- load a3
 265            (a5, code0)  <- load a4
 266            (a6, code1)  <- load a5
 267            (a7, code2)  <- load a6
 268            (a8, code3)  <- load a7
 269            (a9, code4)  <- load a8
 270            (aA, code5)  <- load a9
 271            (aB, code6)  <- load aA
 272            (aC, code7)  <- load aB
 273            (aD, code8)  <- load aC
 274            (aE, code9)  <- load aD
 275            (aF, codeA)  <- load aE
 276            (a10,codeB)  <- load aF
 277            (a11,codeC)  <- load a10
 278            (a12,codeD)  <- load a11
 279            (a13,codeE)  <- load a12
 280            (a14,codeF)  <- load a13
 281            return
 282               StgInfoTable {
 283                  ptrs = ptrs, nptrs = nptrs,
 284                  srtlen = srtlen, tipe = tipe,
 285                  code0 = code0, code1 = code1, code2 = code2, code3 = code3,
 286                  code4 = code4, code5 = code5, code6 = code6, code7 = code7,
 287                  code8 = code8, code9 = code9, codeA = codeA, codeB = codeB,
 288                  codeC = codeC, codeD = codeD, codeE = codeE, codeF = codeF
 289               }
 290
 291 fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int
 292 fieldSz sel x = sizeOf (sel x)
 293
 294 fieldAl :: (Storable a, Storable b) => (a -> b) -> a -> Int
 295 fieldAl sel x = alignment (sel x)
 296
 297 store :: Storable a => a -> Ptr a -> IO (Ptr b)
 298 store x addr = do poke addr x
 299                   return (castPtr (addr `plusPtr` sizeOf x))
 300
 301 load :: Storable a => Ptr a -> IO (Ptr b, a)
 302 load addr = do x <- peek addr
 303                return (castPtr (addr `plusPtr` sizeOf x), x)
 304
 305 \end{code}