X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FByteCodeGen.lhs;h=d8f3032adfa6475d1c766d063291c0c0add30ec1;hb=0e42215db2bb7eaee9682fce1b2e95a06a8a955d;hp=da7f6dff7471419275c8fb5169c67b8198252438;hpb=15d82a553b8591e84d15f5eafa4a8d79be65bbd7;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index da7f6df..d8f3032 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -4,146 +4,124 @@ \section[ByteCodeGen]{Generate bytecode from Core} \begin{code} -module ByteCodeGen ( byteCodeGen, assembleBCO ) where +module ByteCodeGen ( UnlinkedBCO, UnlinkedBCOExpr, ItblEnv, ClosureEnv, HValue, + filterNameMap, + byteCodeGen, coreExprToBCOs + ) where #include "HsVersions.h" import Outputable import Name ( Name, getName ) -import Id ( Id, idType, isDataConId_maybe ) +import Id ( Id, idType, isDataConId_maybe, isPrimOpId_maybe, + idPrimRep, mkSysLocal, idName ) import OrdList ( OrdList, consOL, snocOL, appOL, unitOL, nilOL, toOL, concatOL, fromOL ) -import FiniteMap ( FiniteMap, addListToFM, listToFM, - addToFM, lookupFM, fmToList, emptyFM ) +import FiniteMap ( FiniteMap, addListToFM, listToFM, + addToFM, lookupFM, fmToList ) import CoreSyn -import PprCore ( pprCoreExpr, pprCoreAlt ) -import Literal ( Literal(..) ) +import PprCore ( pprCoreExpr ) +import Literal ( Literal(..), literalPrimRep ) import PrimRep ( PrimRep(..) ) +import PrimOp ( PrimOp(..) ) import CoreFVs ( freeVars ) -import Type ( typePrimRep ) -import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon ) -import TyCon ( tyConFamilySize ) +import Type ( typePrimRep, splitTyConApp_maybe ) +import DataCon ( dataConTag, fIRST_TAG, dataConTyCon, + dataConWrapId, isUnboxedTupleCon ) +import TyCon ( TyCon(..), tyConFamilySize, isDataTyCon, tyConDataCons ) +import Class ( Class, classTyCon ) import Util ( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem ) import Var ( isTyVar ) import VarSet ( VarSet, varSetElems ) import PrimRep ( getPrimRepSize, isFollowableRep ) -import Constants ( wORD_SIZE ) - -import Foreign ( Addr, Word16, Word32, nullAddr ) -import ST ( runST ) -import MutableArray ( readWord32Array, - newFloatArray, writeFloatArray, - newDoubleArray, writeDoubleArray, - newIntArray, writeIntArray, - newAddrArray, writeAddrArray ) -\end{code} - -Entry point. +import CmdLineOpts ( DynFlags, DynFlag(..) ) +import ErrUtils ( showPass, dumpIfSet_dyn ) +import Unique ( mkPseudoUnique3 ) +import FastString ( FastString(..) ) +import Panic ( GhcException(..) ) +import PprType ( pprType ) +import ByteCodeInstr ( BCInstr(..), ProtoBCO(..), nameOfProtoBCO, bciStackUse ) +import ByteCodeItbls ( ItblEnv, mkITbls ) +import ByteCodeLink ( UnlinkedBCO, UnlinkedBCOExpr, assembleBCO, + ClosureEnv, HValue, filterNameMap, + iNTERP_STACK_CHECK_THRESH ) + +import List ( intersperse, sortBy, zip4 ) +import Foreign ( Ptr(..), mallocBytes ) +import Addr ( Addr(..), addrToInt, writeCharOffAddr ) +import CTypes ( CInt ) +import Exception ( throwDyn ) + +import PrelBase ( Int(..) ) +import PrelGHC ( ByteArray# ) +import IOExts ( unsafePerformIO ) +import PrelIOBase ( IO(..) ) -\begin{code} -byteCodeGen :: [CoreBind] -> [ProtoBCO Name] -byteCodeGen binds - = let flatBinds = concatMap getBind binds - getBind (NonRec bndr rhs) = [(bndr, freeVars rhs)] - getBind (Rec binds) = [(bndr, freeVars rhs) | (bndr,rhs) <- binds] - final_state = runBc (BcM_State [] 0) - (mapBc schemeR flatBinds `thenBc_` returnBc ()) - in - case final_state of - BcM_State bcos final_ctr -> bcos \end{code} - %************************************************************************ %* * -\subsection{Bytecodes, and Outputery.} +\subsection{Functions visible from outside this module.} %* * %************************************************************************ \begin{code} -type LocalLabel = Int - -data BCInstr - -- Messing with the stack - = ARGCHECK Int - | PUSH_L Int{-offset-} - | PUSH_LL Int Int{-2 offsets-} - | PUSH_LLL Int Int Int{-3 offsets-} - | PUSH_G Name - | PUSH_AS Name --Int -- push alts and BCO_ptr_ret_info - -- Int is lit pool offset for itbl - | PUSH_LIT Int -- push literal word from offset pool - | PUSH_TAG Int -- push this tag on the stack - | PUSHU_I Int -- push this int, NO TAG, on the stack - | PUSHU_F Float -- ... float ... - | PUSHU_D Double -- ... double ... - | SLIDE Int{-this many-} Int{-down by this much-} - -- To do with the heap - | ALLOC Int -- make an AP_UPD with this many payload words, zeroed - | MKAP Int{-ptr to AP_UPD is this far down stack-} Int{-# words-} - | UNPACK Int -- unpack N ptr words from t.o.s Constr - | UNPACK_I Int -- unpack and tag an Int, from t.o.s Constr @ offset - | UNPACK_F Int -- unpack and tag a Float, from t.o.s Constr @ offset - | UNPACK_D Int -- unpack and tag a Double, from t.o.s Constr @ offset - | PACK DataCon Int - -- For doing case trees - | LABEL LocalLabel - | TESTLT_I Int LocalLabel - | TESTEQ_I Int LocalLabel - | TESTLT_F Float LocalLabel - | TESTEQ_F Float LocalLabel - | TESTLT_D Double LocalLabel - | TESTEQ_D Double LocalLabel - | TESTLT_P Int LocalLabel - | TESTEQ_P Int LocalLabel - | CASEFAIL - -- To Infinity And Beyond - | ENTER - | RETURN -- unboxed value on TOS. Use tag to find underlying ret itbl - -- and return as per that. - - -instance Outputable BCInstr where - ppr (ARGCHECK n) = text "ARGCHECK" <+> int n - ppr (PUSH_L offset) = text "PUSH_L " <+> int offset - ppr (PUSH_LL o1 o2) = text "PUSH_LL " <+> int o1 <+> int o2 - ppr (PUSH_LLL o1 o2 o3) = text "PUSH_LLL" <+> int o1 <+> int o2 <+> int o3 - ppr (PUSH_G nm) = text "PUSH_G " <+> ppr nm - ppr (PUSH_AS nm) = text "PUSH_AS " <+> ppr nm - ppr (PUSHU_I i) = text "PUSHU_I " <+> int i - ppr (SLIDE n d) = text "SLIDE " <+> int n <+> int d - ppr (ALLOC sz) = text "ALLOC " <+> int sz - ppr (MKAP offset sz) = text "MKAP " <+> int offset <+> int sz - ppr (UNPACK sz) = text "UNPACK " <+> int sz - ppr (UNPACK_I sz) = text "UNPACK_I" <+> int sz - ppr (UNPACK_F sz) = text "UNPACK_F" <+> int sz - ppr (UNPACK_D sz) = text "UNPACK_D" <+> int sz - ppr (PACK dcon sz) = text "PACK " <+> ppr dcon <+> ppr sz - ppr (LABEL lab) = text "__" <> int lab <> colon - ppr (TESTLT_I i lab) = text "TESTLT_I" <+> int i <+> text "__" <> int lab - ppr (TESTEQ_I i lab) = text "TESTEQ_I" <+> int i <+> text "__" <> int lab - ppr (TESTLT_F f lab) = text "TESTLT_F" <+> float f <+> text "__" <> int lab - ppr (TESTEQ_F f lab) = text "TESTEQ_F" <+> float f <+> text "__" <> int lab - ppr (TESTLT_D d lab) = text "TESTLT_D" <+> double d <+> text "__" <> int lab - ppr (TESTEQ_D d lab) = text "TESTEQ_D" <+> double d <+> text "__" <> int lab - ppr (TESTLT_P i lab) = text "TESTLT_P" <+> int i <+> text "__" <> int lab - ppr (TESTEQ_P i lab) = text "TESTEQ_P" <+> int i <+> text "__" <> int lab - ppr CASEFAIL = text "CASEFAIL" - ppr ENTER = text "ENTER" - ppr RETURN = text "RETURN" - -pprAltCode discrs_n_codes - = vcat (map f discrs_n_codes) - where f (discr, code) = ppr discr <> colon <+> vcat (map ppr (fromOL code)) - -instance Outputable a => Outputable (ProtoBCO a) where - ppr (ProtoBCO name instrs origin) - = (text "ProtoBCO" <+> ppr name <> colon) - $$ nest 6 (vcat (map ppr instrs)) - $$ case origin of - Left alts -> vcat (map (pprCoreAlt.deAnnAlt) alts) - Right rhs -> pprCoreExpr (deAnnotate rhs) +byteCodeGen :: DynFlags + -> [CoreBind] + -> [TyCon] -> [Class] + -> IO ([UnlinkedBCO], ItblEnv) +byteCodeGen dflags binds local_tycons local_classes + = do showPass dflags "ByteCodeGen" + let tycs = local_tycons ++ map classTyCon local_classes + itblenv <- mkITbls tycs + + let flatBinds = concatMap getBind binds + getBind (NonRec bndr rhs) = [(bndr, freeVars rhs)] + getBind (Rec binds) = [(bndr, freeVars rhs) | (bndr,rhs) <- binds] + final_state = runBc (BcM_State [] 0) + (mapBc (schemeR True) flatBinds + `thenBc_` returnBc ()) + (BcM_State proto_bcos final_ctr) = final_state + + dumpIfSet_dyn dflags Opt_D_dump_BCOs + "Proto-bcos" (vcat (intersperse (char ' ') (map ppr proto_bcos))) + + bcos <- mapM assembleBCO proto_bcos + + return (bcos, itblenv) + + +-- Returns: (the root BCO for this expression, +-- a list of auxilary BCOs resulting from compiling closures) +coreExprToBCOs :: DynFlags + -> CoreExpr + -> IO UnlinkedBCOExpr +coreExprToBCOs dflags expr + = do showPass dflags "ByteCodeGen" + + -- create a totally bogus name for the top-level BCO; this + -- should be harmless, since it's never used for anything + let invented_id = mkSysLocal SLIT("Expr-Top-Level") (mkPseudoUnique3 0) + (panic "invented_id's type") + let invented_name = idName invented_id + + let (BcM_State all_proto_bcos final_ctr) + = runBc (BcM_State [] 0) + (schemeR True (invented_id, freeVars expr)) + dumpIfSet_dyn dflags Opt_D_dump_BCOs + "Proto-bcos" (vcat (intersperse (char ' ') (map ppr all_proto_bcos))) + + let root_proto_bco + = case filter ((== invented_name).nameOfProtoBCO) all_proto_bcos of + [root_bco] -> root_bco + auxiliary_proto_bcos + = filter ((/= invented_name).nameOfProtoBCO) all_proto_bcos + + auxiliary_bcos <- mapM assembleBCO auxiliary_proto_bcos + root_bco <- assembleBCO root_proto_bco + + return (root_bco, auxiliary_bcos) \end{code} %************************************************************************ @@ -156,30 +134,53 @@ instance Outputable a => Outputable (ProtoBCO a) where type BCInstrList = OrdList BCInstr -data ProtoBCO a - = ProtoBCO a -- name, in some sense - [BCInstr] -- instrs - -- what the BCO came from - (Either [AnnAlt Id VarSet] - (AnnExpr Id VarSet)) - - 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 +ppBCEnv :: BCEnv -> SDoc +ppBCEnv p + = text "begin-env" + $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (fmToList p)))) + $$ text "end-env" + where + pp_one (var, offset) = int offset <> colon <+> ppr var + cmp_snd x y = compare (snd x) (snd y) -- Create a BCO and do a spot of peephole optimisation on the insns -- at the same time. mkProtoBCO nm instrs_ordlist origin - = ProtoBCO nm (peep (fromOL instrs_ordlist)) origin + = ProtoBCO nm maybe_with_stack_check origin where + -- Overestimate the stack usage (in words) of this BCO, + -- and if >= iNTERP_STACK_CHECK_THRESH, add an explicit + -- stack check. (The interpreter always does a stack check + -- for iNTERP_STACK_CHECK_THRESH words at the start of each + -- BCO anyway, so we only need to add an explicit on in the + -- (hopefully rare) cases when the (overestimated) stack use + -- exceeds iNTERP_STACK_CHECK_THRESH. + maybe_with_stack_check + | stack_overest >= 65535 + = pprPanic "mkProtoBCO: stack use won't fit in 16 bits" + (int stack_overest) + | stack_overest >= iNTERP_STACK_CHECK_THRESH + = (STKCHECK stack_overest) : peep_d + | otherwise + = peep_d -- the supposedly common case + + stack_overest = sum (map bciStackUse peep_d) + + 10 {- just to be really really sure -} + + + -- Merge local pushes + peep_d = peep (fromOL instrs_ordlist) + peep (PUSH_L off1 : PUSH_L off2 : PUSH_L off3 : rest) = PUSH_LLL off1 (off2-1) (off3-2) : peep rest peep (PUSH_L off1 : PUSH_L off2 : rest) - = PUSH_LL off1 off2 : peep rest + = PUSH_LL off1 (off2-1) : peep rest peep (i:rest) = i : peep rest peep [] @@ -189,25 +190,63 @@ mkProtoBCO nm instrs_ordlist origin -- 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 rhs nm (collect [] rhs) +-- resulting BCO a name. Bool indicates top-levelness. + +schemeR :: Bool -> (Id, AnnExpr Id VarSet) -> BcM () +schemeR is_top (nm, rhs) +{- + | trace (showSDoc ( + (char ' ' + $$ (ppr.filter (not.isTyVar).varSetElems.fst) rhs + $$ pprCoreExpr (deAnnotate rhs) + $$ char ' ' + ))) False + = undefined +-} + | otherwise + = schemeR_wrk is_top rhs nm (collect [] rhs) + +collect xs (_, AnnNote note e) + = collect xs e collect xs (_, AnnLam x e) = collect (if isTyVar x then xs else (x:xs)) e collect xs not_lambda = (reverse xs, not_lambda) -schemeR_wrk original_body nm (args, body) +schemeR_wrk is_top original_body nm (args, body) + | Just dcon <- maybe_toplevel_null_con_rhs + = --trace ("nullary constructor! " ++ showSDocDebug (ppr nm)) ( + emitBc (mkProtoBCO (getName nm) (toOL [PACK dcon 0, ENTER]) + (Right original_body)) + --) + + | otherwise = let fvs = filter (not.isTyVar) (varSetElems (fst original_body)) - all_args = fvs ++ reverse args + all_args = reverse args ++ fvs szsw_args = map taggedIdSizeW all_args szw_args = sum szsw_args p_init = listToFM (zip all_args (mkStackOffsets 0 szsw_args)) - argcheck = if null args then nilOL else unitOL (ARGCHECK szw_args) + argcheck = unitOL (ARGCHECK szw_args) in schemeE szw_args 0 p_init body `thenBc` \ body_code -> - emitBc (mkProtoBCO (getName nm) (appOL argcheck body_code) (Right original_body)) + emitBc (mkProtoBCO (getName nm) (appOL argcheck body_code) + (Right original_body)) + + where + maybe_toplevel_null_con_rhs + | is_top && null args + = case snd body of + AnnVar v_wrk + -> case isDataConId_maybe v_wrk of + Nothing -> Nothing + Just dc_wrk | nm == dataConWrapId dc_wrk + -> Just dc_wrk + | otherwise + -> Nothing + other -> Nothing + | otherwise + = Nothing -- Let szsw be the sizes in words of some items pushed onto the stack, -- which has initial depth d'. Return the values which the stack environment @@ -222,28 +261,34 @@ schemeE :: Int -> Sequel -> BCEnv -> AnnExpr Id VarSet -> BcM BCInstrList -- Delegate tail-calls to schemeT. schemeE d s p e@(fvs, AnnApp f a) - = returnBc (schemeT (should_args_be_tagged e) d s 0 p (fvs, AnnApp f a)) + = schemeT d s p (fvs, AnnApp f a) schemeE d s p e@(fvs, AnnVar v) - | isFollowableRep (typePrimRep (idType v)) - = returnBc (schemeT (should_args_be_tagged e) d s 0 p (fvs, AnnVar v)) + | isFollowableRep v_rep + = schemeT d s p (fvs, AnnVar v) + | otherwise = -- returning an unboxed value. Heave it on the stack, SLIDE, and RETURN. let (push, szw) = pushAtom True d p (AnnVar v) in returnBc (push -- value onto stack - `snocOL` SLIDE szw (d-s) -- clear to sequel - `snocOL` RETURN) -- go + `appOL` mkSLIDE szw (d-s) -- clear to sequel + `snocOL` RETURN v_rep) -- go + where + v_rep = typePrimRep (idType v) schemeE d s p (fvs, AnnLit literal) = let (push, szw) = pushAtom True d p (AnnLit literal) + l_rep = literalPrimRep literal in returnBc (push -- value onto stack - `snocOL` SLIDE szw (d-s) -- clear to sequel - `snocOL` RETURN) -- go + `appOL` mkSLIDE szw (d-s) -- clear to sequel + `snocOL` RETURN l_rep) -- go 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 n = length xs fvss = map (filter (not.isTyVar).varSetElems.fst) rhss + + -- Sizes of tagged free vars, + 1 for the fn sizes = map (\rhs_fvs -> 1 + sum (map taggedIdSizeW rhs_fvs)) fvss -- This p', d' defn is safe because all the items being pushed @@ -259,7 +304,7 @@ schemeE d s p (fvs, AnnLet binds b) -- ToDo: don't build thunks for things with no free variables buildThunk dd ([], size, id, off) - = PUSH_G (getName id) + = PUSH_G (Left (getName id)) `consOL` unitOL (MKAP (off+size-1) size) buildThunk dd ((fv:fvs), size, id, off) = case pushAtom True dd p' (AnnVar fv) of @@ -271,7 +316,7 @@ schemeE d s p (fvs, AnnLet binds b) allocCode = toOL (map ALLOC sizes) in schemeE d' s p' b `thenBc` \ bodyCode -> - mapBc schemeR (zip xs rhss) `thenBc_` + mapBc (schemeR False) (zip xs rhss) `thenBc_` returnBc (allocCode `appOL` thunkCode `appOL` bodyCode) @@ -288,35 +333,40 @@ schemeE d s p (fvs, AnnCase scrut bndr alts) d' = d + ret_frame_sizeW + taggedIdSizeW bndr p' = addToFM p bndr (d' - 1) + scrut_primrep = typePrimRep (idType bndr) isAlgCase - = case typePrimRep (idType bndr) of + = case scrut_primrep of + CharRep -> False ; AddrRep -> False ; WordRep -> False IntRep -> False ; FloatRep -> False ; DoubleRep -> False + VoidRep -> False ; PtrRep -> True other -> pprPanic "ByteCodeGen.schemeE" (ppr other) -- given an alt, return a discr and code for it. codeAlt alt@(discr, binds_f, rhs) | isAlgCase - = let binds_r = reverse binds_f - binds_r_szsw = map untaggedIdSizeW binds_r - binds_szw = sum binds_r_szsw - p'' = addListToFM - p' (zip binds_r (mkStackOffsets d' binds_r_szsw)) - d'' = d' + binds_szw - unpack_code = mkUnpackCode 0 (map (typePrimRep.idType) binds_f) - in schemeE d'' s p'' rhs `thenBc` \ rhs_code -> - returnBc (my_discr alt, unpack_code `appOL` rhs_code) + = let (unpack_code, d_after_unpack, p_after_unpack) + = mkUnpackCode binds_f d' p' + in schemeE d_after_unpack s p_after_unpack rhs + `thenBc` \ rhs_code -> + returnBc (my_discr alt, unpack_code `appOL` rhs_code) | otherwise = ASSERT(null binds_f) schemeE d' s p' rhs `thenBc` \ rhs_code -> returnBc (my_discr alt, rhs_code) - my_discr (DEFAULT, binds, rhs) = NoDiscr - my_discr (DataAlt dc, binds, rhs) = DiscrP (dataConTag dc) + my_discr (DEFAULT, binds, rhs) = NoDiscr + my_discr (DataAlt dc, binds, rhs) + | isUnboxedTupleCon dc + = unboxedTupleException + | otherwise + = DiscrP (dataConTag dc - fIRST_TAG) my_discr (LitAlt l, binds, rhs) = case l of MachInt i -> DiscrI (fromInteger i) MachFloat r -> DiscrF (fromRational r) MachDouble r -> DiscrD (fromRational r) + MachChar i -> DiscrI i + _ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l) maybe_ncons | not isAlgCase = Nothing @@ -329,14 +379,15 @@ schemeE d s p (fvs, AnnCase scrut bndr alts) mapBc codeAlt alts `thenBc` \ alt_stuff -> mkMultiBranch maybe_ncons alt_stuff `thenBc` \ alt_final -> let + alt_final_ac = ARGCHECK (taggedIdSizeW bndr) `consOL` alt_final alt_bco_name = getName bndr - alt_bco = mkProtoBCO alt_bco_name alt_final (Left alts) + alt_bco = mkProtoBCO alt_bco_name alt_final_ac (Left alts) in schemeE (d + ret_frame_sizeW) (d + ret_frame_sizeW) p scrut `thenBc` \ scrut_code -> emitBc alt_bco `thenBc_` - returnBc (PUSH_AS alt_bco_name `consOL` scrut_code) + returnBc (PUSH_AS alt_bco_name scrut_primrep `consOL` scrut_code) schemeE d s p (fvs, AnnNote note body) @@ -347,63 +398,233 @@ schemeE d s p other (pprCoreExpr (deAnnotate other)) --- Compile code to do a tail call. Doesn't need to be monadic. -schemeT :: Bool -- do tagging? - -> Int -- Stack depth +-- Compile code to do a tail call. Specifically, push the fn, +-- slide the on-stack app back down to the sequel depth, +-- and enter. Four cases: +-- +-- 0. (Nasty hack). +-- An application "PrelGHC.tagToEnum# unboxed-int". +-- The int will be on the stack. Generate a code sequence +-- to convert it to the relevant constructor, SLIDE and ENTER. +-- +-- 1. A nullary constructor. Push its closure on the stack +-- and SLIDE and RETURN. +-- +-- 2. Application of a non-nullary constructor, by defn saturated. +-- Split the args into ptrs and non-ptrs, and push the nonptrs, +-- then the ptrs, and then do PACK and RETURN. +-- +-- 3. Otherwise, it must be a function call. Push the args +-- right to left, SLIDE and ENTER. + +schemeT :: Int -- Stack depth -> Sequel -- Sequel depth - -> Int -- # arg words so far -> BCEnv -- stack env - -> AnnExpr Id VarSet -> BCInstrList - -schemeT enTag d s narg_words p (_, AnnApp f a) - = case snd a of - AnnType _ -> schemeT enTag d s narg_words p f - other - -> let (push, arg_words) = pushAtom enTag d p (snd a) - in push - `appOL` schemeT enTag (d+arg_words) s (narg_words+arg_words) p f - -schemeT enTag d s narg_words p (_, AnnVar f) - | Just con <- isDataConId_maybe f - = ASSERT(enTag == False) - PACK con narg_words `consOL` (mkSLIDE 1 (d-s-1) `snocOL` ENTER) + -> AnnExpr Id VarSet + -> BcM BCInstrList + +schemeT d s p app +-- | trace ("schemeT: env in = \n" ++ showSDocDebug (ppBCEnv p)) False +-- = panic "schemeT ?!?!" + + -- Handle case 0 + | Just (arg, constr_names) <- maybe_is_tagToEnum_call + = pushAtom True d p arg `bind` \ (push, arg_words) -> + implement_tagToId constr_names `thenBc` \ tagToId_sequence -> + returnBc (push `appOL` tagToId_sequence + `appOL` mkSLIDE 1 (d+arg_words-s) + `snocOL` ENTER) + + -- Handle case 1 + | is_con_call && null args_r_to_l + = returnBc ( + (PUSH_G (Left (getName con)) `consOL` mkSLIDE 1 (d-s)) + `snocOL` ENTER + ) + + -- Cases 2 and 3 | otherwise - = ASSERT(enTag == True) - let (push, arg_words) = pushAtom True d p (AnnVar f) - in push - `appOL` mkSLIDE (narg_words+arg_words) (d - s - narg_words) - `snocOL` ENTER + = if is_con_call && isUnboxedTupleCon con + then returnBc unboxedTupleException + else returnBc code + + where + -- Detect and extract relevant info for the tagToEnum kludge. + maybe_is_tagToEnum_call + = let extract_constr_Names ty + = case splitTyConApp_maybe ty of + (Just (tyc, [])) | isDataTyCon tyc + -> map getName (tyConDataCons tyc) + other + -> panic "maybe_is_tagToEnum_call.extract_constr_Ids" + in + case app of + (_, AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg) + -> case isPrimOpId_maybe v of + Nothing -> Nothing + Just primop | primop == TagToEnumOp + -> Just (snd arg, extract_constr_Names t) + | otherwise + -> Nothing + other -> Nothing + + -- Extract the args (R->L) and fn + (args_r_to_l_raw, fn) = chomp app + chomp expr + = case snd expr of + AnnVar v -> ([], v) + AnnApp f a -> case chomp f of (az, f) -> (snd a:az, f) + AnnNote n e -> chomp e + other -> pprPanic "schemeT" + (ppr (deAnnotate (panic "schemeT.chomp", other))) + + args_r_to_l = filter (not.isTypeAtom) args_r_to_l_raw + isTypeAtom (AnnType _) = True + isTypeAtom _ = False + + -- decide if this is a constructor call, and rearrange + -- args appropriately. + maybe_dcon = isDataConId_maybe fn + is_con_call = case maybe_dcon of Nothing -> False; Just _ -> True + (Just con) = maybe_dcon + + args_final_r_to_l + | not is_con_call + = args_r_to_l + | otherwise + = filter (not.isPtr) args_r_to_l ++ filter isPtr args_r_to_l + where isPtr = isFollowableRep . atomRep + + -- make code to push the args and then do the SLIDE-ENTER thing + code = do_pushery d args_final_r_to_l + + tag_when_push = not is_con_call + narg_words = sum (map (get_arg_szw . atomRep) args_r_to_l) + get_arg_szw = if tag_when_push then taggedSizeW else untaggedSizeW + + do_pushery d (arg:args) + = let (push, arg_words) = pushAtom tag_when_push d p arg + in push `appOL` do_pushery (d+arg_words) args + do_pushery d [] + = case maybe_dcon of + Just con -> PACK con narg_words `consOL` ( + mkSLIDE 1 (d - narg_words - s) `snocOL` ENTER) + Nothing + -> let (push, arg_words) = pushAtom True d p (AnnVar fn) + in push + `appOL` mkSLIDE (narg_words+arg_words) + (d - s - narg_words) + `snocOL` ENTER mkSLIDE n d = if d == 0 then nilOL else unitOL (SLIDE n d) +bind x f + = f x + + +atomRep (AnnVar v) = typePrimRep (idType v) +atomRep (AnnLit l) = literalPrimRep l +atomRep (AnnNote n b) = atomRep (snd b) +atomRep (AnnApp f (_, AnnType _)) = atomRep (snd f) +atomRep (AnnLam x e) | isTyVar x = atomRep (snd e) +atomRep other = pprPanic "atomRep" (ppr (deAnnotate (undefined,other))) + + +-- Compile code which expects an unboxed Int on the top of stack, +-- (call it i), and pushes the i'th closure in the supplied list +-- as a consequence. +implement_tagToId :: [Name] -> BcM BCInstrList +implement_tagToId names + = ASSERT(not (null names)) + getLabelsBc (length names) `thenBc` \ labels -> + getLabelBc `thenBc` \ label_fail -> + getLabelBc `thenBc` \ label_exit -> + zip4 labels (tail labels ++ [label_fail]) + [0 ..] names `bind` \ infos -> + map (mkStep label_exit) infos `bind` \ steps -> + returnBc (concatOL steps + `appOL` + toOL [LABEL label_fail, CASEFAIL, LABEL label_exit]) + where + mkStep l_exit (my_label, next_label, n, name_for_n) + = toOL [LABEL my_label, + TESTEQ_I n next_label, + PUSH_G (Left name_for_n), + JMP l_exit] -should_args_be_tagged (_, AnnVar v) - = case isDataConId_maybe v of - Just dcon -> False; Nothing -> True -should_args_be_tagged (_, AnnApp f a) - = should_args_be_tagged f -should_args_be_tagged (_, other) - = panic "should_args_be_tagged: tail call to non-con, non-var" - - --- Make code to unpack a constructor onto the stack, adding --- tags for the unboxed bits. Takes the PrimReps of the constructor's --- arguments, and a travelling offset along the *constructor*. -mkUnpackCode :: Int -> [PrimRep] -> BCInstrList -mkUnpackCode off [] = nilOL -mkUnpackCode off (r:rs) - | isFollowableRep r - = let (rs_ptr, rs_nptr) = span isFollowableRep (r:rs) - ptrs_szw = sum (map untaggedSizeW rs_ptr) - in ASSERT(ptrs_szw == length rs_ptr) - UNPACK ptrs_szw `consOL` mkUnpackCode (off+ptrs_szw) rs_nptr - | otherwise - = case r of - IntRep -> UNPACK_I off `consOL` theRest - FloatRep -> UNPACK_F off `consOL` theRest - DoubleRep -> UNPACK_D off `consOL` theRest + +-- Make code to unpack the top-of-stack constructor onto the stack, +-- adding tags for the unboxed bits. Takes the PrimReps of the +-- constructor's arguments. off_h and off_s are travelling offsets +-- along the constructor and the stack. +-- +-- Supposing a constructor in the heap has layout +-- +-- Itbl p_1 ... p_i np_1 ... np_j +-- +-- then we add to the stack, shown growing down, the following: +-- +-- (previous stack) +-- p_i +-- ... +-- p_1 +-- np_j +-- tag_for(np_j) +-- .. +-- np_1 +-- tag_for(np_1) +-- +-- so that in the common case (ptrs only) a single UNPACK instr can +-- copy all the payload of the constr onto the stack with no further ado. + +mkUnpackCode :: [Id] -- constr args + -> Int -- depth before unpack + -> BCEnv -- env before unpack + -> (BCInstrList, Int, BCEnv) +mkUnpackCode vars d p + = --trace ("mkUnpackCode: " ++ showSDocDebug (ppr vars) + -- ++ " --> " ++ show d' ++ "\n" ++ showSDocDebug (ppBCEnv p') + -- ++ "\n") ( + (code_p `appOL` code_np, d', p') + --) where - theRest = mkUnpackCode (off+untaggedSizeW r) rs + -- vars with reps + vreps = [(var, typePrimRep (idType var)) | var <- vars] + + -- ptrs and nonptrs, forward + vreps_p = filter (isFollowableRep.snd) vreps + vreps_np = filter (not.isFollowableRep.snd) vreps + + -- the order in which we will augment the environment + vreps_env = reverse vreps_p ++ reverse vreps_np + + -- new env and depth + vreps_env_tszsw = map (taggedSizeW.snd) vreps_env + p' = addListToFM p (zip (map fst vreps_env) + (mkStackOffsets d vreps_env_tszsw)) + d' = d + sum vreps_env_tszsw + + -- code to unpack the ptrs + ptrs_szw = sum (map (untaggedSizeW.snd) vreps_p) + code_p | null vreps_p = nilOL + | otherwise = unitOL (UNPACK ptrs_szw) + + -- code to unpack the nonptrs + vreps_env_uszw = sum (map (untaggedSizeW.snd) vreps_env) + code_np = do_nptrs vreps_env_uszw ptrs_szw (reverse (map snd vreps_np)) + do_nptrs off_h off_s [] = nilOL + do_nptrs off_h off_s (npr:nprs) + = case npr of + IntRep -> approved ; FloatRep -> approved + DoubleRep -> approved ; AddrRep -> approved + CharRep -> approved + _ -> pprPanic "ByteCodeGen.mkUnpackCode" (ppr npr) + where + approved = UPK_TAG usizeW (off_h-usizeW) off_s `consOL` theRest + theRest = do_nptrs (off_h-usizeW) (off_s + tsizeW) nprs + usizeW = untaggedSizeW npr + tsizeW = taggedSizeW npr + -- Push an atom onto the stack, returning suitable code & number of -- stack words used. Pushes it either tagged or untagged, since @@ -430,21 +651,39 @@ mkUnpackCode off (r:rs) -- 6 stack has valid words 0 .. 5. pushAtom :: Bool -> Int -> BCEnv -> AnnExpr' Id VarSet -> (BCInstrList, Int) -pushAtom tagged d p (AnnVar v) - = let str = "\npushAtom " ++ showSDocDebug (ppr v) ++ ", depth = " ++ show d - ++ ", env =\n" ++ - showSDocDebug (nest 4 (vcat (map ppr (fmToList p)))) - ++ " -->\n" ++ +pushAtom tagged d p (AnnVar v) + + | idPrimRep v == VoidRep + = ASSERT(tagged) + (unitOL (PUSH_TAG 0), 1) + + | Just primop <- isPrimOpId_maybe v + = case primop of + CCallOp _ -> panic "pushAtom: byte code generator can't handle CCalls" + other -> (unitOL (PUSH_G (Right primop)), 1) + + | otherwise + = let str = "\npushAtom " ++ showSDocDebug (ppr v) + ++ " :: " ++ showSDocDebug (pprType (idType v)) + ++ ", depth = " ++ show d + ++ ", tagged = " ++ show tagged ++ ", env =\n" ++ + showSDocDebug (ppBCEnv p) + ++ " --> words: " ++ show (snd result) ++ "\n" ++ showSDoc (nest 4 (vcat (map ppr (fromOL (fst result))))) ++ "\nendPushAtom " ++ showSDocDebug (ppr v) + where + cmp_snd x y = compare (snd x) (snd y) str' = if str == str then str else str result = case lookupBCEnv_maybe p v of - Just d_v -> (toOL (nOfThem nwords (PUSH_L (d-d_v+sz_t-2))), sz_t) - Nothing -> ASSERT(sz_t == 1) (unitOL (PUSH_G nm), sz_t) + Just d_v -> (toOL (nOfThem nwords (PUSH_L (d-d_v+sz_t-2))), nwords) + Nothing -> ASSERT(sz_t == 1) (unitOL (PUSH_G (Left nm)), nwords) + + nm = case isDataConId_maybe v of + Just c -> getName c + Nothing -> getName v - nm = getName v sz_t = taggedIdSizeW v sz_u = untaggedIdSizeW v nwords = if tagged then sz_t else sz_u @@ -458,17 +697,64 @@ pushAtom True d p (AnnLit lit) pushAtom False d p (AnnLit lit) = case lit of - MachInt i -> (unitOL (PUSHU_I (fromInteger i)), untaggedSizeW IntRep) - MachFloat r -> (unitOL (PUSHU_F (fromRational r)), untaggedSizeW FloatRep) - MachDouble r -> (unitOL (PUSHU_D (fromRational r)), untaggedSizeW DoubleRep) + MachWord w -> code WordRep + MachInt i -> code IntRep + MachFloat r -> code FloatRep + MachDouble r -> code DoubleRep + MachChar c -> code CharRep + MachStr s -> pushStr s + where + code rep + = let size_host_words = untaggedSizeW rep + in (unitOL (PUSH_UBX lit size_host_words), size_host_words) + + pushStr s + = let mallocvilleAddr + = case s of + CharStr s i -> A# s + + FastString _ l ba -> + -- sigh, a string in the heap is no good to us. + -- We need a static C pointer, since the type of + -- a string literal is Addr#. So, copy the string + -- into C land and introduce a memory leak + -- at the same time. + let n = I# l + -- CAREFUL! Chars are 32 bits in ghc 4.09+ + in unsafePerformIO ( + do (Ptr a#) <- mallocBytes (n+1) + strncpy (Ptr a#) ba (fromIntegral n) + writeCharOffAddr (A# a#) n '\0' + return (A# a#) + ) + _ -> panic "StgInterp.lit2expr: unhandled string constant type" + + addrLit + = MachInt (toInteger (addrToInt mallocvilleAddr)) + in + -- Get the addr on the stack, untaggedly + (unitOL (PUSH_UBX addrLit 1), 1) + + + + pushAtom tagged d p (AnnApp f (_, AnnType _)) = pushAtom tagged d p (snd f) +pushAtom tagged d p (AnnNote note e) + = pushAtom tagged d p (snd e) + +pushAtom tagged d p (AnnLam x e) + | isTyVar x + = pushAtom tagged d p (snd e) + pushAtom tagged d p other = pprPanic "ByteCodeGen.pushAtom" (pprCoreExpr (deAnnotate (undefined, other))) +foreign import "strncpy" strncpy :: Ptr a -> ByteArray# -> CInt -> IO () + -- Given a bunch of alts code and their discrs, do the donkey work -- of making a multiway branch using a switch tree. @@ -541,7 +827,7 @@ mkMultiBranch maybe_ncons raw_ways (algMinBound, algMaxBound) = case maybe_ncons of - Just n -> (fIRST_TAG, fIRST_TAG + n - 1) + Just n -> (0, n - 1) Nothing -> (minBound, maxBound) (DiscrI i1) `eqAlt` (DiscrI i2) = i1 == i2 @@ -604,12 +890,12 @@ instance Outputable Discr where -- Find things in the BCEnv (the what's-on-the-stack-env) -- See comment preceding pushAtom for precise meaning of env contents -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 :: 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 @@ -633,6 +919,10 @@ taggedIdSizeW, untaggedIdSizeW :: Id -> Int taggedIdSizeW = taggedSizeW . typePrimRep . idType untaggedIdSizeW = untaggedSizeW . typePrimRep . idType +unboxedTupleException :: a +unboxedTupleException + = throwDyn (Panic "bytecode generator can't handle unboxed tuples") + \end{code} %************************************************************************ @@ -648,9 +938,6 @@ data BcM_State type BcM result = BcM_State -> (result, BcM_State) -mkBcM_State :: [ProtoBCO Name] -> Int -> BcM_State -mkBcM_State = BcM_State - runBc :: BcM_State -> BcM () -> BcM_State runBc init_st m = case m init_st of { (r,st) -> st } @@ -680,281 +967,9 @@ getLabelBc :: BcM Int getLabelBc st = (nextlabel st, st{nextlabel = 1 + nextlabel st}) -\end{code} - -%************************************************************************ -%* * -\subsection{The bytecode assembler} -%* * -%************************************************************************ - -The object format for bytecodes is: 16 bits for the opcode, and 16 for -each field -- so the code can be considered a sequence of 16-bit ints. -Each field denotes either a stack offset or number of items on the -stack (eg SLIDE), and index into the pointer table (eg PUSH_G), an -index into the literal table (eg PUSH_I/D/L), or a bytecode address in -this BCO. - -\begin{code} --- An (almost) assembled BCO. -data BCO a = BCO [Word16] -- instructions - [Word32] -- literal pool - [a] -- Names or HValues - --- Top level assembler fn. -assembleBCO :: ProtoBCO Name -> BCO Name -assembleBCO (ProtoBCO nm instrs origin) - = let - -- pass 1: collect up the offsets of the local labels - label_env = mkLabelEnv emptyFM 0 instrs - - mkLabelEnv env i_offset [] = env - mkLabelEnv env i_offset (i:is) - = let new_env - = case i of LABEL n -> addToFM env n i_offset ; _ -> env - in mkLabelEnv new_env (i_offset + instrSizeB i) is - - findLabel lab - = case lookupFM label_env lab of - Just bco_offset -> bco_offset - Nothing -> pprPanic "assembleBCO.findLabel" (int lab) - - -- pass 2: generate the instruction, ptr and nonptr bits - (insnW16s, litW32s, ptrs) = mkBits findLabel [] 0 [] 0 [] 0 instrs - in - BCO insnW16s litW32s ptrs - - --- This is where all the action is (pass 2 of the assembler) -mkBits :: (Int -> Int) -- label finder - -> [Word16] -> Int -- reverse acc instr bits - -> [Word32] -> Int -- reverse acc literal bits - -> [Name] -> Int -- reverse acc ptrs - -> [BCInstr] -- insns! - -> ([Word16], [Word32], [Name]) - -mkBits findLabel r_is n_is r_lits n_lits r_ptrs n_ptrs [] - = (reverse r_is, reverse r_lits, reverse r_ptrs) -mkBits findLabel r_is n_is r_lits n_lits r_ptrs n_ptrs (instr:instrs) - = case instr of - ARGCHECK n -> boring2 i_ARGCHECK n - PUSH_L off -> boring2 i_PUSH_L off - PUSH_LL o1 o2 -> boring3 i_PUSH_LL o1 o2 - PUSH_LLL o1 o2 o3 -> boring4 i_PUSH_LLL o1 o2 o3 - PUSH_G nm -> exciting2_P i_PUSH_G n_ptrs nm - PUSHU_I i -> exciting2_I i_PUSHU_I n_lits i - PUSHU_F f -> exciting2_F i_PUSHU_F n_lits f - PUSHU_D d -> exciting2_D i_PUSHU_D n_lits d - SLIDE n by -> boring3 i_SLIDE n by - ALLOC n -> boring2 i_ALLOC n - MKAP off sz -> boring3 i_MKAP off sz - UNPACK n -> boring2 i_UNPACK n - PACK dcon sz -> exciting3_A i_PACK sz n_lits nullAddr {-findItbl dcon-} - LABEL lab -> nop - TESTLT_I i l -> exciting3_I i_TESTLT_I n_lits (findLabel l) i - TESTEQ_I i l -> exciting3_I i_TESTEQ_I n_lits (findLabel l) i - TESTLT_F f l -> exciting3_F i_TESTLT_F n_lits (findLabel l) f - TESTEQ_F f l -> exciting3_F i_TESTEQ_F n_lits (findLabel l) f - TESTLT_D d l -> exciting3_D i_TESTLT_D n_lits (findLabel l) d - TESTEQ_D d l -> exciting3_D i_TESTEQ_D n_lits (findLabel l) d - TESTLT_P i l -> exciting3_I i_TESTLT_P n_lits (findLabel l) i - TESTEQ_P i l -> exciting3_I i_TESTEQ_P n_lits (findLabel l) i - CASEFAIL -> boring1 i_CASEFAIL - ENTER -> boring1 i_ENTER - RETURN -> boring1 i_RETURN - where - r_mkILit = reverse . mkILit - r_mkFLit = reverse . mkFLit - r_mkDLit = reverse . mkDLit - r_mkALit = reverse . mkALit - - mkw :: Int -> Word16 - mkw = fromIntegral - - nop - = mkBits findLabel r_is n_is r_lits n_lits r_ptrs n_ptrs instrs - boring1 i1 - = mkBits findLabel (mkw i1 : r_is) (n_is+1) - r_lits n_lits r_ptrs n_ptrs instrs - boring2 i1 i2 - = mkBits findLabel (mkw i2 : mkw i1 : r_is) (n_is+2) - r_lits n_lits r_ptrs n_ptrs instrs - boring3 i1 i2 i3 - = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3) - r_lits n_lits r_ptrs n_ptrs instrs - boring4 i1 i2 i3 i4 - = mkBits findLabel (mkw i4 : mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+4) - r_lits n_lits r_ptrs n_ptrs instrs - - exciting2_P i1 i2 p - = mkBits findLabel (mkw i2 : mkw i1 : r_is) (n_is+2) r_lits n_lits - (p:r_ptrs) (n_ptrs+1) instrs - exciting3_P i1 i2 i3 p - = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3) r_lits n_lits - (p:r_ptrs) (n_ptrs+1) instrs - - exciting2_I i1 i2 i - = mkBits findLabel (mkw i2 : mkw i1 : r_is) (n_is+2) - (r_mkILit i ++ r_lits) (n_lits + intLitSz32s) - r_ptrs n_ptrs instrs - exciting3_I i1 i2 i3 i - = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3) - (r_mkILit i ++ r_lits) (n_lits + intLitSz32s) - r_ptrs n_ptrs instrs - - exciting2_F i1 i2 f - = mkBits findLabel (mkw i2 : mkw i1 : r_is) (n_is+2) - (r_mkFLit f ++ r_lits) (n_lits + floatLitSz32s) - r_ptrs n_ptrs instrs - exciting3_F i1 i2 i3 f - = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3) - (r_mkFLit f ++ r_lits) (n_lits + floatLitSz32s) - r_ptrs n_ptrs instrs - - exciting2_D i1 i2 d - = mkBits findLabel (mkw i2 : mkw i1 : r_is) (n_is+2) - (r_mkDLit d ++ r_lits) (n_lits + doubleLitSz32s) - r_ptrs n_ptrs instrs - exciting3_D i1 i2 i3 d - = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3) - (r_mkDLit d ++ r_lits) (n_lits + doubleLitSz32s) - r_ptrs n_ptrs instrs - - exciting3_A i1 i2 i3 d - = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3) - (r_mkALit d ++ r_lits) (n_lits + addrLitSz32s) - r_ptrs n_ptrs instrs - - --- The size in bytes of an instruction. -instrSizeB :: BCInstr -> Int -instrSizeB instr - = case instr of - ARGCHECK _ -> 4 - PUSH_L _ -> 4 - PUSH_LL _ _ -> 6 - PUSH_LLL _ _ _ -> 8 - PUSH_G _ -> 4 - PUSHU_I _ -> 4 - PUSHU_F _ -> 4 - PUSHU_D _ -> 4 - SLIDE _ _ -> 6 - ALLOC _ -> 4 - MKAP _ _ -> 6 - UNPACK _ -> 4 - PACK _ _ -> 6 - LABEL _ -> 4 - TESTLT_I _ _ -> 6 - TESTEQ_I _ _ -> 6 - TESTLT_F _ _ -> 6 - TESTEQ_F _ _ -> 6 - TESTLT_D _ _ -> 6 - TESTEQ_D _ _ -> 6 - TESTLT_P _ _ -> 6 - TESTEQ_P _ _ -> 6 - CASEFAIL -> 2 - ENTER -> 2 - RETURN -> 2 - - --- Sizes of Int, Float and Double literals, in units of 32-bitses -intLitSz32s, floatLitSz32s, doubleLitSz32s, addrLitSz32s :: Int -intLitSz32s = wORD_SIZE `div` 4 -floatLitSz32s = 1 -- Assume IEEE floats -doubleLitSz32s = 2 -addrLitSz32s = intLitSz32s - --- Make lists of 32-bit words for literals, so that when the --- words are placed in memory at increasing addresses, the --- bit pattern is correct for the host's word size and endianness. -mkILit :: Int -> [Word32] -mkFLit :: Float -> [Word32] -mkDLit :: Double -> [Word32] -mkALit :: Addr -> [Word32] - -mkFLit f - = runST (do - arr <- newFloatArray ((0::Int),0) - writeFloatArray arr 0 f - w0 <- readWord32Array arr 0 - return [w0] - ) - -mkDLit d - = runST (do - arr <- newDoubleArray ((0::Int),0) - writeDoubleArray arr 0 d - w0 <- readWord32Array arr 0 - w1 <- readWord32Array arr 1 - return [w0,w1] - ) - -mkILit i - | wORD_SIZE == 4 - = runST (do - arr <- newIntArray ((0::Int),0) - writeIntArray arr 0 i - w0 <- readWord32Array arr 0 - return [w0] - ) - | wORD_SIZE == 8 - = runST (do - arr <- newIntArray ((0::Int),0) - writeIntArray arr 0 i - w0 <- readWord32Array arr 0 - w1 <- readWord32Array arr 1 - return [w0,w1] - ) - -mkALit a - | wORD_SIZE == 4 - = runST (do - arr <- newAddrArray ((0::Int),0) - writeAddrArray arr 0 a - w0 <- readWord32Array arr 0 - return [w0] - ) - | wORD_SIZE == 8 - = runST (do - arr <- newAddrArray ((0::Int),0) - writeAddrArray arr 0 a - w0 <- readWord32Array arr 0 - w1 <- readWord32Array arr 1 - return [w0,w1] - ) - - - -#include "Bytecodes.h" - -i_ARGCHECK = (bci_ARGCHECK :: Int) -i_PUSH_L = (bci_PUSH_L :: Int) -i_PUSH_LL = (bci_PUSH_LL :: Int) -i_PUSH_LLL = (bci_PUSH_LLL :: Int) -i_PUSH_G = (bci_PUSH_G :: Int) -i_PUSH_AS = (bci_PUSH_AS :: Int) -i_PUSHT_I = (bci_PUSHT_I :: Int) -i_PUSHT_F = (bci_PUSHT_F :: Int) -i_PUSHT_D = (bci_PUSHT_D :: Int) -i_PUSHU_I = (bci_PUSHU_I :: Int) -i_PUSHU_F = (bci_PUSHU_F :: Int) -i_PUSHU_D = (bci_PUSHU_D :: Int) -i_SLIDE = (bci_SLIDE :: Int) -i_ALLOC = (bci_ALLOC :: Int) -i_MKAP = (bci_MKAP :: Int) -i_UNPACK = (bci_UNPACK :: Int) -i_PACK = (bci_PACK :: Int) -i_LABEL = (bci_LABEL :: Int) -i_TESTLT_I = (bci_TESTLT_I :: Int) -i_TESTEQ_I = (bci_TESTEQ_I :: Int) -i_TESTLT_F = (bci_TESTLT_F :: Int) -i_TESTEQ_F = (bci_TESTEQ_F :: Int) -i_TESTLT_D = (bci_TESTLT_D :: Int) -i_TESTEQ_D = (bci_TESTEQ_D :: Int) -i_TESTLT_P = (bci_TESTLT_P :: Int) -i_TESTEQ_P = (bci_TESTEQ_P :: Int) -i_CASEFAIL = (bci_CASEFAIL :: Int) -i_ENTER = (bci_ENTER :: Int) -i_RETURN = (bci_RETURN :: Int) +getLabelsBc :: Int -> BcM [Int] +getLabelsBc n st + = let ctr = nextlabel st + in ([ctr .. ctr+n-1], st{nextlabel = ctr+n}) \end{code}