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