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 ) where
   8
   9 #include "HsVersions.h"
  10
  11 --import Id
  12 --import Name
  13 --import PrimOp
  14
  15 import Outputable
  16 import Name             ( Name, getName )
  17 import Id               ( Id, idType, isDataConId_maybe )
  18 import OrdList          ( OrdList, consOL, snocOL, appOL, unitOL,
  19                           nilOL, toOL, concatOL, fromOL )
  20 import FiniteMap        ( FiniteMap, addListToFM, listToFM,
  21                           addToFM, lookupFM, fmToList )
  22 import CoreSyn
  23 import Literal          ( Literal(..) )
  24 import PrimRep          ( PrimRep(..) )
  25 import CoreFVs          ( freeVars )
  26 import Type             ( typePrimRep )
  27 import DataCon          ( DataCon, dataConTag, fIRST_TAG )
  28 import Util             ( zipEqual, zipWith4Equal, naturalMergeSortLe )
  29 import VarSet           ( VarSet, varSetElems )
  30 --import FastTypes
  31 \end{code}
  32
  33 Entry point.
  34
  35 \begin{code}
  36 byteCodeGen :: [CoreBind] -> [BCO Name]
  37 byteCodeGen binds
  38    = let flatBinds = concatMap getBind binds
  39          getBind (NonRec bndr rhs) = [(bndr, freeVars rhs)]
  40          getBind (Rec binds)       = [(bndr, freeVars rhs) | (bndr,rhs) <- binds]
  41          final_state = runBc (BcM_State [] 0)
  42                              (mapBc schemeR flatBinds `thenBc_` returnBc ())
  43      in
  44          case final_state of
  45             BcM_State bcos final_ctr -> bcos
  46
  47 \end{code}
  48
  49 The real machinery.
  50
  51 \begin{code}
  52 type LocalLabel = Int
  53
  54 data BCInstr
  55    -- Messing with the stack
  56    = ARGCHECK Int
  57    | PUSH_L Int{-size-} Int{-offset-}
  58    | PUSH_G Name
  59    | PUSH_I Integer
  60    | SLIDE Int{-this many-} Int{-down by this much-}
  61    -- To do with the heap
  62    | ALLOC Int
  63    | MKAP Int{-place ptr to heap this far down stack-} Int{-# words-}
  64    | UNPACK Int
  65    | PACK DataCon Int
  66    -- For doing case trees
  67    | LABEL       LocalLabel
  68    | TESTLT_I    Int LocalLabel
  69    | TESTEQ_I    Int LocalLabel
  70    | TESTLT_F    Float LocalLabel
  71    | TESTEQ_F    Float LocalLabel
  72    | TESTLT_D    Double LocalLabel
  73    | TESTEQ_D    Double LocalLabel
  74    | TESTLT_P    Int LocalLabel
  75    | TESTEQ_P    Int LocalLabel
  76    | CASEFAIL
  77    -- To Infinity And Beyond
  78    | ENTER
  79
  80 instance Outputable BCInstr where
  81    ppr (ARGCHECK n)          = text "ARGCHECK" <+> int n
  82    ppr (PUSH_L sz offset)    = text "PUSH_L  " <+> int sz <+> int offset
  83    ppr (PUSH_G nm)           = text "PUSH_G  " <+> ppr nm
  84    ppr (PUSH_I i)            = text "PUSH_I  " <+> integer i
  85    ppr (SLIDE n d)           = text "SLIDE   " <+> int n <+> int d
  86    ppr (ALLOC sz)            = text "ALLOC   " <+> int sz
  87    ppr (MKAP offset sz)      = text "MKAP    " <+> int offset <+> int sz
  88    ppr (UNPACK sz)           = text "UNPACK  " <+> int sz
  89    ppr (PACK dcon sz)        = text "PACK    " <+> ppr dcon <+> ppr sz
  90    ppr ENTER                 = text "ENTER"
  91
  92 pprAltCode discrs_n_codes
  93    = vcat (map f discrs_n_codes)
  94      where f (discr, code) = ppr discr <> colon <+> vcat (map ppr (fromOL code))
  95
  96
  97 type BCInstrList = OrdList BCInstr
  98
  99 data BCO a = BCO a BCInstrList
 100
 101 instance Outputable a => Outputable (BCO a) where
 102    ppr (BCO name instrs)
 103       = (text "BCO" <+> ppr name <> colon)
 104         $$ nest 6 (vcat (map ppr (fromOL instrs)))
 105
 106
 107
 108
 109 type Sequel = Int       -- back off to this depth before ENTER
 110
 111 -- Maps Ids to the offset from the stack _base_ so we don't have
 112 -- to mess with it after each push/pop.
 113 type BCEnv = FiniteMap Id Int   -- To find vars on the stack
 114
 115 lookupBCEnv :: BCEnv -> Id -> Int
 116 lookupBCEnv env nm
 117    = case lookupFM env nm of
 118         Nothing -> pprPanic "lookupBCEnv"
 119                             (ppr nm $$ char ' ' $$ vcat (map ppr (fmToList env)))
 120         Just xx -> xx
 121
 122 lookupBCEnv_maybe :: BCEnv -> Id -> Maybe Int
 123 lookupBCEnv_maybe = lookupFM
 124
 125
 126 -- Describes case alts
 127 data Discr
 128    = DiscrI Int
 129    | DiscrF Float
 130    | DiscrD Double
 131    | DiscrP Int
 132    | NoDiscr
 133
 134 instance Outputable Discr where
 135    ppr (DiscrI i) = int i
 136    ppr (DiscrF f) = text (show f)
 137    ppr (DiscrD d) = text (show d)
 138    ppr (DiscrP i) = int i
 139    ppr NoDiscr    = text "DEF"
 140
 141
 142 -- Hmm.  This isn't really right (ie on Alpha, idSizeW Double -> 2)
 143 -- There must be an Officially Approved way to do this somewhere.
 144 idSizeW :: Id -> Int
 145 idSizeW nm
 146    = let pr = typePrimRep (idType nm)
 147      in  case pr of IntRep -> 2
 148                     FloatRep -> 2
 149                     DoubleRep -> 3
 150                     PtrRep -> 1
 151                     other -> pprPanic "ByteCodeGen.idSizeW" (ppr pr)
 152
 153
 154
 155 -- Compile code for the right hand side of a let binding.
 156 -- Park the resulting BCO in the monad.  Also requires the
 157 -- variable to which this value was bound, so as to give the
 158 -- resulting BCO a name.
 159 schemeR :: (Id, AnnExpr Id VarSet) -> BcM ()
 160 schemeR (nm, rhs) = schemeR_wrk nm (collect [] rhs)
 161
 162 collect xs (_, AnnLam x e) = collect (x:xs) e
 163 collect xs not_lambda      = (reverse xs, not_lambda)
 164
 165 schemeR_wrk nm (args, body)
 166    = let fvs       = fst body
 167          all_args  = varSetElems fvs ++ args
 168          szsw_args = map idSizeW all_args
 169          szw_args  = sum szsw_args
 170          p_init    = listToFM (zip all_args (scanl (+) 0 szsw_args))
 171          argcheck  = if null args then nilOL else unitOL (ARGCHECK szw_args)
 172      in
 173      schemeE szw_args 0 p_init body             `thenBc` \ body_code ->
 174      emitBc (BCO (getName nm) (appOL argcheck body_code))
 175
 176
 177 -- Compile code to apply the given expression to the remaining args
 178 -- on the stack, returning a HNF.
 179 schemeE :: Int -> Sequel -> BCEnv -> AnnExpr Id VarSet -> BcM BCInstrList
 180
 181 -- Delegate tail-calls to schemeT.
 182 schemeE d s p (fvs, AnnApp f a) = returnBc (schemeT d s 0 p (fvs, AnnApp f a))
 183 schemeE d s p (fvs, AnnVar v)   = returnBc (schemeT d s 0 p (fvs, AnnVar v))
 184
 185 schemeE d s p (fvs, AnnLet binds b)
 186    = let (xs,rhss) = case binds of AnnNonRec x rhs  -> ([x],[rhs])
 187                                    AnnRec xs_n_rhss -> unzip xs_n_rhss
 188      in
 189      mapBc schemeR (zip xs rhss)                        `thenBc_`
 190      let n     = length xs
 191          fvss  = map (varSetElems.fst) rhss
 192          sizes = map (\rhs_fvs -> 1 + sum (map idSizeW rhs_fvs)) fvss
 193          p'    = addListToFM p (zipE xs [d .. d+n-1])
 194          d'    = d + n
 195          infos = zipE4 fvss sizes xs [n, n-1 .. 1]
 196          zipE  = zipEqual "schemeE"
 197          zipE4 = zipWith4Equal "schemeE" (\a b c d -> (a,b,c,d))
 198
 199          -- ToDo: don't build thunks for things with no free variables
 200          buildThunk (fvs, size, id, off)
 201             = case unzip (map (pushAtom d' p . AnnVar) (reverse fvs)) of
 202                 (push_codes, pushed_szsw)
 203                    -> ASSERT(sum pushed_szsw == size - 1)
 204                             (toOL push_codes `snocOL` PUSH_G (getName id)
 205                                              `appOL` unitOL (MKAP off size))
 206
 207          thunkCode = concatOL (map buildThunk infos)
 208          allocCode = toOL (map ALLOC sizes)
 209      in
 210      schemeE d' s p' b                                  `thenBc` \ bodyCode ->
 211      mapBc schemeR (zip xs rhss)                        `thenBc` \_ ->
 212      returnBc (allocCode `appOL` thunkCode `appOL` bodyCode)
 213
 214
 215 schemeE d s p (fvs, AnnCase scrut bndr alts)
 216    = let
 217         -- Top of stack is the return itbl, as usual.
 218         -- underneath it is the pointer to the alt_code BCO.
 219         -- When an alt is entered, it assumes the returned value is
 220         -- on top of the itbl.
 221         ret_frame_sizeW = 2
 222
 223         -- Env and depth in which to compile the alts, not including
 224         -- any vars bound by the alts themselves
 225         d' = d + ret_frame_sizeW + idSizeW bndr
 226         p' = addToFM p bndr d'
 227
 228         isAlgCase
 229            = case typePrimRep (idType bndr) of
 230                 IntRep -> False ; FloatRep -> False ; DoubleRep -> False
 231                 PtrRep -> True
 232                 other  -> pprPanic "ByteCodeGen.schemeE" (ppr other)
 233
 234         -- given an alt, return a discr and code for it.
 235         codeAlt alt@(discr, binds, rhs)
 236            | isAlgCase
 237            = let binds_szsw = map idSizeW binds
 238                  binds_szw  = sum binds_szsw
 239                  p'' = addListToFM p' (zip binds (scanl (+) d' binds_szsw))
 240                  d'' = d' + binds_szw
 241              in schemeE d'' s p'' rhs   `thenBc` \ rhs_code ->
 242                 returnBc (my_discr alt, UNPACK binds_szw `consOL` rhs_code)
 243            | otherwise
 244            = ASSERT(null binds)
 245              schemeE d' s p' rhs        `thenBc` \ rhs_code ->
 246              returnBc (my_discr alt, rhs_code)
 247
 248         my_discr (DEFAULT, binds, rhs)  = NoDiscr
 249         my_discr (DataAlt dc, binds, rhs) = DiscrP (dataConTag dc - fIRST_TAG)
 250         my_discr (LitAlt l, binds, rhs)
 251            = case l of MachInt i     -> DiscrI (fromInteger i)
 252                        MachFloat r   -> DiscrF (fromRational r)
 253                        MachDouble r  -> DiscrD (fromRational r)
 254
 255      in
 256      mapBc codeAlt alts                                 `thenBc` \ alt_stuff ->
 257      mkMultiBranch alt_stuff                            `thenBc` \ alt_final ->
 258      let
 259          alt_bco_name = getName bndr
 260          alt_bco      = BCO alt_bco_name alt_final
 261      in
 262      schemeE (d + ret_frame_sizeW)
 263              (d + ret_frame_sizeW) p scrut              `thenBc` \ scrut_code ->
 264
 265      emitBc alt_bco                                     `thenBc_`
 266      returnBc (PUSH_G alt_bco_name `consOL` scrut_code)
 267
 268
 269 -- Given a bunch of alts code and their discrs, do the donkey work
 270 -- of making a multiway branch using a switch tree.
 271 -- What a load of hassle!
 272 mkMultiBranch :: [(Discr, BCInstrList)] -> BcM BCInstrList
 273 mkMultiBranch raw_ways
 274    = let d_way     = filter (isNoDiscr.fst) raw_ways
 275          notd_ways = naturalMergeSortLe
 276                         (\w1 w2 -> leAlt (fst w1) (fst w2))
 277                         (filter (not.isNoDiscr.fst) raw_ways)
 278
 279          mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
 280          mkTree [] range_lo range_hi = returnBc the_default
 281
 282          mkTree [val] range_lo range_hi
 283             | range_lo `eqAlt` range_hi
 284             = returnBc (snd val)
 285             | otherwise
 286             = getLabelBc                                `thenBc` \ label_neq ->
 287               returnBc (mkTestEQ (fst val) label_neq
 288                         `consOL` (snd val
 289                         `appOL`   unitOL (LABEL label_neq)
 290                         `appOL`   the_default))
 291
 292          mkTree vals range_lo range_hi
 293             = let n = length vals `div` 2
 294                   vals_lo = take n vals
 295                   vals_hi = drop n vals
 296                   v_mid = fst (head vals_hi)
 297               in
 298               getLabelBc                                `thenBc` \ label_geq ->
 299               mkTree vals_lo range_lo (dec v_mid)       `thenBc` \ code_lo ->
 300               mkTree vals_hi v_mid range_hi             `thenBc` \ code_hi ->
 301               returnBc (mkTestLT v_mid label_geq
 302                         `consOL` (code_lo
 303                         `appOL`   unitOL (LABEL label_geq)
 304                         `appOL`   code_hi))
 305
 306          the_default
 307             = case d_way of [] -> unitOL CASEFAIL
 308                             [(_, def)] -> def
 309
 310          -- None of these will be needed if there are no non-default alts
 311          (mkTestLT, mkTestEQ, init_lo, init_hi)
 312             | null notd_ways
 313             = panic "mkMultiBranch: awesome foursome"
 314             | otherwise
 315             = case fst (head notd_ways) of {
 316               DiscrI _ -> ( \(DiscrI i) fail_label -> TESTLT_I i fail_label,
 317                             \(DiscrI i) fail_label -> TESTEQ_I i fail_label,
 318                             DiscrI minBound,
 319                             DiscrI maxBound );
 320               DiscrF _ -> ( \(DiscrF f) fail_label -> TESTLT_F f fail_label,
 321                             \(DiscrF f) fail_label -> TESTEQ_F f fail_label,
 322                             DiscrF minF,
 323                             DiscrF maxF );
 324               DiscrD _ -> ( \(DiscrD d) fail_label -> TESTLT_D d fail_label,
 325                             \(DiscrD d) fail_label -> TESTEQ_D d fail_label,
 326                             DiscrD minD,
 327                             DiscrD maxD );
 328               DiscrP _ -> ( \(DiscrP i) fail_label -> TESTLT_P i fail_label,
 329                             \(DiscrP i) fail_label -> TESTEQ_P i fail_label,
 330                             DiscrP minBound,
 331                             DiscrP maxBound )
 332               }
 333
 334          (DiscrI i1) `eqAlt` (DiscrI i2) = i1 == i2
 335          (DiscrF f1) `eqAlt` (DiscrF f2) = f1 == f2
 336          (DiscrD d1) `eqAlt` (DiscrD d2) = d1 == d2
 337          (DiscrP i1) `eqAlt` (DiscrP i2) = i1 == i2
 338          NoDiscr     `eqAlt` NoDiscr     = True
 339          _           `eqAlt` _           = False
 340
 341          (DiscrI i1) `leAlt` (DiscrI i2) = i1 <= i2
 342          (DiscrF f1) `leAlt` (DiscrF f2) = f1 <= f2
 343          (DiscrD d1) `leAlt` (DiscrD d2) = d1 <= d2
 344          (DiscrP i1) `leAlt` (DiscrP i2) = i1 <= i2
 345          NoDiscr     `leAlt` NoDiscr     = True
 346          _           `leAlt` _           = False
 347
 348          isNoDiscr NoDiscr = True
 349          isNoDiscr _       = False
 350
 351          dec (DiscrI i) = DiscrI (i-1)
 352          dec (DiscrP i) = DiscrP (i-1)
 353          dec other      = other         -- not really right, but if you
 354                 -- do cases on floating values, you'll get what you deserve
 355
 356          -- same snotty comment applies to the following
 357          minF, maxF :: Float
 358          minD, maxD :: Double
 359          minF = -1.0e37
 360          maxF =  1.0e37
 361          minD = -1.0e308
 362          maxD =  1.0e308
 363      in
 364          mkTree notd_ways init_lo init_hi
 365
 366
 367 -- Compile code to do a tail call.  Doesn't need to be monadic.
 368 schemeT :: Int -> Sequel -> Int -> BCEnv -> AnnExpr Id VarSet -> BCInstrList
 369
 370 schemeT d s narg_words p (_, AnnApp f a)
 371    = let (push, arg_words) = pushAtom d p (snd a)
 372      in push
 373         `consOL` schemeT (d+arg_words) s (narg_words+arg_words) p f
 374
 375 schemeT d s narg_words p (_, AnnVar f)
 376    | Just con <- isDataConId_maybe f
 377    = PACK con narg_words `consOL` SLIDE 1 (d-s-1) `consOL` unitOL ENTER
 378    | otherwise
 379    = let (push, arg_words) = pushAtom d p (AnnVar f)
 380      in push
 381         `consOL` SLIDE (narg_words+arg_words) (d - s - narg_words)
 382         `consOL` unitOL ENTER
 383
 384
 385 -- Push an atom onto the stack, returning suitable code & number of
 386 -- stack words used.
 387 pushAtom d p (AnnVar v)
 388    = case lookupBCEnv_maybe p v of
 389         Just offset -> (PUSH_L sz offset, sz)
 390         Nothing     -> ASSERT(sz == 1) (PUSH_G nm, 1)
 391      where
 392         nm = getName v
 393         sz = idSizeW v
 394
 395 pushAtom d p (AnnLit lit)
 396    = case lit of
 397         MachInt i -> (PUSH_I i, 2)
 398 \end{code}
 399
 400 The bytecode generator's monad.
 401
 402 \begin{code}
 403 data BcM_State
 404    = BcM_State { bcos      :: [BCO Name],       -- accumulates completed BCOs
 405                  nextlabel :: Int }             -- for generating local labels
 406
 407 type BcM result = BcM_State -> (result, BcM_State)
 408
 409 mkBcM_State :: [BCO Name] -> Int -> BcM_State
 410 mkBcM_State = BcM_State
 411
 412 runBc :: BcM_State -> BcM () -> BcM_State
 413 runBc init_st m = case m init_st of { (r,st) -> st }
 414
 415 thenBc :: BcM a -> (a -> BcM b) -> BcM b
 416 thenBc expr cont st
 417   = case expr st of { (result, st') -> cont result st' }
 418
 419 thenBc_ :: BcM a -> BcM b -> BcM b
 420 thenBc_ expr cont st
 421   = case expr st of { (result, st') -> cont st' }
 422
 423 returnBc :: a -> BcM a
 424 returnBc result st = (result, st)
 425
 426 mapBc :: (a -> BcM b) -> [a] -> BcM [b]
 427 mapBc f []     = returnBc []
 428 mapBc f (x:xs)
 429   = f x          `thenBc` \ r  ->
 430     mapBc f xs   `thenBc` \ rs ->
 431     returnBc (r:rs)
 432
 433 emitBc :: BCO Name -> BcM ()
 434 emitBc bco st
 435    = ((), st{bcos = bco : bcos st})
 436
 437 getLabelBc :: BcM Int
 438 getLabelBc st
 439    = (nextlabel st, st{nextlabel = 1 + nextlabel st})
 440 \end{code}