compiler/ghci/ByteCodeAsm.lhs

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