compiler/ghci/ByteCodeItbls.lhs

   1 %
   2 % (c) The University of Glasgow 2000-2006
   3 %
   4 ByteCodeItbls: Generate infotables for interpreter-made bytecodes
   5
   6 \begin{code}
   7 {-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
   8
   9 {-# OPTIONS -w #-}
  10 -- The above warning supression flag is a temporary kludge.
  11 -- While working on this module you are encouraged to remove it and fix
  12 -- any warnings in the module. See
  13 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  14 -- for details
  15
  16 module ByteCodeItbls ( ItblEnv, ItblPtr(..), itblCode, mkITbls
  17                      , StgInfoTable(..)
  18                      ) where
  19
  20 #include "HsVersions.h"
  21
  22 import ByteCodeFFI      ( newExec )
  23 import Name             ( Name, getName )
  24 import NameEnv
  25 import SMRep            ( typeCgRep )
  26 import DataCon          ( DataCon, dataConRepArgTys, dataConIdentity )
  27 import TyCon            ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )
  28 import Constants        ( mIN_PAYLOAD_SIZE, wORD_SIZE )
  29 import CgHeapery        ( mkVirtHeapOffsets )
  30 import FastString       ( FastString(..) )
  31 import Util             ( lengthIs, listLengthCmp )
  32 import Outputable
  33
  34 import Foreign
  35 import Foreign.C
  36 import Foreign.C.String
  37 import Data.Bits        ( Bits(..), shiftR )
  38
  39 import GHC.Exts         ( Int(I#), addr2Int# )
  40 import GHC.Ptr          ( Ptr(..) )
  41
  42 import Debug.Trace
  43 import Text.Printf
  44 \end{code}
  45
  46 %************************************************************************
  47 %*                                                                      *
  48 \subsection{Manufacturing of info tables for DataCons}
  49 %*                                                                      *
  50 %************************************************************************
  51
  52 \begin{code}
  53 newtype ItblPtr = ItblPtr (Ptr ()) deriving Show
  54
  55 itblCode :: ItblPtr -> Ptr ()
  56 itblCode (ItblPtr ptr)
  57    = (castPtr ptr)
  58 #ifdef GHCI_TABLES_NEXT_TO_CODE
  59                  `plusPtr` conInfoTableSizeB
  60 #endif
  61
  62 -- XXX bogus
  63 conInfoTableSizeB = 3 * wORD_SIZE
  64
  65 type ItblEnv = NameEnv (Name, ItblPtr)
  66         -- We need the Name in the range so we know which
  67         -- elements to filter out when unloading a module
  68
  69 mkItblEnv :: [(Name,ItblPtr)] -> ItblEnv
  70 mkItblEnv pairs = mkNameEnv [(n, (n,p)) | (n,p) <- pairs]
  71
  72
  73 -- Make info tables for the data decls in this module
  74 mkITbls :: [TyCon] -> IO ItblEnv
  75 mkITbls [] = return emptyNameEnv
  76 mkITbls (tc:tcs) = do itbls  <- mkITbl tc
  77                       itbls2 <- mkITbls tcs
  78                       return (itbls `plusNameEnv` itbls2)
  79
  80 mkITbl :: TyCon -> IO ItblEnv
  81 mkITbl tc
  82    | not (isDataTyCon tc)
  83    = return emptyNameEnv
  84    | dcs `lengthIs` n -- paranoia; this is an assertion.
  85    = make_constr_itbls dcs
  86      where
  87         dcs = tyConDataCons tc
  88         n   = tyConFamilySize tc
  89
  90 #include "../includes/ClosureTypes.h"
  91 cONSTR :: Int   -- Defined in ClosureTypes.h
  92 cONSTR = CONSTR
  93
  94 -- Assumes constructors are numbered from zero, not one
  95 make_constr_itbls :: [DataCon] -> IO ItblEnv
  96 make_constr_itbls cons
  97    = do is <- mapM mk_dirret_itbl (zip cons [0..])
  98         return (mkItblEnv is)
  99      where
 100         mk_dirret_itbl (dcon, conNo)
 101            = mk_itbl dcon conNo stg_interp_constr_entry
 102
 103         mk_itbl :: DataCon -> Int -> Ptr () -> IO (Name,ItblPtr)
 104         mk_itbl dcon conNo entry_addr = do
 105            let rep_args = [ (typeCgRep arg,arg) | arg <- dataConRepArgTys dcon ]
 106                (tot_wds, ptr_wds, _) = mkVirtHeapOffsets False{-not a THUNK-} rep_args
 107
 108                ptrs  = ptr_wds
 109                nptrs = tot_wds - ptr_wds
 110                nptrs_really
 111                   | ptrs + nptrs >= mIN_PAYLOAD_SIZE = nptrs
 112                   | otherwise = mIN_PAYLOAD_SIZE - ptrs
 113                code = mkJumpToAddr entry_addr
 114                itbl  = StgInfoTable {
 115 #ifndef GHCI_TABLES_NEXT_TO_CODE
 116                            entry = entry_addr,
 117 #endif
 118                            ptrs  = fromIntegral ptrs,
 119                            nptrs = fromIntegral nptrs_really,
 120                            tipe  = fromIntegral cONSTR,
 121                            srtlen = fromIntegral conNo
 122 #ifdef GHCI_TABLES_NEXT_TO_CODE
 123                          , code  = code
 124 #endif
 125                         }
 126            qNameCString <- newArray0 0 $ dataConIdentity dcon
 127            let conInfoTbl = StgConInfoTable {
 128                                  conDesc = qNameCString,
 129                                  infoTable = itbl
 130                             }
 131                -- Make a piece of code to jump to "entry_label".
 132                -- This is the only arch-dependent bit.
 133            addrCon <- newExec [conInfoTbl]
 134                     --putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl))
 135                     --putStrLn ("# ptrs  of itbl is " ++ show ptrs)
 136                     --putStrLn ("# nptrs of itbl is " ++ show nptrs_really)
 137            return (getName dcon, ItblPtr (castFunPtrToPtr addrCon))
 138
 139
 140 -- Make code which causes a jump to the given address.  This is the
 141 -- only arch-dependent bit of the itbl story.  The returned list is
 142 -- itblCodeLength elements (bytes) long.
 143
 144 -- For sparc_TARGET_ARCH, i386_TARGET_ARCH, etc.
 145 #include "nativeGen/NCG.h"
 146
 147 itblCodeLength :: Int
 148 itblCodeLength = length (mkJumpToAddr undefined)
 149
 150 mkJumpToAddr :: Ptr () -> [ItblCode]
 151
 152 ptrToInt (Ptr a#) = I# (addr2Int# a#)
 153
 154 #if sparc_TARGET_ARCH
 155 -- After some consideration, we'll try this, where
 156 -- 0x55555555 stands in for the address to jump to.
 157 -- According to ghc/includes/MachRegs.h, %g3 is very
 158 -- likely indeed to be baggable.
 159 --
 160 --   0000 07155555              sethi   %hi(0x55555555), %g3
 161 --   0004 8610E155              or      %g3, %lo(0x55555555), %g3
 162 --   0008 81C0C000              jmp     %g3
 163 --   000c 01000000              nop
 164
 165 type ItblCode = Word32
 166 mkJumpToAddr a
 167    = let w32 = fromIntegral (ptrToInt a)
 168
 169          hi22, lo10 :: Word32 -> Word32
 170          lo10 x = x .&. 0x3FF
 171          hi22 x = (x `shiftR` 10) .&. 0x3FFFF
 172
 173      in  [ 0x07000000 .|. (hi22 w32),
 174            0x8610E000 .|. (lo10 w32),
 175            0x81C0C000,
 176            0x01000000 ]
 177
 178 #elif powerpc_TARGET_ARCH
 179 -- We'll use r12, for no particular reason.
 180 -- 0xDEADBEEF stands for the adress:
 181 -- 3D80DEAD lis r12,0xDEAD
 182 -- 618CBEEF ori r12,r12,0xBEEF
 183 -- 7D8903A6 mtctr r12
 184 -- 4E800420 bctr
 185
 186 type ItblCode = Word32
 187 mkJumpToAddr a =
 188     let w32 = fromIntegral (ptrToInt a)
 189         hi16 x = (x `shiftR` 16) .&. 0xFFFF
 190         lo16 x = x .&. 0xFFFF
 191     in  [
 192         0x3D800000 .|. hi16 w32,
 193         0x618C0000 .|. lo16 w32,
 194         0x7D8903A6, 0x4E800420
 195         ]
 196
 197 #elif i386_TARGET_ARCH
 198 -- Let the address to jump to be 0xWWXXYYZZ.
 199 -- Generate   movl $0xWWXXYYZZ,%eax  ;  jmp *%eax
 200 -- which is
 201 -- B8 ZZ YY XX WW FF E0
 202
 203 type ItblCode = Word8
 204 mkJumpToAddr a
 205    = let w32 = fromIntegral (ptrToInt a) :: Word32
 206          insnBytes :: [Word8]
 207          insnBytes
 208             = [0xB8, byte0 w32, byte1 w32,
 209                      byte2 w32, byte3 w32,
 210                0xFF, 0xE0]
 211      in
 212          insnBytes
 213
 214 #elif x86_64_TARGET_ARCH
 215 -- Generates:
 216 --      jmpq *.L1(%rip)
 217 --      .align 8
 218 -- .L1:
 219 --      .quad <addr>
 220 --
 221 -- We need a full 64-bit pointer (we can't assume the info table is
 222 -- allocated in low memory).  Assuming the info pointer is aligned to
 223 -- an 8-byte boundary, the addr will also be aligned.
 224
 225 type ItblCode = Word8
 226 mkJumpToAddr a
 227    = let w64 = fromIntegral (ptrToInt a) :: Word64
 228          insnBytes :: [Word8]
 229          insnBytes
 230             = [0xff, 0x25, 0x02, 0x00, 0x00, 0x00, 0x00, 0x00,
 231                byte0 w64, byte1 w64, byte2 w64, byte3 w64,
 232                byte4 w64, byte5 w64, byte6 w64, byte7 w64]
 233      in
 234          insnBytes
 235
 236 #elif alpha_TARGET_ARCH
 237 type ItblCode = Word32
 238 mkJumpToAddr a
 239     = [ 0xc3800000      -- br   at, .+4
 240       , 0xa79c000c      -- ldq  at, 12(at)
 241       , 0x6bfc0000      -- jmp  (at)    # with zero hint -- oh well
 242       , 0x47ff041f      -- nop
 243       , fromIntegral (w64 .&. 0x0000FFFF)
 244       , fromIntegral ((w64 `shiftR` 32) .&. 0x0000FFFF) ]
 245     where w64 = fromIntegral (ptrToInt a) :: Word64
 246
 247 #else
 248 type ItblCode = Word32
 249 mkJumpToAddr a
 250     = undefined
 251 #endif
 252
 253
 254 byte0, byte1, byte2, byte3, byte4, byte5, byte6, byte7
 255    :: (Integral w, Bits w) => w -> Word8
 256 byte0 w = fromIntegral w
 257 byte1 w = fromIntegral (w `shiftR` 8)
 258 byte2 w = fromIntegral (w `shiftR` 16)
 259 byte3 w = fromIntegral (w `shiftR` 24)
 260 byte4 w = fromIntegral (w `shiftR` 32)
 261 byte5 w = fromIntegral (w `shiftR` 40)
 262 byte6 w = fromIntegral (w `shiftR` 48)
 263 byte7 w = fromIntegral (w `shiftR` 56)
 264
 265
 266 #ifndef __HADDOCK__
 267 -- entry point for direct returns for created constr itbls
 268 foreign import ccall "&stg_interp_constr_entry" stg_interp_constr_entry :: Ptr ()
 269 #endif
 270
 271
 272
 273
 274 -- Ultra-minimalist version specially for constructors
 275 #if SIZEOF_VOID_P == 8
 276 type HalfWord = Word32
 277 #else
 278 type HalfWord = Word16
 279 #endif
 280
 281 data StgConInfoTable = StgConInfoTable {
 282    conDesc   :: Ptr Word8,
 283    infoTable :: StgInfoTable
 284 }
 285
 286 instance Storable StgConInfoTable where
 287    sizeOf conInfoTable
 288       = sum [ sizeOf (conDesc conInfoTable)
 289             , sizeOf (infoTable conInfoTable) ]
 290    alignment conInfoTable = SIZEOF_VOID_P
 291    peek ptr
 292       = runState (castPtr ptr) $ do
 293 #ifdef GHCI_TABLES_NEXT_TO_CODE
 294            desc <- load
 295 #endif
 296            itbl <- load
 297 #ifndef GHCI_TABLES_NEXT_TO_CODE
 298            desc <- load
 299 #endif
 300            return
 301               StgConInfoTable
 302               {
 303 #ifdef GHCI_TABLES_NEXT_TO_CODE
 304                 conDesc   = castPtr $ ptr `plusPtr` conInfoTableSizeB `plusPtr` desc
 305 #else
 306                 conDesc   = desc
 307 #endif
 308               , infoTable = itbl
 309               }
 310    poke ptr itbl
 311       = runState (castPtr ptr) $ do
 312 #ifdef GHCI_TABLES_NEXT_TO_CODE
 313            store (conDesc itbl `minusPtr` (ptr `plusPtr` conInfoTableSizeB))
 314 #endif
 315            store (infoTable itbl)
 316 #ifndef GHCI_TABLES_NEXT_TO_CODE
 317            store (conDesc itbl)
 318 #endif
 319
 320 data StgInfoTable = StgInfoTable {
 321 #ifndef GHCI_TABLES_NEXT_TO_CODE
 322    entry  :: Ptr (),
 323 #endif
 324    ptrs   :: HalfWord,
 325    nptrs  :: HalfWord,
 326    tipe   :: HalfWord,
 327    srtlen :: HalfWord
 328 #ifdef GHCI_TABLES_NEXT_TO_CODE
 329  , code   :: [ItblCode]
 330 #endif
 331   }
 332
 333 instance Storable StgInfoTable where
 334
 335    sizeOf itbl
 336       = sum
 337         [
 338 #ifndef GHCI_TABLES_NEXT_TO_CODE
 339          fieldSz entry itbl,
 340 #endif
 341          fieldSz ptrs itbl,
 342          fieldSz nptrs itbl,
 343          fieldSz tipe itbl,
 344          fieldSz srtlen itbl
 345 #ifdef GHCI_TABLES_NEXT_TO_CODE
 346         ,fieldSz (head.code) itbl * itblCodeLength
 347 #endif
 348         ]
 349
 350    alignment itbl
 351       = SIZEOF_VOID_P
 352
 353    poke a0 itbl
 354       = runState (castPtr a0)
 355       $ do
 356 #ifndef GHCI_TABLES_NEXT_TO_CODE
 357            store (entry  itbl)
 358 #endif
 359            store (ptrs   itbl)
 360            store (nptrs  itbl)
 361            store (tipe   itbl)
 362            store (srtlen itbl)
 363 #ifdef GHCI_TABLES_NEXT_TO_CODE
 364            sequence_ (map store (code itbl))
 365 #endif
 366
 367    peek a0
 368       = runState (castPtr a0)
 369       $ do
 370 #ifndef GHCI_TABLES_NEXT_TO_CODE
 371            entry  <- load
 372 #endif
 373            ptrs   <- load
 374            nptrs  <- load
 375            tipe   <- load
 376            srtlen <- load
 377 #ifdef GHCI_TABLES_NEXT_TO_CODE
 378            code   <- sequence (replicate itblCodeLength load)
 379 #endif
 380            return
 381               StgInfoTable {
 382 #ifndef GHCI_TABLES_NEXT_TO_CODE
 383                  entry  = entry,
 384 #endif
 385                  ptrs   = ptrs,
 386                  nptrs  = nptrs,
 387                  tipe   = tipe,
 388                  srtlen = srtlen
 389 #ifdef GHCI_TABLES_NEXT_TO_CODE
 390                 ,code   = code
 391 #endif
 392               }
 393
 394 fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int
 395 fieldSz sel x = sizeOf (sel x)
 396
 397 newtype State s m a = State (s -> m (s, a))
 398
 399 instance Monad m => Monad (State s m) where
 400   return a      = State (\s -> return (s, a))
 401   State m >>= k = State (\s -> m s >>= \(s', a) -> case k a of State n -> n s')
 402   fail str      = State (\s -> fail str)
 403
 404 class (Monad m, Monad (t m)) => MonadT t m where
 405   lift :: m a -> t m a
 406
 407 instance Monad m => MonadT (State s) m where
 408   lift m        = State (\s -> m >>= \a -> return (s, a))
 409
 410 runState :: (Monad m) => s -> State s m a -> m a
 411 runState s (State m) = m s >>= return . snd
 412
 413 type PtrIO = State (Ptr Word8) IO
 414
 415 advance :: Storable a => PtrIO (Ptr a)
 416 advance = State adv where
 417     adv addr = case castPtr addr of { addrCast -> return
 418         (addr `plusPtr` sizeOfPointee addrCast, addrCast) }
 419
 420 sizeOfPointee :: (Storable a) => Ptr a -> Int
 421 sizeOfPointee addr = sizeOf (typeHack addr)
 422     where typeHack = undefined :: Ptr a -> a
 423
 424 store :: Storable a => a -> PtrIO ()
 425 store x = do addr <- advance
 426              lift (poke addr x)
 427
 428 load :: Storable a => PtrIO a
 429 load = do addr <- advance
 430           lift (peek addr)
 431
 432 \end{code}