compiler/ghci/ByteCodeAsm.lhs

   1 %
   2 % (c) The University of Glasgow 2002-2006
   3 %
   4
   5 ByteCodeLink: Bytecode assembler and linker
   6
   7 \begin{code}
   8 {-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
   9
  10 module ByteCodeAsm (
  11         assembleBCOs, assembleBCO,
  12
  13         CompiledByteCode(..),
  14         UnlinkedBCO(..), BCOPtr(..), bcoFreeNames,
  15         SizedSeq, sizeSS, ssElts,
  16         iNTERP_STACK_CHECK_THRESH
  17   ) where
  18
  19 #include "HsVersions.h"
  20
  21 import ByteCodeInstr
  22 import ByteCodeItbls
  23
  24 import Name
  25 import NameSet
  26 import FiniteMap
  27 import Literal
  28 import TyCon
  29 import PrimOp
  30 import Constants
  31 import FastString
  32 import SMRep
  33 import FiniteMap
  34 import Outputable
  35
  36 import Control.Monad    ( foldM )
  37 import Control.Monad.ST ( runST )
  38
  39 import GHC.Word         ( Word(..) )
  40 import Data.Array.MArray
  41 import Data.Array.Unboxed ( listArray )
  42 import Data.Array.Base  ( UArray(..) )
  43 import Data.Array.ST    ( castSTUArray )
  44 import Foreign          ( Word16, free )
  45 import Data.Int         ( Int64 )
  46 import Data.Char        ( ord )
  47
  48 import GHC.Base         ( ByteArray# )
  49 import GHC.IOBase       ( IO(..) )
  50 import GHC.Ptr          ( Ptr(..) )
  51
  52 -- -----------------------------------------------------------------------------
  53 -- Unlinked BCOs
  54
  55 -- CompiledByteCode represents the result of byte-code
  56 -- compiling a bunch of functions and data types
  57
  58 data CompiledByteCode
  59   = ByteCode [UnlinkedBCO] -- Bunch of interpretable bindings
  60              ItblEnv       -- A mapping from DataCons to their itbls
  61
  62 instance Outputable CompiledByteCode where
  63   ppr (ByteCode bcos _) = ppr bcos
  64
  65
  66 data UnlinkedBCO
  67    = UnlinkedBCO {
  68         unlinkedBCOName   :: Name,
  69         unlinkedBCOArity  :: Int,
  70         unlinkedBCOInstrs :: ByteArray#,                         -- insns
  71         unlinkedBCOBitmap :: ByteArray#,                         -- bitmap
  72         unlinkedBCOLits   :: (SizedSeq (Either Word FastString)), -- literals
  73                         -- Either literal words or a pointer to a asciiz
  74                         -- string, denoting a label whose *address* should
  75                         -- be determined at link time
  76         unlinkedBCOPtrs   :: (SizedSeq BCOPtr),         -- ptrs
  77         unlinkedBCOItbls  :: (SizedSeq Name)            -- itbl refs
  78    }
  79
  80 data BCOPtr
  81   = BCOPtrName   Name
  82   | BCOPtrPrimOp PrimOp
  83   | BCOPtrBCO    UnlinkedBCO
  84
  85 -- | Finds external references.  Remember to remove the names
  86 -- defined by this group of BCOs themselves
  87 bcoFreeNames :: UnlinkedBCO -> NameSet
  88 bcoFreeNames bco
  89   = bco_refs bco `minusNameSet` mkNameSet [unlinkedBCOName bco]
  90   where
  91     bco_refs (UnlinkedBCO _ _ _ _ _ ptrs itbls)
  92         = unionManyNameSets (
  93              mkNameSet [ n | BCOPtrName n <- ssElts ptrs ] :
  94              mkNameSet (ssElts itbls) :
  95              map bco_refs [ bco | BCOPtrBCO bco <- ssElts ptrs ]
  96           )
  97
  98 instance Outputable UnlinkedBCO where
  99    ppr (UnlinkedBCO nm arity insns bitmap lits ptrs itbls)
 100       = sep [text "BCO", ppr nm, text "with",
 101              int (sizeSS lits), text "lits",
 102              int (sizeSS ptrs), text "ptrs",
 103              int (sizeSS itbls), text "itbls"]
 104
 105 -- -----------------------------------------------------------------------------
 106 -- The bytecode assembler
 107
 108 -- The object format for bytecodes is: 16 bits for the opcode, and 16
 109 -- for each field -- so the code can be considered a sequence of
 110 -- 16-bit ints.  Each field denotes either a stack offset or number of
 111 -- items on the stack (eg SLIDE), and index into the pointer table (eg
 112 -- PUSH_G), an index into the literal table (eg PUSH_I/D/L), or a
 113 -- bytecode address in this BCO.
 114
 115 -- Top level assembler fn.
 116 assembleBCOs :: [ProtoBCO Name] -> [TyCon] -> IO CompiledByteCode
 117 assembleBCOs proto_bcos tycons
 118   = do  itblenv <- mkITbls tycons
 119         bcos    <- mapM assembleBCO proto_bcos
 120         return (ByteCode bcos itblenv)
 121
 122 assembleBCO :: ProtoBCO Name -> IO UnlinkedBCO
 123 assembleBCO (ProtoBCO nm instrs bitmap bsize arity origin malloced)
 124    = let
 125          -- pass 1: collect up the offsets of the local labels.
 126          -- Remember that the first insn starts at offset 1 since offset 0
 127          -- (eventually) will hold the total # of insns.
 128          label_env = mkLabelEnv emptyFM 1 instrs
 129
 130          mkLabelEnv env i_offset [] = env
 131          mkLabelEnv env i_offset (i:is)
 132             = let new_env
 133                      = case i of LABEL n -> addToFM env n i_offset ; _ -> env
 134               in  mkLabelEnv new_env (i_offset + instrSize16s i) is
 135
 136          findLabel lab
 137             = case lookupFM label_env lab of
 138                  Just bco_offset -> bco_offset
 139                  Nothing -> pprPanic "assembleBCO.findLabel" (int lab)
 140      in
 141      do  -- pass 2: generate the instruction, ptr and nonptr bits
 142          insns <- return emptySS :: IO (SizedSeq Word16)
 143          lits  <- return emptySS :: IO (SizedSeq (Either Word FastString))
 144          ptrs  <- return emptySS :: IO (SizedSeq BCOPtr)
 145          itbls <- return emptySS :: IO (SizedSeq Name)
 146          let init_asm_state = (insns,lits,ptrs,itbls)
 147          (final_insns, final_lits, final_ptrs, final_itbls)
 148             <- mkBits findLabel init_asm_state instrs
 149
 150          let asm_insns = ssElts final_insns
 151              n_insns   = sizeSS final_insns
 152
 153              insns_arr
 154                  | n_insns > 65535 = panic "linkBCO: >= 64k insns in BCO"
 155                  | otherwise = mkInstrArray n_insns asm_insns
 156              insns_barr = case insns_arr of UArray _lo _hi barr -> barr
 157
 158              bitmap_arr = mkBitmapArray bsize bitmap
 159              bitmap_barr = case bitmap_arr of UArray _lo _hi barr -> barr
 160
 161          let ul_bco = UnlinkedBCO nm arity insns_barr bitmap_barr final_lits
 162                                         final_ptrs final_itbls
 163
 164          -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive
 165          -- objects, since they might get run too early.  Disable this until
 166          -- we figure out what to do.
 167          -- when (notNull malloced) (addFinalizer ul_bco (mapM_ zonk malloced))
 168
 169          return ul_bco
 170      where
 171          zonk ptr = do -- putStrLn ("freeing malloc'd block at " ++ show (A# a#))
 172                            free ptr
 173
 174 mkBitmapArray :: Int -> [StgWord] -> UArray Int StgWord
 175 mkBitmapArray bsize bitmap
 176   = listArray (0, length bitmap) (fromIntegral bsize : bitmap)
 177
 178 mkInstrArray :: Int -> [Word16] -> UArray Int Word16
 179 mkInstrArray n_insns asm_insns
 180   = listArray (0, n_insns) (fromIntegral n_insns : asm_insns)
 181
 182 -- instrs nonptrs ptrs itbls
 183 type AsmState = (SizedSeq Word16,
 184                  SizedSeq (Either Word FastString),
 185                  SizedSeq BCOPtr,
 186                  SizedSeq Name)
 187
 188 data SizedSeq a = SizedSeq !Int [a]
 189 emptySS = SizedSeq 0 []
 190
 191 -- Why are these two monadic???
 192 addToSS (SizedSeq n r_xs) x = return (SizedSeq (n+1) (x:r_xs))
 193 addListToSS (SizedSeq n r_xs) xs
 194    = return (SizedSeq (n + length xs) (reverse xs ++ r_xs))
 195
 196 ssElts :: SizedSeq a -> [a]
 197 ssElts (SizedSeq n r_xs) = reverse r_xs
 198
 199 sizeSS :: SizedSeq a -> Int
 200 sizeSS (SizedSeq n r_xs) = n
 201
 202 -- Bring in all the bci_ bytecode constants.
 203 #include "Bytecodes.h"
 204
 205 -- This is where all the action is (pass 2 of the assembler)
 206 mkBits :: (Int -> Int)                  -- label finder
 207        -> AsmState
 208        -> [BCInstr]                     -- instructions (in)
 209        -> IO AsmState
 210
 211 mkBits findLabel st proto_insns
 212   = foldM doInstr st proto_insns
 213     where
 214        doInstr :: AsmState -> BCInstr -> IO AsmState
 215        doInstr st i
 216           = case i of
 217                STKCHECK  n        -> instr2 st bci_STKCHECK n
 218                PUSH_L    o1       -> instr2 st bci_PUSH_L o1
 219                PUSH_LL   o1 o2    -> instr3 st bci_PUSH_LL o1 o2
 220                PUSH_LLL  o1 o2 o3 -> instr4 st bci_PUSH_LLL o1 o2 o3
 221                PUSH_G    nm       -> do (p, st2) <- ptr st (BCOPtrName nm)
 222                                         instr2 st2 bci_PUSH_G p
 223                PUSH_PRIMOP op     -> do (p, st2) <- ptr st (BCOPtrPrimOp op)
 224                                         instr2 st2 bci_PUSH_G p
 225                PUSH_BCO proto     -> do ul_bco <- assembleBCO proto
 226                                         (p, st2) <- ptr st (BCOPtrBCO ul_bco)
 227                                         instr2 st2 bci_PUSH_G p
 228                PUSH_ALTS proto    -> do ul_bco <- assembleBCO proto
 229                                         (p, st2) <- ptr st (BCOPtrBCO ul_bco)
 230                                         instr2 st2 bci_PUSH_ALTS p
 231                PUSH_ALTS_UNLIFTED proto pk -> do
 232                                         ul_bco <- assembleBCO proto
 233                                         (p, st2) <- ptr st (BCOPtrBCO ul_bco)
 234                                         instr2 st2 (push_alts pk) p
 235                PUSH_UBX  (Left lit) nws
 236                                   -> do (np, st2) <- literal st lit
 237                                         instr3 st2 bci_PUSH_UBX np nws
 238                PUSH_UBX  (Right aa) nws
 239                                   -> do (np, st2) <- addr st aa
 240                                         instr3 st2 bci_PUSH_UBX np nws
 241
 242                PUSH_APPLY_N         -> do instr1 st bci_PUSH_APPLY_N
 243                PUSH_APPLY_V         -> do instr1 st bci_PUSH_APPLY_V
 244                PUSH_APPLY_F         -> do instr1 st bci_PUSH_APPLY_F
 245                PUSH_APPLY_D         -> do instr1 st bci_PUSH_APPLY_D
 246                PUSH_APPLY_L         -> do instr1 st bci_PUSH_APPLY_L
 247                PUSH_APPLY_P         -> do instr1 st bci_PUSH_APPLY_P
 248                PUSH_APPLY_PP        -> do instr1 st bci_PUSH_APPLY_PP
 249                PUSH_APPLY_PPP       -> do instr1 st bci_PUSH_APPLY_PPP
 250                PUSH_APPLY_PPPP      -> do instr1 st bci_PUSH_APPLY_PPPP
 251                PUSH_APPLY_PPPPP     -> do instr1 st bci_PUSH_APPLY_PPPPP
 252                PUSH_APPLY_PPPPPP    -> do instr1 st bci_PUSH_APPLY_PPPPPP
 253
 254                SLIDE     n by     -> instr3 st bci_SLIDE n by
 255                ALLOC_AP  n        -> instr2 st bci_ALLOC_AP n
 256                ALLOC_PAP arity n  -> instr3 st bci_ALLOC_PAP arity n
 257                MKAP      off sz   -> instr3 st bci_MKAP off sz
 258                MKPAP     off sz   -> instr3 st bci_MKPAP off sz
 259                UNPACK    n        -> instr2 st bci_UNPACK n
 260                PACK      dcon sz  -> do (itbl_no,st2) <- itbl st dcon
 261                                         instr3 st2 bci_PACK itbl_no sz
 262                LABEL     lab      -> return st
 263                TESTLT_I  i l      -> do (np, st2) <- int st i
 264                                         instr3 st2 bci_TESTLT_I np (findLabel l)
 265                TESTEQ_I  i l      -> do (np, st2) <- int st i
 266                                         instr3 st2 bci_TESTEQ_I np (findLabel l)
 267                TESTLT_F  f l      -> do (np, st2) <- float st f
 268                                         instr3 st2 bci_TESTLT_F np (findLabel l)
 269                TESTEQ_F  f l      -> do (np, st2) <- float st f
 270                                         instr3 st2 bci_TESTEQ_F np (findLabel l)
 271                TESTLT_D  d l      -> do (np, st2) <- double st d
 272                                         instr3 st2 bci_TESTLT_D np (findLabel l)
 273                TESTEQ_D  d l      -> do (np, st2) <- double st d
 274                                         instr3 st2 bci_TESTEQ_D np (findLabel l)
 275                TESTLT_P  i l      -> instr3 st bci_TESTLT_P i (findLabel l)
 276                TESTEQ_P  i l      -> instr3 st bci_TESTEQ_P i (findLabel l)
 277                CASEFAIL           -> instr1 st bci_CASEFAIL
 278                SWIZZLE   stkoff n -> instr3 st bci_SWIZZLE stkoff n
 279                JMP       l        -> instr2 st bci_JMP (findLabel l)
 280                ENTER              -> instr1 st bci_ENTER
 281                RETURN             -> instr1 st bci_RETURN
 282                RETURN_UBX rep     -> instr1 st (return_ubx rep)
 283                CCALL off m_addr   -> do (np, st2) <- addr st m_addr
 284                                         instr3 st2 bci_CCALL off np
 285
 286        i2s :: Int -> Word16
 287        i2s = fromIntegral
 288
 289        instr1 (st_i0,st_l0,st_p0,st_I0) i1
 290           = do st_i1 <- addToSS st_i0 i1
 291                return (st_i1,st_l0,st_p0,st_I0)
 292
 293        instr2 (st_i0,st_l0,st_p0,st_I0) i1 i2
 294           = do st_i1 <- addToSS st_i0 (i2s i1)
 295                st_i2 <- addToSS st_i1 (i2s i2)
 296                return (st_i2,st_l0,st_p0,st_I0)
 297
 298        instr3 (st_i0,st_l0,st_p0,st_I0) i1 i2 i3
 299           = do st_i1 <- addToSS st_i0 (i2s i1)
 300                st_i2 <- addToSS st_i1 (i2s i2)
 301                st_i3 <- addToSS st_i2 (i2s i3)
 302                return (st_i3,st_l0,st_p0,st_I0)
 303
 304        instr4 (st_i0,st_l0,st_p0,st_I0) i1 i2 i3 i4
 305           = do st_i1 <- addToSS st_i0 (i2s i1)
 306                st_i2 <- addToSS st_i1 (i2s i2)
 307                st_i3 <- addToSS st_i2 (i2s i3)
 308                st_i4 <- addToSS st_i3 (i2s i4)
 309                return (st_i4,st_l0,st_p0,st_I0)
 310
 311        float (st_i0,st_l0,st_p0,st_I0) f
 312           = do let ws = mkLitF f
 313                st_l1 <- addListToSS st_l0 (map Left ws)
 314                return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
 315
 316        double (st_i0,st_l0,st_p0,st_I0) d
 317           = do let ws = mkLitD d
 318                st_l1 <- addListToSS st_l0 (map Left ws)
 319                return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
 320
 321        int (st_i0,st_l0,st_p0,st_I0) i
 322           = do let ws = mkLitI i
 323                st_l1 <- addListToSS st_l0 (map Left ws)
 324                return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
 325
 326        int64 (st_i0,st_l0,st_p0,st_I0) i
 327           = do let ws = mkLitI64 i
 328                st_l1 <- addListToSS st_l0 (map Left ws)
 329                return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
 330
 331        addr (st_i0,st_l0,st_p0,st_I0) a
 332           = do let ws = mkLitPtr a
 333                st_l1 <- addListToSS st_l0 (map Left ws)
 334                return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
 335
 336        litlabel (st_i0,st_l0,st_p0,st_I0) fs
 337           = do st_l1 <- addListToSS st_l0 [Right fs]
 338                return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
 339
 340        ptr (st_i0,st_l0,st_p0,st_I0) p
 341           = do st_p1 <- addToSS st_p0 p
 342                return (sizeSS st_p0, (st_i0,st_l0,st_p1,st_I0))
 343
 344        itbl (st_i0,st_l0,st_p0,st_I0) dcon
 345           = do st_I1 <- addToSS st_I0 (getName dcon)
 346                return (sizeSS st_I0, (st_i0,st_l0,st_p0,st_I1))
 347
 348        literal st (MachLabel fs _) = litlabel st fs
 349        literal st (MachWord w)     = int st (fromIntegral w)
 350        literal st (MachInt j)      = int st (fromIntegral j)
 351        literal st (MachFloat r)    = float st (fromRational r)
 352        literal st (MachDouble r)   = double st (fromRational r)
 353        literal st (MachChar c)     = int st (ord c)
 354        literal st (MachInt64 ii)   = int64 st (fromIntegral ii)
 355        literal st (MachWord64 ii)  = int64 st (fromIntegral ii)
 356        literal st other            = pprPanic "ByteCodeLink.literal" (ppr other)
 357
 358
 359 push_alts NonPtrArg = bci_PUSH_ALTS_N
 360 push_alts FloatArg  = bci_PUSH_ALTS_F
 361 push_alts DoubleArg = bci_PUSH_ALTS_D
 362 push_alts VoidArg   = bci_PUSH_ALTS_V
 363 push_alts LongArg   = bci_PUSH_ALTS_L
 364 push_alts PtrArg    = bci_PUSH_ALTS_P
 365
 366 return_ubx NonPtrArg = bci_RETURN_N
 367 return_ubx FloatArg  = bci_RETURN_F
 368 return_ubx DoubleArg = bci_RETURN_D
 369 return_ubx VoidArg   = bci_RETURN_V
 370 return_ubx LongArg   = bci_RETURN_L
 371 return_ubx PtrArg    = bci_RETURN_P
 372
 373
 374 -- The size in 16-bit entities of an instruction.
 375 instrSize16s :: BCInstr -> Int
 376 instrSize16s instr
 377    = case instr of
 378         STKCHECK{}              -> 2
 379         PUSH_L{}                -> 2
 380         PUSH_LL{}               -> 3
 381         PUSH_LLL{}              -> 4
 382         PUSH_G{}                -> 2
 383         PUSH_PRIMOP{}           -> 2
 384         PUSH_BCO{}              -> 2
 385         PUSH_ALTS{}             -> 2
 386         PUSH_ALTS_UNLIFTED{}    -> 2
 387         PUSH_UBX{}              -> 3
 388         PUSH_APPLY_N{}          -> 1
 389         PUSH_APPLY_V{}          -> 1
 390         PUSH_APPLY_F{}          -> 1
 391         PUSH_APPLY_D{}          -> 1
 392         PUSH_APPLY_L{}          -> 1
 393         PUSH_APPLY_P{}          -> 1
 394         PUSH_APPLY_PP{}         -> 1
 395         PUSH_APPLY_PPP{}        -> 1
 396         PUSH_APPLY_PPPP{}       -> 1
 397         PUSH_APPLY_PPPPP{}      -> 1
 398         PUSH_APPLY_PPPPPP{}     -> 1
 399         SLIDE{}                 -> 3
 400         ALLOC_AP{}              -> 2
 401         ALLOC_PAP{}             -> 3
 402         MKAP{}                  -> 3
 403         MKPAP{}                 -> 3
 404         UNPACK{}                -> 2
 405         PACK{}                  -> 3
 406         LABEL{}                 -> 0    -- !!
 407         TESTLT_I{}              -> 3
 408         TESTEQ_I{}              -> 3
 409         TESTLT_F{}              -> 3
 410         TESTEQ_F{}              -> 3
 411         TESTLT_D{}              -> 3
 412         TESTEQ_D{}              -> 3
 413         TESTLT_P{}              -> 3
 414         TESTEQ_P{}              -> 3
 415         JMP{}                   -> 2
 416         CASEFAIL{}              -> 1
 417         ENTER{}                 -> 1
 418         RETURN{}                -> 1
 419         RETURN_UBX{}            -> 1
 420         CCALL{}                 -> 3
 421         SWIZZLE{}               -> 3
 422
 423 -- Make lists of host-sized words for literals, so that when the
 424 -- words are placed in memory at increasing addresses, the
 425 -- bit pattern is correct for the host's word size and endianness.
 426 mkLitI   :: Int    -> [Word]
 427 mkLitF   :: Float  -> [Word]
 428 mkLitD   :: Double -> [Word]
 429 mkLitPtr :: Ptr () -> [Word]
 430 mkLitI64 :: Int64  -> [Word]
 431
 432 mkLitF f
 433    = runST (do
 434         arr <- newArray_ ((0::Int),0)
 435         writeArray arr 0 f
 436         f_arr <- castSTUArray arr
 437         w0 <- readArray f_arr 0
 438         return [w0 :: Word]
 439      )
 440
 441 mkLitD d
 442    | wORD_SIZE == 4
 443    = runST (do
 444         arr <- newArray_ ((0::Int),1)
 445         writeArray arr 0 d
 446         d_arr <- castSTUArray arr
 447         w0 <- readArray d_arr 0
 448         w1 <- readArray d_arr 1
 449         return [w0 :: Word, w1]
 450      )
 451    | wORD_SIZE == 8
 452    = runST (do
 453         arr <- newArray_ ((0::Int),0)
 454         writeArray arr 0 d
 455         d_arr <- castSTUArray arr
 456         w0 <- readArray d_arr 0
 457         return [w0 :: Word]
 458      )
 459
 460 mkLitI64 ii
 461    | wORD_SIZE == 4
 462    = runST (do
 463         arr <- newArray_ ((0::Int),1)
 464         writeArray arr 0 ii
 465         d_arr <- castSTUArray arr
 466         w0 <- readArray d_arr 0
 467         w1 <- readArray d_arr 1
 468         return [w0 :: Word,w1]
 469      )
 470    | wORD_SIZE == 8
 471    = runST (do
 472         arr <- newArray_ ((0::Int),0)
 473         writeArray arr 0 ii
 474         d_arr <- castSTUArray arr
 475         w0 <- readArray d_arr 0
 476         return [w0 :: Word]
 477      )
 478
 479 mkLitI i
 480    = runST (do
 481         arr <- newArray_ ((0::Int),0)
 482         writeArray arr 0 i
 483         i_arr <- castSTUArray arr
 484         w0 <- readArray i_arr 0
 485         return [w0 :: Word]
 486      )
 487
 488 mkLitPtr a
 489    = runST (do
 490         arr <- newArray_ ((0::Int),0)
 491         writeArray arr 0 a
 492         a_arr <- castSTUArray arr
 493         w0 <- readArray a_arr 0
 494         return [w0 :: Word]
 495      )
 496
 497 iNTERP_STACK_CHECK_THRESH = (INTERP_STACK_CHECK_THRESH :: Int)
 498 \end{code}