ghc/compiler/ghci/ByteCodeGen.lhs

   1 %
   2 % (c) The University of Glasgow 2000
   3 %
   4 \section[ByteCodeGen]{Generate bytecode from Core}
   5
   6 \begin{code}
   7 module ByteCodeGen ( byteCodeGen, assembleBCO ) where
   8
   9 #include "HsVersions.h"
  10
  11 import Outputable
  12 import Name             ( Name, getName )
  13 import Id               ( Id, idType, isDataConId_maybe )
  14 import OrdList          ( OrdList, consOL, snocOL, appOL, unitOL,
  15                           nilOL, toOL, concatOL, fromOL )
  16 import FiniteMap        ( FiniteMap, addListToFM, listToFM,
  17                           addToFM, lookupFM, fmToList, emptyFM )
  18 import CoreSyn
  19 import Literal          ( Literal(..) )
  20 import PrimRep          ( PrimRep(..) )
  21 import CoreFVs          ( freeVars )
  22 import Type             ( typePrimRep )
  23 import DataCon          ( DataCon, dataConTag, fIRST_TAG )
  24 import Util             ( zipEqual, zipWith4Equal, naturalMergeSortLe )
  25 import VarSet           ( VarSet, varSetElems )
  26 import PrimRep          ( getPrimRepSize, isFollowableRep )
  27 import Constants        ( wORD_SIZE )
  28
  29 import Foreign          ( Addr, Word16, Word32, nullAddr )
  30 import ST               ( runST )
  31 import MutableArray     ( readWord32Array,
  32                           newFloatArray, writeFloatArray,
  33                           newDoubleArray, writeDoubleArray,
  34                           newIntArray, writeIntArray,
  35                           newAddrArray, writeAddrArray )
  36 \end{code}
  37
  38 Entry point.
  39
  40 \begin{code}
  41 byteCodeGen :: [CoreBind] -> [ProtoBCO Name]
  42 byteCodeGen binds
  43    = let flatBinds = concatMap getBind binds
  44          getBind (NonRec bndr rhs) = [(bndr, freeVars rhs)]
  45          getBind (Rec binds)       = [(bndr, freeVars rhs) | (bndr,rhs) <- binds]
  46          final_state = runBc (BcM_State [] 0)
  47                              (mapBc schemeR flatBinds `thenBc_` returnBc ())
  48      in
  49          case final_state of
  50             BcM_State bcos final_ctr -> bcos
  51 \end{code}
  52
  53
  54 %************************************************************************
  55 %*                                                                      *
  56 \subsection{Bytecodes, and Outputery.}
  57 %*                                                                      *
  58 %************************************************************************
  59
  60 \begin{code}
  61
  62 type LocalLabel = Int
  63
  64 data BCInstr
  65    -- Messing with the stack
  66    = ARGCHECK  Int
  67    | PUSH_L    Int{-size-} Int{-offset-}
  68    | PUSH_G    Name
  69    | PUSHT_I   Int
  70    | PUSHT_F   Float
  71    | PUSHT_D   Double
  72    | PUSHU_I   Int
  73    | PUSHU_F   Float
  74    | PUSHU_D   Double
  75    | SLIDE     Int{-this many-} Int{-down by this much-}
  76    -- To do with the heap
  77    | ALLOC     Int
  78    | MKAP      Int{-place ptr to heap this far down stack-} Int{-# words-}
  79    | UNPACK    Int
  80    | PACK      DataCon Int
  81    -- For doing case trees
  82    | LABEL     LocalLabel
  83    | TESTLT_I  Int    LocalLabel
  84    | TESTEQ_I  Int    LocalLabel
  85    | TESTLT_F  Float  LocalLabel
  86    | TESTEQ_F  Float  LocalLabel
  87    | TESTLT_D  Double LocalLabel
  88    | TESTEQ_D  Double LocalLabel
  89    | TESTLT_P  Int    LocalLabel
  90    | TESTEQ_P  Int    LocalLabel
  91    | CASEFAIL
  92    -- To Infinity And Beyond
  93    | ENTER
  94
  95 instance Outputable BCInstr where
  96    ppr (ARGCHECK n)          = text "ARGCHECK" <+> int n
  97    ppr (PUSH_L sz offset)    = text "PUSH_L  " <+> int sz <+> int offset
  98    ppr (PUSH_G nm)           = text "PUSH_G  " <+> ppr nm
  99    ppr (PUSHT_I i)           = text "PUSHT_I " <+> int i
 100    ppr (SLIDE n d)           = text "SLIDE   " <+> int n <+> int d
 101    ppr (ALLOC sz)            = text "ALLOC   " <+> int sz
 102    ppr (MKAP offset sz)      = text "MKAP    " <+> int offset <+> int sz
 103    ppr (UNPACK sz)           = text "UNPACK  " <+> int sz
 104    ppr (PACK dcon sz)        = text "PACK    " <+> ppr dcon <+> ppr sz
 105    ppr ENTER                 = text "ENTER"
 106
 107 pprAltCode discrs_n_codes
 108    = vcat (map f discrs_n_codes)
 109      where f (discr, code) = ppr discr <> colon <+> vcat (map ppr (fromOL code))
 110
 111 instance Outputable a => Outputable (ProtoBCO a) where
 112    ppr (ProtoBCO name instrs)
 113       = (text "ProtoBCO" <+> ppr name <> colon)
 114         $$ nest 6 (vcat (map ppr (fromOL instrs)))
 115
 116 \end{code}
 117
 118 %************************************************************************
 119 %*                                                                      *
 120 \subsection{Compilation schema for the bytecode generator.}
 121 %*                                                                      *
 122 %************************************************************************
 123
 124 \begin{code}
 125
 126 type BCInstrList = OrdList BCInstr
 127
 128 data ProtoBCO a = ProtoBCO a BCInstrList
 129
 130 type Sequel = Int       -- back off to this depth before ENTER
 131
 132 -- Maps Ids to the offset from the stack _base_ so we don't have
 133 -- to mess with it after each push/pop.
 134 type BCEnv = FiniteMap Id Int   -- To find vars on the stack
 135
 136
 137
 138 -- Compile code for the right hand side of a let binding.
 139 -- Park the resulting BCO in the monad.  Also requires the
 140 -- variable to which this value was bound, so as to give the
 141 -- resulting BCO a name.
 142 schemeR :: (Id, AnnExpr Id VarSet) -> BcM ()
 143 schemeR (nm, rhs) = schemeR_wrk nm (collect [] rhs)
 144
 145 collect xs (_, AnnLam x e) = collect (x:xs) e
 146 collect xs not_lambda      = (reverse xs, not_lambda)
 147
 148 schemeR_wrk nm (args, body)
 149    = let fvs       = fst body
 150          all_args  = varSetElems fvs ++ args
 151          szsw_args = map taggedIdSizeW all_args
 152          szw_args  = sum szsw_args
 153          p_init    = listToFM (zip all_args (scanl (+) 0 szsw_args))
 154          argcheck  = if null args then nilOL else unitOL (ARGCHECK szw_args)
 155      in
 156      schemeE szw_args 0 p_init body             `thenBc` \ body_code ->
 157      emitBc (ProtoBCO (getName nm) (appOL argcheck body_code))
 158
 159
 160 -- Compile code to apply the given expression to the remaining args
 161 -- on the stack, returning a HNF.
 162 schemeE :: Int -> Sequel -> BCEnv -> AnnExpr Id VarSet -> BcM BCInstrList
 163
 164 -- Delegate tail-calls to schemeT.
 165 schemeE d s p e@(fvs, AnnApp f a)
 166    = returnBc (schemeT (should_args_be_tagged e) d s 0 p (fvs, AnnApp f a))
 167 schemeE d s p e@(fvs, AnnVar v)
 168    = returnBc (schemeT (should_args_be_tagged e) d s 0 p (fvs, AnnVar v))
 169
 170 schemeE d s p (fvs, AnnLet binds b)
 171    = let (xs,rhss) = case binds of AnnNonRec x rhs  -> ([x],[rhs])
 172                                    AnnRec xs_n_rhss -> unzip xs_n_rhss
 173      in
 174      mapBc schemeR (zip xs rhss)                        `thenBc_`
 175      let n     = length xs
 176          fvss  = map (varSetElems.fst) rhss
 177          sizes = map (\rhs_fvs -> 1 + sum (map taggedIdSizeW rhs_fvs)) fvss
 178          p'    = addListToFM p (zipE xs [d .. d+n-1])
 179          d'    = d + n
 180          infos = zipE4 fvss sizes xs [n, n-1 .. 1]
 181          zipE  = zipEqual "schemeE"
 182          zipE4 = zipWith4Equal "schemeE" (\a b c d -> (a,b,c,d))
 183
 184          -- ToDo: don't build thunks for things with no free variables
 185          buildThunk (fvs, size, id, off)
 186             = case unzip (map (pushAtom True d' p . AnnVar) (reverse fvs)) of
 187                 (push_codes, pushed_szsw)
 188                    -> ASSERT(sum pushed_szsw == size - 1)
 189                             (toOL push_codes `snocOL` PUSH_G (getName id)
 190                                              `appOL` unitOL (MKAP off size))
 191
 192          thunkCode = concatOL (map buildThunk infos)
 193          allocCode = toOL (map ALLOC sizes)
 194      in
 195      schemeE d' s p' b                                  `thenBc` \ bodyCode ->
 196      mapBc schemeR (zip xs rhss)                        `thenBc` \_ ->
 197      returnBc (allocCode `appOL` thunkCode `appOL` bodyCode)
 198
 199
 200 schemeE d s p (fvs, AnnCase scrut bndr alts)
 201    = let
 202         -- Top of stack is the return itbl, as usual.
 203         -- underneath it is the pointer to the alt_code BCO.
 204         -- When an alt is entered, it assumes the returned value is
 205         -- on top of the itbl.
 206         ret_frame_sizeW = 2
 207
 208         -- Env and depth in which to compile the alts, not including
 209         -- any vars bound by the alts themselves
 210         d' = d + ret_frame_sizeW + taggedIdSizeW bndr
 211         p' = addToFM p bndr d'
 212
 213         isAlgCase
 214            = case typePrimRep (idType bndr) of
 215                 IntRep -> False ; FloatRep -> False ; DoubleRep -> False
 216                 PtrRep -> True
 217                 other  -> pprPanic "ByteCodeGen.schemeE" (ppr other)
 218
 219         -- given an alt, return a discr and code for it.
 220         codeAlt alt@(discr, binds, rhs)
 221            | isAlgCase
 222            = let binds_szsw = map untaggedIdSizeW binds
 223                  binds_szw  = sum binds_szsw
 224                  p'' = addListToFM p' (zip binds (scanl (+) d' binds_szsw))
 225                  d'' = d' + binds_szw
 226              in schemeE d'' s p'' rhs   `thenBc` \ rhs_code ->
 227                 returnBc (my_discr alt, UNPACK binds_szw `consOL` rhs_code)
 228            | otherwise
 229            = ASSERT(null binds)
 230              schemeE d' s p' rhs        `thenBc` \ rhs_code ->
 231              returnBc (my_discr alt, rhs_code)
 232
 233         my_discr (DEFAULT, binds, rhs)  = NoDiscr
 234         my_discr (DataAlt dc, binds, rhs) = DiscrP (dataConTag dc - fIRST_TAG)
 235         my_discr (LitAlt l, binds, rhs)
 236            = case l of MachInt i     -> DiscrI (fromInteger i)
 237                        MachFloat r   -> DiscrF (fromRational r)
 238                        MachDouble r  -> DiscrD (fromRational r)
 239
 240      in
 241      mapBc codeAlt alts                                 `thenBc` \ alt_stuff ->
 242      mkMultiBranch alt_stuff                            `thenBc` \ alt_final ->
 243      let
 244          alt_bco_name = getName bndr
 245          alt_bco      = ProtoBCO alt_bco_name alt_final
 246      in
 247      schemeE (d + ret_frame_sizeW)
 248              (d + ret_frame_sizeW) p scrut              `thenBc` \ scrut_code ->
 249
 250      emitBc alt_bco                                     `thenBc_`
 251      returnBc (PUSH_G alt_bco_name `consOL` scrut_code)
 252
 253
 254 -- Compile code to do a tail call.  Doesn't need to be monadic.
 255 schemeT :: Bool         -- do tagging?
 256         -> Int          -- Stack depth
 257         -> Sequel       -- Sequel depth
 258         -> Int          -- # arg words so far
 259         -> BCEnv        -- stack env
 260         -> AnnExpr Id VarSet -> BCInstrList
 261
 262 schemeT enTag d s narg_words p (_, AnnApp f a)
 263    = let (push, arg_words) = pushAtom enTag d p (snd a)
 264      in push
 265         `consOL` schemeT enTag (d+arg_words) s (narg_words+arg_words) p f
 266
 267 schemeT enTag d s narg_words p (_, AnnVar f)
 268    | Just con <- isDataConId_maybe f
 269    = ASSERT(enTag == False)
 270      PACK con narg_words `consOL` SLIDE 1 (d-s-1) `consOL` unitOL ENTER
 271    | otherwise
 272    = ASSERT(enTag == True)
 273      let (push, arg_words) = pushAtom True d p (AnnVar f)
 274      in push
 275         `consOL` SLIDE (narg_words+arg_words) (d - s - narg_words)
 276         `consOL` unitOL ENTER
 277
 278 should_args_be_tagged (_, AnnVar v)
 279    = case isDataConId_maybe v of
 280         Just dcon -> False; Nothing -> True
 281 should_args_be_tagged (_, AnnApp f a)
 282    = should_args_be_tagged f
 283 should_args_be_tagged (_, other)
 284    = panic "should_args_be_tagged: tail call to non-con, non-var"
 285
 286 -- Push an atom onto the stack, returning suitable code & number of
 287 -- stack words used.  Pushes it either tagged or untagged, since
 288 -- pushAtom is used to set up the stack prior to copying into the
 289 -- heap for both APs (requiring tags) and constructors (which don't).
 290 --
 291 -- NB this means NO GC between pushing atoms for a constructor and
 292 -- copying them into the heap.  It probably also means that
 293 -- tail calls MUST be of the form atom{atom ... atom} since if the
 294 -- expression head was allowed to be arbitrary, there could be GC
 295 -- in between pushing the arg atoms and completing the head.
 296 -- (not sure; perhaps the allocate/doYouWantToGC interface means this
 297 -- isn't a problem; but only if arbitrary graph construction for the
 298 -- head doesn't leave this BCO, since GC might happen at the start of
 299 -- each BCO (we consult doYouWantToGC there).
 300 --
 301 -- Blargh.  JRS 001206
 302 --
 303 pushAtom True{-tagged-} d p (AnnVar v)
 304    = case lookupBCEnv_maybe p v of
 305         Just offset -> (PUSH_L sz offset, sz)
 306         Nothing     -> ASSERT(sz == 1) (PUSH_G nm, sz)
 307      where
 308         nm = getName v
 309         sz = taggedIdSizeW v
 310
 311 pushAtom False{-not tagged-} d p (AnnVar v)
 312    = case lookupBCEnv_maybe p v of
 313         Just offset -> (PUSH_L sz (offset+1), sz-1)
 314         Nothing     -> ASSERT(sz == 1) (PUSH_G nm, sz)
 315      where
 316         nm = getName v
 317         sz = untaggedIdSizeW v
 318
 319 pushAtom True d p (AnnLit lit)
 320    = case lit of
 321         MachInt i    -> (PUSHT_I (fromInteger i),  taggedSizeW IntRep)
 322         MachFloat r  -> (PUSHT_F (fromRational r), taggedSizeW FloatRep)
 323         MachDouble r -> (PUSHT_D (fromRational r), taggedSizeW DoubleRep)
 324
 325 pushAtom False d p (AnnLit lit)
 326    = case lit of
 327         MachInt i    -> (PUSHU_I (fromInteger i),  untaggedSizeW IntRep)
 328         MachFloat r  -> (PUSHU_F (fromRational r), untaggedSizeW FloatRep)
 329         MachDouble r -> (PUSHU_D (fromRational r), untaggedSizeW DoubleRep)
 330
 331
 332 -- Given a bunch of alts code and their discrs, do the donkey work
 333 -- of making a multiway branch using a switch tree.
 334 -- What a load of hassle!
 335 mkMultiBranch :: [(Discr, BCInstrList)] -> BcM BCInstrList
 336 mkMultiBranch raw_ways
 337    = let d_way     = filter (isNoDiscr.fst) raw_ways
 338          notd_ways = naturalMergeSortLe
 339                         (\w1 w2 -> leAlt (fst w1) (fst w2))
 340                         (filter (not.isNoDiscr.fst) raw_ways)
 341
 342          mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
 343          mkTree [] range_lo range_hi = returnBc the_default
 344
 345          mkTree [val] range_lo range_hi
 346             | range_lo `eqAlt` range_hi
 347             = returnBc (snd val)
 348             | otherwise
 349             = getLabelBc                                `thenBc` \ label_neq ->
 350               returnBc (mkTestEQ (fst val) label_neq
 351                         `consOL` (snd val
 352                         `appOL`   unitOL (LABEL label_neq)
 353                         `appOL`   the_default))
 354
 355          mkTree vals range_lo range_hi
 356             = let n = length vals `div` 2
 357                   vals_lo = take n vals
 358                   vals_hi = drop n vals
 359                   v_mid = fst (head vals_hi)
 360               in
 361               getLabelBc                                `thenBc` \ label_geq ->
 362               mkTree vals_lo range_lo (dec v_mid)       `thenBc` \ code_lo ->
 363               mkTree vals_hi v_mid range_hi             `thenBc` \ code_hi ->
 364               returnBc (mkTestLT v_mid label_geq
 365                         `consOL` (code_lo
 366                         `appOL`   unitOL (LABEL label_geq)
 367                         `appOL`   code_hi))
 368
 369          the_default
 370             = case d_way of [] -> unitOL CASEFAIL
 371                             [(_, def)] -> def
 372
 373          -- None of these will be needed if there are no non-default alts
 374          (mkTestLT, mkTestEQ, init_lo, init_hi)
 375             | null notd_ways
 376             = panic "mkMultiBranch: awesome foursome"
 377             | otherwise
 378             = case fst (head notd_ways) of {
 379               DiscrI _ -> ( \(DiscrI i) fail_label -> TESTLT_I i fail_label,
 380                             \(DiscrI i) fail_label -> TESTEQ_I i fail_label,
 381                             DiscrI minBound,
 382                             DiscrI maxBound );
 383               DiscrF _ -> ( \(DiscrF f) fail_label -> TESTLT_F f fail_label,
 384                             \(DiscrF f) fail_label -> TESTEQ_F f fail_label,
 385                             DiscrF minF,
 386                             DiscrF maxF );
 387               DiscrD _ -> ( \(DiscrD d) fail_label -> TESTLT_D d fail_label,
 388                             \(DiscrD d) fail_label -> TESTEQ_D d fail_label,
 389                             DiscrD minD,
 390                             DiscrD maxD );
 391               DiscrP _ -> ( \(DiscrP i) fail_label -> TESTLT_P i fail_label,
 392                             \(DiscrP i) fail_label -> TESTEQ_P i fail_label,
 393                             DiscrP minBound,
 394                             DiscrP maxBound )
 395               }
 396
 397          (DiscrI i1) `eqAlt` (DiscrI i2) = i1 == i2
 398          (DiscrF f1) `eqAlt` (DiscrF f2) = f1 == f2
 399          (DiscrD d1) `eqAlt` (DiscrD d2) = d1 == d2
 400          (DiscrP i1) `eqAlt` (DiscrP i2) = i1 == i2
 401          NoDiscr     `eqAlt` NoDiscr     = True
 402          _           `eqAlt` _           = False
 403
 404          (DiscrI i1) `leAlt` (DiscrI i2) = i1 <= i2
 405          (DiscrF f1) `leAlt` (DiscrF f2) = f1 <= f2
 406          (DiscrD d1) `leAlt` (DiscrD d2) = d1 <= d2
 407          (DiscrP i1) `leAlt` (DiscrP i2) = i1 <= i2
 408          NoDiscr     `leAlt` NoDiscr     = True
 409          _           `leAlt` _           = False
 410
 411          isNoDiscr NoDiscr = True
 412          isNoDiscr _       = False
 413
 414          dec (DiscrI i) = DiscrI (i-1)
 415          dec (DiscrP i) = DiscrP (i-1)
 416          dec other      = other         -- not really right, but if you
 417                 -- do cases on floating values, you'll get what you deserve
 418
 419          -- same snotty comment applies to the following
 420          minF, maxF :: Float
 421          minD, maxD :: Double
 422          minF = -1.0e37
 423          maxF =  1.0e37
 424          minD = -1.0e308
 425          maxD =  1.0e308
 426      in
 427          mkTree notd_ways init_lo init_hi
 428
 429 \end{code}
 430
 431 %************************************************************************
 432 %*                                                                      *
 433 \subsection{Supporting junk for the compilation schemes}
 434 %*                                                                      *
 435 %************************************************************************
 436
 437 \begin{code}
 438
 439 -- Describes case alts
 440 data Discr
 441    = DiscrI Int
 442    | DiscrF Float
 443    | DiscrD Double
 444    | DiscrP Int
 445    | NoDiscr
 446
 447 instance Outputable Discr where
 448    ppr (DiscrI i) = int i
 449    ppr (DiscrF f) = text (show f)
 450    ppr (DiscrD d) = text (show d)
 451    ppr (DiscrP i) = int i
 452    ppr NoDiscr    = text "DEF"
 453
 454
 455 -- Find things in the BCEnv (the what's-on-the-stack-env)
 456 lookupBCEnv :: BCEnv -> Id -> Int
 457 lookupBCEnv env nm
 458    = case lookupFM env nm of
 459         Nothing -> pprPanic "lookupBCEnv"
 460                             (ppr nm $$ char ' ' $$ vcat (map ppr (fmToList env)))
 461         Just xx -> xx
 462
 463 lookupBCEnv_maybe :: BCEnv -> Id -> Maybe Int
 464 lookupBCEnv_maybe = lookupFM
 465
 466
 467 -- When I push one of these on the stack, how much does Sp move by?
 468 taggedSizeW :: PrimRep -> Int
 469 taggedSizeW pr
 470    | isFollowableRep pr = 1
 471    | otherwise          = 1{-the tag-} + getPrimRepSize pr
 472
 473
 474 -- The plain size of something, without tag.
 475 untaggedSizeW :: PrimRep -> Int
 476 untaggedSizeW pr
 477    | isFollowableRep pr = 1
 478    | otherwise          = getPrimRepSize pr
 479
 480
 481 taggedIdSizeW, untaggedIdSizeW :: Id -> Int
 482 taggedIdSizeW   = taggedSizeW   . typePrimRep . idType
 483 untaggedIdSizeW = untaggedSizeW . typePrimRep . idType
 484
 485 \end{code}
 486
 487 %************************************************************************
 488 %*                                                                      *
 489 \subsection{The bytecode generator's monad}
 490 %*                                                                      *
 491 %************************************************************************
 492
 493 \begin{code}
 494 data BcM_State
 495    = BcM_State { bcos      :: [ProtoBCO Name],  -- accumulates completed BCOs
 496                  nextlabel :: Int }             -- for generating local labels
 497
 498 type BcM result = BcM_State -> (result, BcM_State)
 499
 500 mkBcM_State :: [ProtoBCO Name] -> Int -> BcM_State
 501 mkBcM_State = BcM_State
 502
 503 runBc :: BcM_State -> BcM () -> BcM_State
 504 runBc init_st m = case m init_st of { (r,st) -> st }
 505
 506 thenBc :: BcM a -> (a -> BcM b) -> BcM b
 507 thenBc expr cont st
 508   = case expr st of { (result, st') -> cont result st' }
 509
 510 thenBc_ :: BcM a -> BcM b -> BcM b
 511 thenBc_ expr cont st
 512   = case expr st of { (result, st') -> cont st' }
 513
 514 returnBc :: a -> BcM a
 515 returnBc result st = (result, st)
 516
 517 mapBc :: (a -> BcM b) -> [a] -> BcM [b]
 518 mapBc f []     = returnBc []
 519 mapBc f (x:xs)
 520   = f x          `thenBc` \ r  ->
 521     mapBc f xs   `thenBc` \ rs ->
 522     returnBc (r:rs)
 523
 524 emitBc :: ProtoBCO Name -> BcM ()
 525 emitBc bco st
 526    = ((), st{bcos = bco : bcos st})
 527
 528 getLabelBc :: BcM Int
 529 getLabelBc st
 530    = (nextlabel st, st{nextlabel = 1 + nextlabel st})
 531
 532 \end{code}
 533
 534 %************************************************************************
 535 %*                                                                      *
 536 \subsection{The bytecode assembler}
 537 %*                                                                      *
 538 %************************************************************************
 539
 540 The object format for bytecodes is: 16 bits for the opcode, and 16 for
 541 each field -- so the code can be considered a sequence of 16-bit ints.
 542 Each field denotes either a stack offset or number of items on the
 543 stack (eg SLIDE), and index into the pointer table (eg PUSH_G), an
 544 index into the literal table (eg PUSH_I/D/L), or a bytecode address in
 545 this BCO.
 546
 547 \begin{code}
 548 -- An (almost) assembled BCO.
 549 data BCO a = BCO [Word16]       -- instructions
 550                  [Word32]       -- literal pool
 551                  [a]            -- Names or HValues
 552
 553 -- Top level assembler fn.
 554 assembleBCO :: ProtoBCO Name -> BCO Name
 555 assembleBCO (ProtoBCO nm instrs_ordlist)
 556    = let
 557          -- pass 1: collect up the offsets of the local labels
 558          instrs = fromOL instrs_ordlist
 559          label_env = mkLabelEnv emptyFM 0 instrs
 560
 561          mkLabelEnv env i_offset [] = env
 562          mkLabelEnv env i_offset (i:is)
 563             = let new_env
 564                      = case i of LABEL n -> addToFM env n i_offset ; _ -> env
 565               in  mkLabelEnv new_env (i_offset + instrSizeB i) is
 566
 567          findLabel lab
 568             = case lookupFM label_env lab of
 569                  Just bco_offset -> bco_offset
 570                  Nothing -> pprPanic "assembleBCO.findLabel" (int lab)
 571
 572          -- pass 2: generate the instruction, ptr and nonptr bits
 573          (insnW16s, litW32s, ptrs) = mkBits findLabel [] 0 [] 0 [] 0 instrs
 574      in
 575          BCO insnW16s litW32s ptrs
 576
 577
 578 -- This is where all the action is (pass 2 of the assembler)
 579 mkBits :: (Int -> Int)          -- label finder
 580        -> [Word16] -> Int       -- reverse acc instr bits
 581        -> [Word32] -> Int       -- reverse acc literal bits
 582        -> [Name] -> Int         -- reverse acc ptrs
 583        -> [BCInstr]             -- insns!
 584        -> ([Word16], [Word32], [Name])
 585
 586 mkBits findLabel r_is n_is r_lits n_lits r_ptrs n_ptrs []
 587    = (reverse r_is, reverse r_lits, reverse r_ptrs)
 588 mkBits findLabel r_is n_is r_lits n_lits r_ptrs n_ptrs (instr:instrs)
 589    = case instr of
 590         ARGCHECK  n    -> boring2 i_ARGCHECK n
 591         PUSH_L    sz off -> boring3 i_PUSH_L sz off
 592         PUSH_G    nm   -> exciting2_P i_PUSH_G n_ptrs nm
 593         PUSHT_I   i    -> exciting2_I i_PUSHT_I n_lits i
 594         PUSHT_F   f    -> exciting2_F i_PUSHT_F n_lits f
 595         PUSHT_D   d    -> exciting2_D i_PUSHT_D n_lits d
 596         PUSHU_I   i    -> exciting2_I i_PUSHU_I n_lits i
 597         PUSHU_F   f    -> exciting2_F i_PUSHU_F n_lits f
 598         PUSHU_D   d    -> exciting2_D i_PUSHU_D n_lits d
 599         SLIDE     n by -> boring3 i_SLIDE n by
 600         ALLOC     n    -> boring2 i_ALLOC n
 601         MKAP      off sz -> boring3 i_MKAP off sz
 602         UNPACK    n    -> boring2 i_UNPACK n
 603         PACK      dcon sz -> exciting3_A i_PACK sz n_lits nullAddr {-findItbl dcon-}
 604         LABEL     lab  -> nop
 605         TESTLT_I  i l  -> exciting3_I i_TESTLT_I n_lits (findLabel l) i
 606         TESTEQ_I  i l  -> exciting3_I i_TESTEQ_I n_lits (findLabel l) i
 607         TESTLT_F  f l  -> exciting3_F i_TESTLT_F n_lits (findLabel l) f
 608         TESTEQ_F  f l  -> exciting3_F i_TESTEQ_F n_lits (findLabel l) f
 609         TESTLT_D  d l  -> exciting3_D i_TESTLT_D n_lits (findLabel l) d
 610         TESTEQ_D  d l  -> exciting3_D i_TESTEQ_D n_lits (findLabel l) d
 611         TESTLT_P  i l  -> exciting3_I i_TESTLT_P n_lits (findLabel l) i
 612         TESTEQ_P  i l  -> exciting3_I i_TESTEQ_P n_lits (findLabel l) i
 613         CASEFAIL       -> boring1 i_CASEFAIL
 614         ENTER          -> boring1 i_ENTER
 615      where
 616         r_mkILit = reverse . mkILit
 617         r_mkFLit = reverse . mkFLit
 618         r_mkDLit = reverse . mkDLit
 619         r_mkALit = reverse . mkALit
 620
 621         mkw :: Int -> Word16
 622         mkw = fromIntegral
 623
 624         nop
 625            = mkBits findLabel r_is n_is r_lits n_lits r_ptrs n_ptrs instrs
 626         boring1 i1
 627            = mkBits findLabel (mkw i1 : r_is) (n_is+1)
 628                     r_lits n_lits r_ptrs n_ptrs instrs
 629         boring2 i1 i2
 630            = mkBits findLabel (mkw i2 : mkw i1 : r_is) (n_is+2)
 631                     r_lits n_lits r_ptrs n_ptrs instrs
 632         boring3 i1 i2 i3
 633            = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3)
 634                     r_lits n_lits r_ptrs n_ptrs instrs
 635
 636         exciting2_P i1 i2 p
 637            = mkBits findLabel (mkw i2 : mkw i1 : r_is) (n_is+2) r_lits n_lits
 638                     (p:r_ptrs) (n_ptrs+1) instrs
 639         exciting3_P i1 i2 i3 p
 640            = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3) r_lits n_lits
 641                     (p:r_ptrs) (n_ptrs+1) instrs
 642
 643         exciting2_I i1 i2 i
 644            = mkBits findLabel (mkw i2 : mkw i1 : r_is) (n_is+2)
 645                     (r_mkILit i ++ r_lits) (n_lits + intLitSz32s)
 646                     r_ptrs n_ptrs instrs
 647         exciting3_I i1 i2 i3 i
 648            = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3)
 649                     (r_mkILit i ++ r_lits) (n_lits + intLitSz32s)
 650                     r_ptrs n_ptrs instrs
 651
 652         exciting2_F i1 i2 f
 653            = mkBits findLabel (mkw i2 : mkw i1 : r_is) (n_is+2)
 654                     (r_mkFLit f ++ r_lits) (n_lits + floatLitSz32s)
 655                     r_ptrs n_ptrs instrs
 656         exciting3_F i1 i2 i3 f
 657            = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3)
 658                     (r_mkFLit f ++ r_lits) (n_lits + floatLitSz32s)
 659                     r_ptrs n_ptrs instrs
 660
 661         exciting2_D i1 i2 d
 662            = mkBits findLabel (mkw i2 : mkw i1 : r_is) (n_is+2)
 663                     (r_mkDLit d ++ r_lits) (n_lits + doubleLitSz32s)
 664                     r_ptrs n_ptrs instrs
 665         exciting3_D i1 i2 i3 d
 666            = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3)
 667                     (r_mkDLit d ++ r_lits) (n_lits + doubleLitSz32s)
 668                     r_ptrs n_ptrs instrs
 669
 670         exciting3_A i1 i2 i3 d
 671            = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3)
 672                     (r_mkALit d ++ r_lits) (n_lits + addrLitSz32s)
 673                     r_ptrs n_ptrs instrs
 674
 675
 676 -- The size in bytes of an instruction.
 677 instrSizeB :: BCInstr -> Int
 678 instrSizeB instr
 679    = case instr of
 680         ARGCHECK _   -> 4
 681         PUSH_L   _ _ -> 6
 682         PUSH_G   _   -> 4
 683         PUSHT_I  _   -> 4
 684         PUSHT_F  _   -> 4
 685         PUSHT_D  _   -> 4
 686         PUSHU_I  _   -> 4
 687         PUSHU_F  _   -> 4
 688         PUSHU_D  _   -> 4
 689         SLIDE    _ _ -> 6
 690         ALLOC    _   -> 4
 691         MKAP     _ _ -> 6
 692         UNPACK   _   -> 4
 693         PACK     _ _ -> 6
 694         LABEL    _   -> 4
 695         TESTLT_I _ _ -> 6
 696         TESTEQ_I _ _ -> 6
 697         TESTLT_F _ _ -> 6
 698         TESTEQ_F _ _ -> 6
 699         TESTLT_D _ _ -> 6
 700         TESTEQ_D _ _ -> 6
 701         TESTLT_P _ _ -> 6
 702         TESTEQ_P _ _ -> 6
 703         CASEFAIL     -> 2
 704         ENTER        -> 2
 705
 706
 707 -- Sizes of Int, Float and Double literals, in units of 32-bitses
 708 intLitSz32s, floatLitSz32s, doubleLitSz32s, addrLitSz32s :: Int
 709 intLitSz32s    = wORD_SIZE `div` 4
 710 floatLitSz32s  = 1      -- Assume IEEE floats
 711 doubleLitSz32s = 2
 712 addrLitSz32s   = intLitSz32s
 713
 714 -- Make lists of 32-bit words for literals, so that when the
 715 -- words are placed in memory at increasing addresses, the
 716 -- bit pattern is correct for the host's word size and endianness.
 717 mkILit :: Int    -> [Word32]
 718 mkFLit :: Float  -> [Word32]
 719 mkDLit :: Double -> [Word32]
 720 mkALit :: Addr   -> [Word32]
 721
 722 mkFLit f
 723    = runST (do
 724         arr <- newFloatArray ((0::Int),0)
 725         writeFloatArray arr 0 f
 726         w0 <- readWord32Array arr 0
 727         return [w0]
 728      )
 729
 730 mkDLit d
 731    = runST (do
 732         arr <- newDoubleArray ((0::Int),0)
 733         writeDoubleArray arr 0 d
 734         w0 <- readWord32Array arr 0
 735         w1 <- readWord32Array arr 1
 736         return [w0,w1]
 737      )
 738
 739 mkILit i
 740    | wORD_SIZE == 4
 741    = runST (do
 742         arr <- newIntArray ((0::Int),0)
 743         writeIntArray arr 0 i
 744         w0 <- readWord32Array arr 0
 745         return [w0]
 746      )
 747    | wORD_SIZE == 8
 748    = runST (do
 749         arr <- newIntArray ((0::Int),0)
 750         writeIntArray arr 0 i
 751         w0 <- readWord32Array arr 0
 752         w1 <- readWord32Array arr 1
 753         return [w0,w1]
 754      )
 755
 756 mkALit a
 757    | wORD_SIZE == 4
 758    = runST (do
 759         arr <- newAddrArray ((0::Int),0)
 760         writeAddrArray arr 0 a
 761         w0 <- readWord32Array arr 0
 762         return [w0]
 763      )
 764    | wORD_SIZE == 8
 765    = runST (do
 766         arr <- newAddrArray ((0::Int),0)
 767         writeAddrArray arr 0 a
 768         w0 <- readWord32Array arr 0
 769         w1 <- readWord32Array arr 1
 770         return [w0,w1]
 771      )
 772
 773
 774
 775 #include "../rts/Bytecodes.h"
 776
 777 i_ARGCHECK = (bci_ARGCHECK :: Int)
 778 i_PUSH_L   = (bci_PUSH_L   :: Int)
 779 i_PUSH_G   = (bci_PUSH_G   :: Int)
 780 i_PUSHT_I  = (bci_PUSHT_I  :: Int)
 781 i_PUSHT_F  = (bci_PUSHT_F  :: Int)
 782 i_PUSHT_D  = (bci_PUSHT_D  :: Int)
 783 i_PUSHU_I  = (bci_PUSHU_I  :: Int)
 784 i_PUSHU_F  = (bci_PUSHU_F  :: Int)
 785 i_PUSHU_D  = (bci_PUSHU_D  :: Int)
 786 i_SLIDE    = (bci_SLIDE    :: Int)
 787 i_ALLOC    = (bci_ALLOC    :: Int)
 788 i_MKAP     = (bci_MKAP     :: Int)
 789 i_UNPACK   = (bci_UNPACK   :: Int)
 790 i_PACK     = (bci_PACK     :: Int)
 791 i_LABEL    = (bci_LABEL    :: Int)
 792 i_TESTLT_I = (bci_TESTLT_I :: Int)
 793 i_TESTEQ_I = (bci_TESTEQ_I :: Int)
 794 i_TESTLT_F = (bci_TESTLT_F :: Int)
 795 i_TESTEQ_F = (bci_TESTEQ_F :: Int)
 796 i_TESTLT_D = (bci_TESTLT_D :: Int)
 797 i_TESTEQ_D = (bci_TESTEQ_D :: Int)
 798 i_TESTLT_P = (bci_TESTLT_P :: Int)
 799 i_TESTEQ_P = (bci_TESTEQ_P :: Int)
 800 i_CASEFAIL = (bci_CASEFAIL :: Int)
 801 i_ENTER    = (bci_ENTER    :: Int)
 802
 803 \end{code}