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