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
 164             = take 16 (
 165                  [0xB8, byte 0 w32, byte 1 w32,
 166                         byte 2 w32, byte 3 w32,
 167                   0xFF, 0xE0]
 168                  ++ let nops = 0x90 : nops in nops
 169               )
 170      in
 171          insnBytes
 172 #endif
 173
 174
 175 byte :: Int -> Word32 -> Word32
 176 byte 0 w = w .&. 0xFF
 177 byte 1 w = (w `shiftR` 8) .&. 0xFF
 178 byte 2 w = (w `shiftR` 16) .&. 0xFF
 179 byte 3 w = (w `shiftR` 24) .&. 0xFF
 180
 181
 182 vecret_entry 0 = stg_interp_constr1_entry
 183 vecret_entry 1 = stg_interp_constr2_entry
 184 vecret_entry 2 = stg_interp_constr3_entry
 185 vecret_entry 3 = stg_interp_constr4_entry
 186 vecret_entry 4 = stg_interp_constr5_entry
 187 vecret_entry 5 = stg_interp_constr6_entry
 188 vecret_entry 6 = stg_interp_constr7_entry
 189 vecret_entry 7 = stg_interp_constr8_entry
 190
 191 -- entry point for direct returns for created constr itbls
 192 foreign label "stg_interp_constr_entry" stg_interp_constr_entry :: Addr
 193 -- and the 8 vectored ones
 194 foreign label "stg_interp_constr1_entry" stg_interp_constr1_entry :: Addr
 195 foreign label "stg_interp_constr2_entry" stg_interp_constr2_entry :: Addr
 196 foreign label "stg_interp_constr3_entry" stg_interp_constr3_entry :: Addr
 197 foreign label "stg_interp_constr4_entry" stg_interp_constr4_entry :: Addr
 198 foreign label "stg_interp_constr5_entry" stg_interp_constr5_entry :: Addr
 199 foreign label "stg_interp_constr6_entry" stg_interp_constr6_entry :: Addr
 200 foreign label "stg_interp_constr7_entry" stg_interp_constr7_entry :: Addr
 201 foreign label "stg_interp_constr8_entry" stg_interp_constr8_entry :: Addr
 202
 203
 204
 205
 206
 207 -- Ultra-minimalist version specially for constructors
 208 data StgInfoTable = StgInfoTable {
 209    ptrs   :: Word16,
 210    nptrs  :: Word16,
 211    srtlen :: Word16,
 212    tipe   :: Word16,
 213    code0, code1, code2, code3, code4, code5, code6, code7,
 214    code8, code9, codeA, codeB, codeC, codeD, codeE, codeF :: Word8
 215 }
 216
 217
 218 instance Storable StgInfoTable where
 219
 220    sizeOf itbl
 221       = (sum . map (\f -> f itbl))
 222         [fieldSz ptrs, fieldSz nptrs, fieldSz srtlen, fieldSz tipe,
 223          fieldSz code0, fieldSz code1, fieldSz code2, fieldSz code3,
 224          fieldSz code4, fieldSz code5, fieldSz code6, fieldSz code7,
 225          fieldSz code8, fieldSz code9, fieldSz codeA, fieldSz codeB,
 226          fieldSz codeC, fieldSz codeD, fieldSz codeE, fieldSz codeF]
 227
 228    alignment itbl
 229       = (sum . map (\f -> f itbl))
 230         [fieldAl ptrs, fieldAl nptrs, fieldAl srtlen, fieldAl tipe,
 231          fieldAl code0, fieldAl code1, fieldAl code2, fieldAl code3,
 232          fieldAl code4, fieldAl code5, fieldAl code6, fieldAl code7,
 233          fieldAl code8, fieldAl code9, fieldAl codeA, fieldAl codeB,
 234          fieldAl codeC, fieldAl codeD, fieldAl codeE, fieldAl codeF]
 235
 236    poke a0 itbl
 237       = do a1  <- store (ptrs   itbl) (castPtr a0)
 238            a2  <- store (nptrs  itbl) a1
 239            a3  <- store (tipe   itbl) a2
 240            a4  <- store (srtlen itbl) a3
 241            a5  <- store (code0  itbl) a4
 242            a6  <- store (code1  itbl) a5
 243            a7  <- store (code2  itbl) a6
 244            a8  <- store (code3  itbl) a7
 245            a9  <- store (code4  itbl) a8
 246            aA  <- store (code5  itbl) a9
 247            aB  <- store (code6  itbl) aA
 248            aC  <- store (code7  itbl) aB
 249            aD  <- store (code8  itbl) aC
 250            aE  <- store (code9  itbl) aD
 251            aF  <- store (codeA  itbl) aE
 252            a10 <- store (codeB  itbl) aF
 253            a11 <- store (codeC  itbl) a10
 254            a12 <- store (codeD  itbl) a11
 255            a13 <- store (codeE  itbl) a12
 256            a14 <- store (codeF  itbl) a13
 257            return ()
 258
 259    peek a0
 260       = do (a1, ptrs)   <- load (castPtr a0)
 261            (a2, nptrs)  <- load a1
 262            (a3, tipe)   <- load a2
 263            (a4, srtlen) <- load a3
 264            (a5, code0)  <- load a4
 265            (a6, code1)  <- load a5
 266            (a7, code2)  <- load a6
 267            (a8, code3)  <- load a7
 268            (a9, code4)  <- load a8
 269            (aA, code5)  <- load a9
 270            (aB, code6)  <- load aA
 271            (aC, code7)  <- load aB
 272            (aD, code8)  <- load aC
 273            (aE, code9)  <- load aD
 274            (aF, codeA)  <- load aE
 275            (a10,codeB)  <- load aF
 276            (a11,codeC)  <- load a10
 277            (a12,codeD)  <- load a11
 278            (a13,codeE)  <- load a12
 279            (a14,codeF)  <- load a13
 280            return
 281               StgInfoTable {
 282                  ptrs = ptrs, nptrs = nptrs,
 283                  srtlen = srtlen, tipe = tipe,
 284                  code0 = code0, code1 = code1, code2 = code2, code3 = code3,
 285                  code4 = code4, code5 = code5, code6 = code6, code7 = code7,
 286                  code8 = code8, code9 = code9, codeA = codeA, codeB = codeB,
 287                  codeC = codeC, codeD = codeD, codeE = codeE, codeF = codeF
 288               }
 289
 290 fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int
 291 fieldSz sel x = sizeOf (sel x)
 292
 293 fieldAl :: (Storable a, Storable b) => (a -> b) -> a -> Int
 294 fieldAl sel x = alignment (sel x)
 295
 296 store :: Storable a => a -> Ptr a -> IO (Ptr b)
 297 store x addr = do poke addr x
 298                   return (castPtr (addr `plusPtr` sizeOf x))
 299
 300 load :: Storable a => Ptr a -> IO (Ptr b, a)
 301 load addr = do x <- peek addr
 302                return (castPtr (addr `plusPtr` sizeOf x), x)
 303
 304 \end{code}