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 )
  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 )
  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      in
  42          snd (initBc [] (mapBc schemeR flatBinds))
  43 \end{code}
  44
  45 The real machinery.
  46
  47 \begin{code}
  48 data BCInstr
  49    -- Messing with the stack
  50    = ARGCHECK Int
  51    | PUSH_L Int{-size-} Int{-offset-}
  52    | PUSH_G Name
  53    | PUSH_ALTS Name{-labels the alt BCO; derived from case binder-}
  54    | PUSH_I Integer
  55    | SLIDE Int{-this many-} Int{-down by this much-}
  56    -- To do with the heap
  57    | ALLOC Int
  58    | MKAP Int{-place ptr to heap this far down stack-} Int{-# words-}
  59    | UNPACK Int
  60    | PACK DataCon Int
  61    -- Casery (in French: caseage)
  62    | CASE_PTR    [(Discr, BCInstrList)]
  63    | CASE_INT    [(Discr, BCInstrList)]
  64    | CASE_FLOAT  [(Discr, BCInstrList)]
  65    | CASE_DOUBLE [(Discr, BCInstrList)]
  66    -- To Infinity And Beyond
  67    | ENTER
  68
  69
  70 type BCInstrList = OrdList BCInstr
  71
  72 data BCO a = BCO a BCInstrList
  73
  74
  75 type Sequel = Int       -- back off to this depth before ENTER
  76
  77 -- Maps Ids to the offset from the stack _base_ so we don't have
  78 -- to mess with it after each push/pop.
  79 type BCEnv = FiniteMap Id Int   -- To find vars on the stack
  80
  81 lookupBCEnv :: BCEnv -> Id -> Int
  82 lookupBCEnv env nm
  83    = case lookupFM env nm of
  84         Nothing -> pprPanic "lookupBCEnv"
  85                             (ppr nm $$ char ' ' $$ vcat (map ppr (fmToList env)))
  86         Just xx -> xx
  87
  88 lookupBCEnv_maybe :: BCEnv -> Id -> Maybe Int
  89 lookupBCEnv_maybe = lookupFM
  90
  91
  92 -- Describes case alts
  93 data Discr
  94    = DiscrI Int
  95    | DiscrF Rational
  96    | DiscrD Rational
  97    | DiscrP Int
  98    | NoDiscr
  99
 100 -- Hmm.  This isn't really right (ie on Alpha, idSizeW Double -> 2)
 101 -- There must be an Officially Approved way to do this somewhere.
 102 idSizeW :: Id -> Int
 103 idSizeW nm
 104    = let pr = typePrimRep (idType nm)
 105      in  case pr of IntRep -> 2
 106                     FloatRep -> 2
 107                     DoubleRep -> 3
 108                     PtrRep -> 1
 109                     other -> pprPanic "ByteCodeGen.idSizeW" (ppr pr)
 110
 111
 112
 113 -- Compile code for the right hand side of a let binding.
 114 -- Park the resulting BCO in the monad.  Also requires the
 115 -- variable to which this value was bound, so as to give the
 116 -- resulting BCO a name.
 117 schemeR :: (Id, AnnExpr Id VarSet) -> BcM ()
 118 schemeR (nm, rhs) = schemeR_wrk nm (collect [] rhs)
 119
 120 collect xs (_, AnnLam x e) = collect (x:xs) e
 121 collect xs not_lambda      = (reverse xs, not_lambda)
 122
 123 schemeR_wrk nm (args, body)
 124    = let fvs       = fst body
 125          all_args  = varSetElems fvs ++ args
 126          szsw_args = map idSizeW all_args
 127          szw_args  = sum szsw_args
 128          p_init    = listToFM (zip all_args (scanl (+) 0 szsw_args))
 129          argcheck  = if null args then nilOL else unitOL (ARGCHECK szw_args)
 130      in
 131      schemeE szw_args 0 p_init body             `thenBc` \ body_code ->
 132      emitBc (BCO (getName nm) (appOL argcheck body_code))
 133
 134
 135 -- Compile code to apply the given expression to the remaining args
 136 -- on the stack, returning a HNF.
 137 schemeE :: Int -> Sequel -> BCEnv -> AnnExpr Id VarSet -> BcM BCInstrList
 138
 139 -- Delegate tail-calls to schemeT.
 140 schemeE d s p (fvs, AnnApp f a) = returnBc (schemeT d s 0 p (fvs, AnnApp f a))
 141 schemeE d s p (fvs, AnnVar v)   = returnBc (schemeT d s 0 p (fvs, AnnVar v))
 142
 143 schemeE d s p (fvs, AnnLet binds b)
 144    = let (xs,rhss) = case binds of AnnNonRec x rhs  -> ([x],[rhs])
 145                                    AnnRec xs_n_rhss -> unzip xs_n_rhss
 146      in
 147      mapBc schemeR (zip xs rhss)                        `thenBc_`
 148      let n     = length xs
 149          fvss  = map (varSetElems.fst) rhss
 150          sizes = map (\rhs_fvs -> 1 + sum (map idSizeW rhs_fvs)) fvss
 151          p'    = addListToFM p (zipE xs [d .. d+n-1])
 152          d'    = d + n
 153          infos = zipE4 fvss sizes xs [n, n-1 .. 1]
 154          zipE  = zipEqual "schemeE"
 155          zipE4 = zipWith4Equal "schemeE" (\a b c d -> (a,b,c,d))
 156
 157          -- ToDo: don't build thunks for things with no free variables
 158          buildThunk (fvs, size, id, off)
 159             = case unzip (map (pushAtom d' p . AnnVar) (reverse fvs)) of
 160                 (push_codes, pushed_szsw)
 161                    -> ASSERT(sum pushed_szsw == size - 1)
 162                             (toOL push_codes `snocOL` PUSH_G (getName id)
 163                                              `appOL` unitOL (MKAP off size))
 164
 165          thunkCode = concatOL (map buildThunk infos)
 166          allocCode = toOL (map ALLOC sizes)
 167      in
 168      schemeE d' s p' b                                  `thenBc` \ bodyCode ->
 169      mapBc schemeR (zip xs rhss)                        `thenBc` \_ ->
 170      returnBc (allocCode `appOL` thunkCode `appOL` bodyCode)
 171
 172
 173 schemeE d s p (fvs, AnnCase scrut bndr alts)
 174    = let
 175         -- Top of stack is the return itbl, as usual.
 176         -- underneath it is the pointer to the alt_code BCO.
 177         -- When an alt is entered, it assumes the returned value is
 178         -- on top of the itbl.
 179         ret_frame_sizeW = 2
 180
 181         -- Env and depth in which to compile the alts, not including
 182         -- any vars bound by the alts themselves
 183         d' = d + ret_frame_sizeW + idSizeW bndr
 184         p' = addToFM p bndr d'
 185
 186         (case_instr, isAlgCase)
 187            = case typePrimRep (idType bndr) of
 188                 IntRep -> (CASE_INT, False)
 189                 FloatRep -> (CASE_FLOAT, False)
 190                 DoubleRep -> (CASE_DOUBLE, False)
 191                 PtrRep -> (CASE_PTR, True)
 192                 other -> pprPanic "ByteCodeGen.schemeE" (ppr other)
 193
 194         -- make the code for an alt
 195         codeAlt (discr, binds, rhs)
 196            | isAlgCase
 197            = let binds_szsw = map idSizeW binds
 198                  binds_szw  = sum binds_szsw
 199                  p'' = addListToFM p' (zip binds (scanl (+) d' binds_szsw))
 200                  d'' = d' + binds_szw
 201              in schemeE d'' s p'' rhs   `thenBc` \ rhs_code ->
 202                 returnBc (UNPACK binds_szw `consOL` rhs_code)
 203            | otherwise
 204            = ASSERT(null binds) schemeE d' s p' rhs
 205
 206         discr (DEFAULT, binds, rhs)  = NoDiscr
 207         discr (DataAlt dc, binds, rhs) = DiscrP (dataConTag dc - fIRST_TAG)
 208         discr (LitAlt l, binds, rhs)
 209            = case l of MachInt i     -> DiscrI (fromInteger i)
 210                        MachFloat r   -> DiscrF r
 211                        MachDouble r  -> DiscrD r
 212
 213         discrs = map discr alts
 214      in
 215      mapBc codeAlt alts                                 `thenBc` \ alt_codes ->
 216      let
 217          alt_code     = case_instr (zip discrs alt_codes)
 218          alt_bco_name = getName bndr
 219          alt_bco      = BCO alt_bco_name (unitOL alt_code)
 220      in
 221      schemeE (d + ret_frame_sizeW)
 222              (d + ret_frame_sizeW) p scrut              `thenBc` \ scrut_code ->
 223
 224      emitBc alt_bco                                     `thenBc_`
 225      returnBc (PUSH_ALTS alt_bco_name `consOL` scrut_code)
 226
 227
 228 -- Compile code to do a tail call.  Doesn't need to be monadic.
 229 schemeT :: Int -> Sequel -> Int -> BCEnv -> AnnExpr Id VarSet -> BCInstrList
 230
 231 schemeT d s narg_words p (_, AnnApp f a)
 232    = let (push, arg_words) = pushAtom d p (snd a)
 233      in push
 234         `consOL` schemeT (d+arg_words) s (narg_words+arg_words) p f
 235
 236 schemeT d s narg_words p (_, AnnVar f)
 237    | Just con <- isDataConId_maybe f
 238    = PACK con narg_words `consOL` SLIDE 1 (d-s-1) `consOL` unitOL ENTER
 239    | otherwise
 240    = let (push, arg_words) = pushAtom d p (AnnVar f)
 241      in push
 242         `consOL` SLIDE (narg_words+arg_words) (d - s - narg_words)
 243         `consOL` unitOL ENTER
 244
 245
 246 -- Push an atom onto the stack, returning suitable code & number of
 247 -- stack words used.
 248 pushAtom d p (AnnVar v)
 249    = case lookupBCEnv_maybe p v of
 250         Just offset -> (PUSH_L sz offset, sz)
 251         Nothing     -> ASSERT(sz == 1) (PUSH_G nm, 1)
 252      where
 253         nm = getName v
 254         sz = idSizeW v
 255
 256 pushAtom d p (AnnLit lit)
 257    = case lit of
 258         MachInt i -> (PUSH_I i, 2)
 259 \end{code}
 260
 261 The bytecode generator's monad.
 262
 263 \begin{code}
 264 type BcM_State = [BCO Name]             -- accumulates completed BCOs
 265
 266 type BcM result = BcM_State -> (result, BcM_State)
 267
 268 mkBcM_State :: [BCO Name] -> BcM_State
 269 mkBcM_State = id
 270
 271 initBc :: BcM_State -> BcM a -> (a, BcM_State)
 272 initBc init_st m = case m init_st of { (r,st) -> (r,st) }
 273
 274 thenBc :: BcM a -> (a -> BcM b) -> BcM b
 275 thenBc expr cont st
 276   = case expr st of { (result, st') -> cont result st' }
 277
 278 thenBc_ :: BcM a -> BcM b -> BcM b
 279 thenBc_ expr cont st
 280   = case expr st of { (result, st') -> cont st' }
 281
 282 returnBc :: a -> BcM a
 283 returnBc result st = (result, st)
 284
 285 mapBc :: (a -> BcM b) -> [a] -> BcM [b]
 286 mapBc f []     = returnBc []
 287 mapBc f (x:xs)
 288   = f x          `thenBc` \ r  ->
 289     mapBc f xs   `thenBc` \ rs ->
 290     returnBc (r:rs)
 291
 292 emitBc :: BCO Name -> BcM ()
 293 emitBc bco bcos
 294    = ((), bcos)
 295 \end{code}