From: sewardj Date: Mon, 4 Dec 2000 16:02:20 +0000 (+0000) Subject: [project @ 2000-12-04 16:02:20 by sewardj] X-Git-Tag: Approximately_9120_patches~3208 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=5b54f875651ec0d098651507345ae8d2204ec39e;p=ghc-hetmet.git [project @ 2000-12-04 16:02:20 by sewardj] First shot at the bytecode generator. It isn't yet connected to the rest of GHCi, and doesn't have a way to assemble the bytecodes, but at least it typechecks :-) --- diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs new file mode 100644 index 0000000..340afdd --- /dev/null +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -0,0 +1,295 @@ +% +% (c) The University of Glasgow 2000 +% +\section[ByteCodeGen]{Generate bytecode from Core} + +\begin{code} +module ByteCodeGen ( byteCodeGen ) where + +#include "HsVersions.h" + +--import Id +--import Name +--import PrimOp + +import Outputable +import Name ( Name, getName ) +import Id ( Id, idType, isDataConId_maybe ) +import OrdList ( OrdList, consOL, snocOL, appOL, unitOL, + nilOL, toOL, concatOL ) +import FiniteMap ( FiniteMap, addListToFM, listToFM, + addToFM, lookupFM, fmToList ) +import CoreSyn +import Literal ( Literal(..) ) +import PrimRep ( PrimRep(..) ) +import CoreFVs ( freeVars ) +import Type ( typePrimRep ) +import DataCon ( DataCon, dataConTag, fIRST_TAG ) +import Util ( zipEqual, zipWith4Equal ) +import VarSet ( VarSet, varSetElems ) +--import FastTypes +\end{code} + +Entry point. + +\begin{code} +byteCodeGen :: [CoreBind] -> [BCO Name] +byteCodeGen binds + = let flatBinds = concatMap getBind binds + getBind (NonRec bndr rhs) = [(bndr, freeVars rhs)] + getBind (Rec binds) = [(bndr, freeVars rhs) | (bndr,rhs) <- binds] + in + snd (initBc [] (mapBc schemeR flatBinds)) +\end{code} + +The real machinery. + +\begin{code} +data BCInstr + -- Messing with the stack + = ARGCHECK Int + | PUSH_L Int{-size-} Int{-offset-} + | PUSH_G Name + | PUSH_ALTS Name{-labels the alt BCO; derived from case binder-} + | PUSH_I Integer + | SLIDE Int{-this many-} Int{-down by this much-} + -- To do with the heap + | ALLOC Int + | MKAP Int{-place ptr to heap this far down stack-} Int{-# words-} + | UNPACK Int + | PACK DataCon Int + -- Casery (in French: caseage) + | CASE_PTR [(Discr, BCInstrList)] + | CASE_INT [(Discr, BCInstrList)] + | CASE_FLOAT [(Discr, BCInstrList)] + | CASE_DOUBLE [(Discr, BCInstrList)] + -- To Infinity And Beyond + | ENTER + + +type BCInstrList = OrdList BCInstr + +data BCO a = BCO a BCInstrList + + +type Sequel = Int -- back off to this depth before ENTER + +-- Maps Ids to the offset from the stack _base_ so we don't have +-- to mess with it after each push/pop. +type BCEnv = FiniteMap Id Int -- To find vars on the stack + +lookupBCEnv :: BCEnv -> Id -> Int +lookupBCEnv env nm + = case lookupFM env nm of + Nothing -> pprPanic "lookupBCEnv" + (ppr nm $$ char ' ' $$ vcat (map ppr (fmToList env))) + Just xx -> xx + +lookupBCEnv_maybe :: BCEnv -> Id -> Maybe Int +lookupBCEnv_maybe = lookupFM + + +-- Describes case alts +data Discr + = DiscrI Int + | DiscrF Rational + | DiscrD Rational + | DiscrP Int + | NoDiscr + +-- Hmm. This isn't really right (ie on Alpha, idSizeW Double -> 2) +-- There must be an Officially Approved way to do this somewhere. +idSizeW :: Id -> Int +idSizeW nm + = let pr = typePrimRep (idType nm) + in case pr of IntRep -> 2 + FloatRep -> 2 + DoubleRep -> 3 + PtrRep -> 1 + other -> pprPanic "ByteCodeGen.idSizeW" (ppr pr) + + + +-- Compile code for the right hand side of a let binding. +-- Park the resulting BCO in the monad. Also requires the +-- variable to which this value was bound, so as to give the +-- resulting BCO a name. +schemeR :: (Id, AnnExpr Id VarSet) -> BcM () +schemeR (nm, rhs) = schemeR_wrk nm (collect [] rhs) + +collect xs (_, AnnLam x e) = collect (x:xs) e +collect xs not_lambda = (reverse xs, not_lambda) + +schemeR_wrk nm (args, body) + = let fvs = fst body + all_args = varSetElems fvs ++ args + szsw_args = map idSizeW all_args + szw_args = sum szsw_args + p_init = listToFM (zip all_args (scanl (+) 0 szsw_args)) + argcheck = if null args then nilOL else unitOL (ARGCHECK szw_args) + in + schemeE szw_args 0 p_init body `thenBc` \ body_code -> + emitBc (BCO (getName nm) (appOL argcheck body_code)) + + +-- Compile code to apply the given expression to the remaining args +-- on the stack, returning a HNF. +schemeE :: Int -> Sequel -> BCEnv -> AnnExpr Id VarSet -> BcM BCInstrList + +-- Delegate tail-calls to schemeT. +schemeE d s p (fvs, AnnApp f a) = returnBc (schemeT d s 0 p (fvs, AnnApp f a)) +schemeE d s p (fvs, AnnVar v) = returnBc (schemeT d s 0 p (fvs, AnnVar v)) + +schemeE d s p (fvs, AnnLet binds b) + = let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs]) + AnnRec xs_n_rhss -> unzip xs_n_rhss + in + mapBc schemeR (zip xs rhss) `thenBc_` + let n = length xs + fvss = map (varSetElems.fst) rhss + sizes = map (\rhs_fvs -> 1 + sum (map idSizeW rhs_fvs)) fvss + p' = addListToFM p (zipE xs [d .. d+n-1]) + d' = d + n + infos = zipE4 fvss sizes xs [n, n-1 .. 1] + zipE = zipEqual "schemeE" + zipE4 = zipWith4Equal "schemeE" (\a b c d -> (a,b,c,d)) + + -- ToDo: don't build thunks for things with no free variables + buildThunk (fvs, size, id, off) + = case unzip (map (pushAtom d' p . AnnVar) (reverse fvs)) of + (push_codes, pushed_szsw) + -> ASSERT(sum pushed_szsw == size - 1) + (toOL push_codes `snocOL` PUSH_G (getName id) + `appOL` unitOL (MKAP off size)) + + thunkCode = concatOL (map buildThunk infos) + allocCode = toOL (map ALLOC sizes) + in + schemeE d' s p' b `thenBc` \ bodyCode -> + mapBc schemeR (zip xs rhss) `thenBc` \_ -> + returnBc (allocCode `appOL` thunkCode `appOL` bodyCode) + + +schemeE d s p (fvs, AnnCase scrut bndr alts) + = let + -- Top of stack is the return itbl, as usual. + -- underneath it is the pointer to the alt_code BCO. + -- When an alt is entered, it assumes the returned value is + -- on top of the itbl. + ret_frame_sizeW = 2 + + -- Env and depth in which to compile the alts, not including + -- any vars bound by the alts themselves + d' = d + ret_frame_sizeW + idSizeW bndr + p' = addToFM p bndr d' + + (case_instr, isAlgCase) + = case typePrimRep (idType bndr) of + IntRep -> (CASE_INT, False) + FloatRep -> (CASE_FLOAT, False) + DoubleRep -> (CASE_DOUBLE, False) + PtrRep -> (CASE_PTR, True) + other -> pprPanic "ByteCodeGen.schemeE" (ppr other) + + -- make the code for an alt + codeAlt (discr, binds, rhs) + | isAlgCase + = let binds_szsw = map idSizeW binds + binds_szw = sum binds_szsw + p'' = addListToFM p' (zip binds (scanl (+) d' binds_szsw)) + d'' = d' + binds_szw + in schemeE d'' s p'' rhs `thenBc` \ rhs_code -> + returnBc (UNPACK binds_szw `consOL` rhs_code) + | otherwise + = ASSERT(null binds) schemeE d' s p' rhs + + discr (DEFAULT, binds, rhs) = NoDiscr + discr (DataAlt dc, binds, rhs) = DiscrP (dataConTag dc - fIRST_TAG) + discr (LitAlt l, binds, rhs) + = case l of MachInt i -> DiscrI (fromInteger i) + MachFloat r -> DiscrF r + MachDouble r -> DiscrD r + + discrs = map discr alts + in + mapBc codeAlt alts `thenBc` \ alt_codes -> + let + alt_code = case_instr (zip discrs alt_codes) + alt_bco_name = getName bndr + alt_bco = BCO alt_bco_name (unitOL alt_code) + in + schemeE (d + ret_frame_sizeW) + (d + ret_frame_sizeW) p scrut `thenBc` \ scrut_code -> + + emitBc alt_bco `thenBc_` + returnBc (PUSH_ALTS alt_bco_name `consOL` scrut_code) + + +-- Compile code to do a tail call. Doesn't need to be monadic. +schemeT :: Int -> Sequel -> Int -> BCEnv -> AnnExpr Id VarSet -> BCInstrList + +schemeT d s narg_words p (_, AnnApp f a) + = let (push, arg_words) = pushAtom d p (snd a) + in push + `consOL` schemeT (d+arg_words) s (narg_words+arg_words) p f + +schemeT d s narg_words p (_, AnnVar f) + | Just con <- isDataConId_maybe f + = PACK con narg_words `consOL` SLIDE 1 (d-s-1) `consOL` unitOL ENTER + | otherwise + = let (push, arg_words) = pushAtom d p (AnnVar f) + in push + `consOL` SLIDE (narg_words+arg_words) (d - s - narg_words) + `consOL` unitOL ENTER + + +-- Push an atom onto the stack, returning suitable code & number of +-- stack words used. +pushAtom d p (AnnVar v) + = case lookupBCEnv_maybe p v of + Just offset -> (PUSH_L sz offset, sz) + Nothing -> ASSERT(sz == 1) (PUSH_G nm, 1) + where + nm = getName v + sz = idSizeW v + +pushAtom d p (AnnLit lit) + = case lit of + MachInt i -> (PUSH_I i, 2) +\end{code} + +The bytecode generator's monad. + +\begin{code} +type BcM_State = [BCO Name] -- accumulates completed BCOs + +type BcM result = BcM_State -> (result, BcM_State) + +mkBcM_State :: [BCO Name] -> BcM_State +mkBcM_State = id + +initBc :: BcM_State -> BcM a -> (a, BcM_State) +initBc init_st m = case m init_st of { (r,st) -> (r,st) } + +thenBc :: BcM a -> (a -> BcM b) -> BcM b +thenBc expr cont st + = case expr st of { (result, st') -> cont result st' } + +thenBc_ :: BcM a -> BcM b -> BcM b +thenBc_ expr cont st + = case expr st of { (result, st') -> cont st' } + +returnBc :: a -> BcM a +returnBc result st = (result, st) + +mapBc :: (a -> BcM b) -> [a] -> BcM [b] +mapBc f [] = returnBc [] +mapBc f (x:xs) + = f x `thenBc` \ r -> + mapBc f xs `thenBc` \ rs -> + returnBc (r:rs) + +emitBc :: BCO Name -> BcM () +emitBc bco bcos + = ((), bcos) +\end{code}