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