X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FByteCodeGen.lhs;h=f6cf787493f313f95913187a0dfa6f09bbd3a52b;hb=2cc5b907318f97e19b28b2ad8ed9ff8c1f401dcc;hp=abded492d04baaaa1c3d090d501add393deb3947;hpb=d54a7e7ca6a3c01c15366243ca1963c8199f58c9;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index abded49..f6cf787 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -4,149 +4,144 @@ \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, isFCallId, + idPrimRep, mkSysLocal, idName, isFCallId_maybe, isPrimOpId ) +import ForeignCall ( ForeignCall(..), CCallTarget(..), CCallSpec(..) ) 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, elemFM, + 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 Util ( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem ) +import Type ( typePrimRep, splitTyConApp_maybe, isTyVarTy ) +import DataCon ( dataConTag, fIRST_TAG, dataConTyCon, + dataConWrapId, isUnboxedTupleCon ) +import TyCon ( TyCon(..), tyConFamilySize, isDataTyCon, tyConDataCons, + isFunTyCon, isUnboxedTupleTyCon ) +import Class ( Class, classTyCon ) +import Type ( Type, repType, splitRepFunTys ) +import Util ( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem, + isSingleton, lengthIs ) +import DataCon ( dataConRepArity ) import Var ( isTyVar ) import VarSet ( VarSet, varSetElems ) -import PrimRep ( getPrimRepSize, isFollowableRep ) +import PrimRep ( isFollowableRep ) +import CmdLineOpts ( DynFlags, DynFlag(..) ) +import ErrUtils ( showPass, dumpIfSet_dyn ) +import Unique ( mkPseudoUnique3 ) +import FastString ( FastString(..) ) +import Panic ( GhcException(..) ) +import PprType ( pprType ) +import SMRep ( arrWordsHdrSize, arrPtrsHdrSize ) import Constants ( wORD_SIZE ) - -import Monad ( foldM ) -import Foreign ( Addr, Word16, Word32, nullAddr ) -import ST ( runST ) ---import MutableArray ( readWord32Array, --- newFloatArray, writeFloatArray, --- newDoubleArray, writeDoubleArray, --- newIntArray, writeIntArray, --- newAddrArray, writeAddrArray ) - -import MArray +import ByteCodeInstr ( BCInstr(..), ProtoBCO(..), nameOfProtoBCO, bciStackUse ) +import ByteCodeItbls ( ItblEnv, mkITbls ) +import ByteCodeLink ( UnlinkedBCO, UnlinkedBCOExpr, assembleBCO, + ClosureEnv, HValue, filterNameMap, linkFail, + iNTERP_STACK_CHECK_THRESH ) +import ByteCodeFFI ( taggedSizeW, untaggedSizeW, mkMarshalCode, moan64 ) +import Linker ( lookupSymbol ) + +import List ( intersperse, sortBy, zip4 ) +import Foreign ( Ptr(..), castPtr, mallocBytes, pokeByteOff, Word8 ) +import CTypes ( CInt ) +import Exception ( throwDyn ) + +import GlaExts ( Int(..), ByteArray# ) + +import Monad ( when ) +import Maybe ( isJust ) +import Char ( ord ) \end{code} -Entry point. - -\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 UnboxedLit = UnboxedI Int | UnboxedF Float | UnboxedD Double - -data BCInstr - -- Messing with the stack - = ARGCHECK Int - -- Push locals (existing bits of the stack) - | PUSH_L Int{-offset-} - | PUSH_LL Int Int{-2 offsets-} - | PUSH_LLL Int Int Int{-3 offsets-} - -- Push a ptr - | PUSH_G Name - -- Push an alt continuation - | PUSH_AS Name PrimRep -- push alts and BCO_ptr_ret_info - -- PrimRep so we know which itbl - -- Pushing literals - | PUSH_UBX Literal -- push this int/float/double, NO TAG, on the stack - | PUSH_TAG Int -- push this tag on the stack - - | 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 - | UPK_TAG Int Int Int - -- unpack N non-ptr words from offset M in constructor - -- K words down the stack - | 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 pk) = text "PUSH_AS " <+> ppr nm <+> ppr pk - 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 (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] + + (BcM_State proto_bcos final_ctr mallocd, ()) + <- runBc (BcM_State [] 0 []) + (mapBc (schemeR True []) flatBinds `thenBc_` returnBc ()) + -- ^^ + -- better be no free vars in these top-level bindings + + when (not (null mallocd)) + (panic "ByteCodeGen.byteCodeGen: missing final emitBc?") + + 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 + + annexpr = freeVars expr + fvs = filter (not.isTyVar) (varSetElems (fst annexpr)) + + (BcM_State all_proto_bcos final_ctr mallocd, ()) + <- runBc (BcM_State [] 0 []) + (schemeR True fvs (invented_id, annexpr)) + + when (not (null mallocd)) + (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?") + + 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} %************************************************************************ @@ -159,30 +154,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 +mkProtoBCO nm instrs_ordlist origin mallocd_blocks + = ProtoBCO nm maybe_with_stack_check origin mallocd_blocks 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 [] @@ -192,25 +210,66 @@ 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] -> (Id, AnnExpr Id VarSet) -> BcM () +schemeR is_top fvs (nm, rhs) +{- + | trace (showSDoc ( + (char ' ' + $$ (ppr.filter (not.isTyVar).varSetElems.fst) rhs + $$ pprCoreExpr (deAnnotate rhs) + $$ char ' ' + ))) False + = undefined +-} + | otherwise + = schemeR_wrk is_top fvs 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) - = let fvs = filter (not.isTyVar) (varSetElems (fst original_body)) - all_args = fvs ++ reverse args +schemeR_wrk is_top fvs 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 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 nukeTyArgs (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 + + nukeTyArgs (AnnApp f (_, AnnType _)) = nukeTyArgs (snd f) + nukeTyArgs other = other + -- 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 @@ -225,28 +284,133 @@ 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 + = -- Ptr-ish thing; push it in the normal way + 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 + pushAtom True d p (AnnVar v) `thenBc` \ (push, szw) -> + returnBc (push -- value onto stack + `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) + = pushAtom True d p (AnnLit literal) `thenBc` \ (push, szw) -> + let 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 + +{- + Deal specially with the cases + let x = fn atom1 .. atomn in B + and + let x = Con atom1 .. atomn in B + (Con must be saturated) + + In these cases, generate code to allocate in-line. + + This is optimisation of the general case for let, which follows + this one; this case can safely be omitted. The reduction in + interpreter execution time seems to be around 5% for some programs, + with a similar drop in allocations. + + This optimisation should be done more cleanly. As-is, it is + inapplicable to RHSs in letrecs, and needlessly duplicates code in + schemeR and schemeT. Some refactoring of the machinery would cure + both ills. +-} +schemeE d s p ee@(fvs, AnnLet (AnnNonRec x rhs) b) + | ok_to_go + = let d_init = if is_con then d else d' + in + mkPushes d_init args_r_to_l_reordered `thenBc` \ (d_final, push_code) -> + schemeE d' s p' b `thenBc` \ body_code -> + let size = d_final - d_init + alloc = if is_con then nilOL else unitOL (ALLOC size) + pack = unitOL (if is_con then PACK the_dcon size else MKAP size size) + in + returnBc (alloc `appOL` push_code `appOL` pack + `appOL` body_code) + where + -- Decide whether we can do this or not + (ok_to_go, is_con, the_dcon, the_fn) + = case maybe_fn of + Nothing -> (False, bomb 1, bomb 2, bomb 3) + Just (Left fn) -> (True, False, bomb 5, fn) + Just (Right dcon) + | dataConRepArity dcon <= length args_r_to_l + -> (True, True, dcon, bomb 6) + | otherwise + -> (False, bomb 7, bomb 8, bomb 9) + bomb n = panic ("schemeE.is_con(hacky hack hack) " ++ show n) + + -- Extract the args (R -> L) and fn + args_r_to_l_reordered + | not is_con + = args_r_to_l + | otherwise + = filter (not.isPtr.snd) args_r_to_l ++ filter (isPtr.snd) args_r_to_l + where isPtr = isFollowableRep . atomRep + + args_r_to_l = filter (not.isTypeAtom.snd) args_r_to_l_raw + isTypeAtom (AnnType _) = True + isTypeAtom _ = False + + (args_r_to_l_raw, maybe_fn) = chomp rhs + chomp expr + = case snd expr of + AnnVar v + | isFCallId v || isPrimOpId v + -> ([], Nothing) + | otherwise + -> case isDataConId_maybe v of + Just dcon -> ([], Just (Right dcon)) + Nothing -> ([], Just (Left v)) + AnnApp f a -> case chomp f of (az, f) -> (a:az, f) + AnnNote n e -> chomp e + other -> ([], Nothing) + + -- This is the env in which to translate the body + p' = addToFM p x d + d' = d + 1 + + -- Shove the args on the stack, including the fn in the non-dcon case + tag_when_push = not is_con + + mkPushes :: Int{-curr depth-} -> [AnnExpr Id VarSet] + -> BcM (Int{-final depth-}, BCInstrList) + mkPushes dd [] + | is_con + = returnBc (dd, nilOL) + | otherwise + = pushAtom False dd p' (AnnVar the_fn) `thenBc` \ (fn_push_code, fn_szw) -> + returnBc (dd+fn_szw, fn_push_code) + mkPushes dd (atom:atoms) + = pushAtom tag_when_push dd p' (snd atom) + `thenBc` \ (push1_code, push1_szw) -> + mkPushes (dd+push1_szw) atoms `thenBc` \ (dd_final, push_rest) -> + returnBc (dd_final, push1_code `appOL` push_rest) + + +-- General case for let. Generates correct, if inefficient, code in +-- all situations. 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 + + is_local id = not (isTyVar id) && elemFM id p' + fvss = map (filter is_local . 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 @@ -262,22 +426,84 @@ 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) - `consOL` unitOL (MKAP (off+size-1) size) + = returnBc (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 - (push_code, pushed_szw) - -> push_code `appOL` - buildThunk (dd+pushed_szw) (fvs, size, id, off) + = pushAtom True dd p' (AnnVar fv) + `thenBc` \ (push_code, pushed_szw) -> + buildThunk (dd+pushed_szw) (fvs, size, id, off) + `thenBc` \ more_push_code -> + returnBc (push_code `appOL` more_push_code) + + genThunkCode = mapBc (buildThunk d') infos `thenBc` \ tcodes -> + returnBc (concatOL tcodes) - thunkCode = concatOL (map (buildThunk d') infos) allocCode = toOL (map ALLOC sizes) + + schemeRs [] _ _ = returnBc () + schemeRs (fvs:fvss) (x:xs) (rhs:rhss) = + schemeR False fvs (x,rhs) `thenBc_` schemeRs fvss xs rhss in schemeE d' s p' b `thenBc` \ bodyCode -> - mapBc schemeR (zip xs rhss) `thenBc_` + schemeRs fvss xs rhss `thenBc_` + genThunkCode `thenBc` \ thunkCode -> returnBc (allocCode `appOL` thunkCode `appOL` bodyCode) + + + +schemeE d s p (fvs_case, AnnCase (fvs_scrut, scrut) bndr + [(DEFAULT, [], (fvs_rhs, rhs))]) + + | let isFunType var_type + = case splitTyConApp_maybe var_type of + Just (tycon,_) | isFunTyCon tycon -> True + _ -> False + ty_bndr = repType (idType bndr) + in isFunType ty_bndr || isTyVarTy ty_bndr + + -- Nasty hack; treat + -- case scrut::suspect of bndr { DEFAULT -> rhs } + -- as + -- let bndr = scrut in rhs + -- when suspect is polymorphic or arrowtyped + -- So the required strictness properties are not observed. + -- At some point, must fix this properly. + = let new_expr + = (fvs_case, + AnnLet + (AnnNonRec bndr (fvs_scrut, scrut)) (fvs_rhs, rhs) + ) + + in trace ("WARNING: ignoring polymorphic case in interpreted mode.\n" ++ + " Possibly due to strict polymorphic/functional constructor args.\n" ++ + " Your program may leak space unexpectedly.\n") + (schemeE d s p new_expr) + + + +{- Convert case .... of (# VoidRep'd-thing, a #) -> ... + as + case .... of a -> ... + Use a as the name of the binder too. + + Also case .... of (# a #) -> ... + to + case .... of a -> ... +-} +schemeE d s p (fvs, AnnCase scrut bndr [(DataAlt dc, [bind1, bind2], rhs)]) + | isUnboxedTupleCon dc && VoidRep == typePrimRep (idType bind1) + = --trace "automagic mashing of case alts (# VoidRep, a #)" ( + schemeE d s p (fvs, AnnCase scrut bind2 [(DEFAULT, [bind2], rhs)]) + --) + +schemeE d s p (fvs, AnnCase scrut bndr [(DataAlt dc, [bind1], rhs)]) + | isUnboxedTupleCon dc + = --trace "automagic mashing of case alts (# a #)" ( + schemeE d s p (fvs, AnnCase scrut bind1 [(DEFAULT, [bind1], rhs)]) + --) + schemeE d s p (fvs, AnnCase scrut bndr alts) = let -- Top of stack is the return itbl, as usual. @@ -293,34 +519,41 @@ schemeE d s p (fvs, AnnCase scrut bndr alts) scrut_primrep = typePrimRep (idType bndr) isAlgCase - = case scrut_primrep of - IntRep -> False ; FloatRep -> False ; DoubleRep -> False - PtrRep -> True - other -> pprPanic "ByteCodeGen.schemeE" (ppr other) + | scrut_primrep == PtrRep + = True + | scrut_primrep `elem` + [CharRep, AddrRep, WordRep, IntRep, FloatRep, DoubleRep, + VoidRep, Int8Rep, Int16Rep, Int32Rep, Int64Rep, + Word8Rep, Word16Rep, Word32Rep, Word64Rep] + = False + | otherwise + = pprPanic "ByteCodeGen.schemeE" (ppr scrut_primrep) -- 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 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 (filter (not.isTyVar) 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 @@ -333,8 +566,9 @@ 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 -> @@ -351,70 +585,523 @@ 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. (Another nasty hack). Spot (# a::VoidRep, b #) and treat +-- it simply as b -- since the representations are identical +-- (the VoidRep takes up zero stack space). Also, spot +-- (# b #) and treat it as b. +-- +-- 3. The fn denotes a ccall. Defer to generateCCall. +-- +-- 4. 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. +-- +-- 5. 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) - | 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 - -mkSLIDE n d - = if d == 0 then nilOL else unitOL (SLIDE n d) - -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 both the constructor --- (off_h) and the stack (off_s). -mkUnpackCode :: Int -> Int -> [PrimRep] -> BCInstrList -mkUnpackCode off_h off_s [] = nilOL -mkUnpackCode off_h off_s (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) - ASSERT(off_h == 0) - ASSERT(off_s == 0) - UNPACK ptrs_szw - `consOL` mkUnpackCode (off_h + ptrs_szw) (off_s + ptrs_szw) rs_nptr + -> AnnExpr Id VarSet + -> BcM BCInstrList + +schemeT d s p app + +-- | trace ("schemeT: env in = \n" ++ showSDocDebug (ppBCEnv p)) False +-- = panic "schemeT ?!?!" + +-- | trace ("\nschemeT\n" ++ showSDoc (pprCoreExpr (deAnnotate app)) ++ "\n") False +-- = error "?!?!" + + -- Case 0 + | Just (arg, constr_names) <- maybe_is_tagToEnum_call + = pushAtom True d p arg `thenBc` \ (push, arg_words) -> + implement_tagToId constr_names `thenBc` \ tagToId_sequence -> + returnBc (push `appOL` tagToId_sequence + `appOL` mkSLIDE 1 (d+arg_words-s) + `snocOL` ENTER) + + -- Case 1 + | is_con_call && null args_r_to_l + = returnBc ( + (PUSH_G (Left (getName con)) `consOL` mkSLIDE 1 (d-s)) + `snocOL` ENTER + ) + + -- Case 2 + | let isVoidRepAtom (_, AnnVar v) = VoidRep == typePrimRep (idType v) + isVoidRepAtom (_, AnnNote n e) = isVoidRepAtom e + in is_con_call && isUnboxedTupleCon con + && ( (args_r_to_l `lengthIs` 2 && isVoidRepAtom (last (args_r_to_l))) + || (isSingleton args_r_to_l) + ) + = --trace (if isSingleton args_r_to_l + -- then "schemeT: unboxed singleton" + -- else "schemeT: unboxed pair with Void first component") ( + schemeT d s p (head args_r_to_l) + --) + + -- Case 3 + | Just (CCall ccall_spec) <- isFCallId_maybe fn + = generateCCall d s p ccall_spec fn args_r_to_l + + -- Cases 4 and 5 | otherwise - = case r of - IntRep -> approved - FloatRep -> approved - DoubleRep -> approved + = if is_con_call && isUnboxedTupleCon con + then unboxedTupleException + else do_pushery d (map snd args_final_r_to_l) + + where + -- Detect and extract relevant info for the tagToEnum kludge. + maybe_is_tagToEnum_call + = let extract_constr_Names ty + = case splitTyConApp_maybe (repType 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 + Just TagToEnumOp -> Just (snd arg, extract_constr_Names t) + other -> Nothing + other -> Nothing + + -- Extract the args (R->L) and fn + (args_r_to_l, fn) = chomp app + chomp expr + = case snd expr of + AnnVar v -> ([], v) + AnnApp f a + | isTypeAtom (snd a) -> chomp f + | otherwise -> case chomp f of (az, f) -> (a:az, f) + AnnNote n e -> chomp e + other -> pprPanic "schemeT" + (ppr (deAnnotate (panic "schemeT.chomp", other))) + + n_args = length args_r_to_l + + isTypeAtom (AnnType _) = True + isTypeAtom _ = False + + -- decide if this is a constructor application, because we need + -- to rearrange the arguments on the stack if so. For building + -- a constructor, we put pointers before non-pointers and omit + -- the tags. + -- + -- Also if the constructor is not saturated, we just arrange to + -- call the curried worker instead. + + maybe_dcon = case isDataConId_maybe fn of + Just con | dataConRepArity con == n_args -> Just con + _ -> Nothing + is_con_call = isJust maybe_dcon + (Just con) = maybe_dcon + + args_final_r_to_l + | not is_con_call + = args_r_to_l + | otherwise + = filter (not.isPtr.snd) args_r_to_l ++ filter (isPtr.snd) args_r_to_l + where isPtr = isFollowableRep . atomRep + + -- make code to push the args and then do the SLIDE-ENTER thing + tag_when_push = not is_con_call + narg_words = sum (map (get_arg_szw . atomRep . snd) args_r_to_l) + get_arg_szw = if tag_when_push then taggedSizeW else untaggedSizeW + + do_pushery d (arg:args) + = pushAtom tag_when_push d p arg `thenBc` \ (push, arg_words) -> + do_pushery (d+arg_words) args `thenBc` \ more_push_code -> + returnBc (push `appOL` more_push_code) + do_pushery d [] + | Just (CCall ccall_spec) <- isFCallId_maybe fn + = panic "schemeT.do_pushery: unexpected ccall" + | otherwise + = case maybe_dcon of + Just con -> returnBc ( + (PACK con narg_words `consOL` + mkSLIDE 1 (d - narg_words - s)) `snocOL` + ENTER + ) + Nothing + -> pushAtom True d p (AnnVar fn) + `thenBc` \ (push, arg_words) -> + returnBc (push `appOL` mkSLIDE (narg_words+arg_words) + (d - s - narg_words) + `snocOL` ENTER) + + +{- Deal with a CCall. Taggedly push the args onto the stack R->L, + deferencing ForeignObj#s and (ToDo: adjusting addrs to point to + payloads in Ptr/Byte arrays). Then, generate the marshalling + (machine) code for the ccall, and create bytecodes to call that and + then return in the right way. +-} +generateCCall :: Int -> Sequel -- stack and sequel depths + -> BCEnv + -> CCallSpec -- where to call + -> Id -- of target, for type info + -> [AnnExpr Id VarSet] -- args (atoms) + -> BcM BCInstrList + +generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l + = let + -- useful constants + addr_usizeW = untaggedSizeW AddrRep + addr_tsizeW = taggedSizeW AddrRep + + -- Get the args on the stack, with tags and suitably + -- dereferenced for the CCall. For each arg, return the + -- depth to the first word of the bits for that arg, and the + -- PrimRep of what was actually pushed. + + pargs d [] = returnBc [] + pargs d ((_,a):az) + = let rep_arg = atomRep a + in case rep_arg of + -- Don't push the FO; instead push the Addr# it + -- contains. + ForeignObjRep + -> pushAtom False{-irrelevant-} d p a + `thenBc` \ (push_fo, _) -> + let foro_szW = taggedSizeW ForeignObjRep + d_now = d + addr_tsizeW + code = push_fo `appOL` toOL [ + UPK_TAG addr_usizeW 0 0, + SLIDE addr_tsizeW foro_szW + ] + in pargs d_now az `thenBc` \ rest -> + returnBc ((code, AddrRep) : rest) + + ArrayRep + -> pargs (d + addr_tsizeW) az `thenBc` \ rest -> + parg_ArrayishRep arrPtrsHdrSize d p a + `thenBc` \ code -> + returnBc ((code,AddrRep):rest) + + ByteArrayRep + -> pargs (d + addr_tsizeW) az `thenBc` \ rest -> + parg_ArrayishRep arrWordsHdrSize d p a + `thenBc` \ code -> + returnBc ((code,AddrRep):rest) + + -- Default case: push taggedly, but otherwise intact. + other + -> pushAtom True d p a `thenBc` \ (code_a, sz_a) -> + pargs (d+sz_a) az `thenBc` \ rest -> + returnBc ((code_a, rep_arg) : rest) + + -- Do magic for Ptr/Byte arrays. Push a ptr to the array on + -- the stack but then advance it over the headers, so as to + -- point to the payload. + parg_ArrayishRep hdrSizeW d p a + = pushAtom False{-irrel-} d p a `thenBc` \ (push_fo, _) -> + -- The ptr points at the header. Advance it over the + -- header and then pretend this is an Addr# (push a tag). + returnBc (push_fo `snocOL` + SWIZZLE 0 (hdrSizeW * untaggedSizeW PtrRep + * wORD_SIZE) + `snocOL` + PUSH_TAG addr_usizeW) + + in + pargs d0 args_r_to_l `thenBc` \ code_n_reps -> + let + (pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps + + push_args = concatOL pushs_arg + d_after_args = d0 + sum (map taggedSizeW a_reps_pushed_r_to_l) + a_reps_pushed_RAW + | null a_reps_pushed_r_to_l || head a_reps_pushed_r_to_l /= VoidRep + = panic "ByteCodeGen.generateCCall: missing or invalid World token?" + | otherwise + = reverse (tail a_reps_pushed_r_to_l) + + -- Now: a_reps_pushed_RAW are the reps which are actually on the stack. + -- push_args is the code to do that. + -- d_after_args is the stack depth once the args are on. + + -- Get the result rep. + (returns_void, r_rep) + = case maybe_getCCallReturnRep (idType fn) of + Nothing -> (True, VoidRep) + Just rr -> (False, rr) + {- + Because the Haskell stack grows down, the a_reps refer to + lowest to highest addresses in that order. The args for the call + are on the stack. Now push an unboxed, tagged Addr# indicating + the C function to call. Then push a dummy placeholder for the + result. Finally, emit a CCALL insn with an offset pointing to the + Addr# just pushed, and a literal field holding the mallocville + address of the piece of marshalling code we generate. + So, just prior to the CCALL insn, the stack looks like this + (growing down, as usual): + + + ... + + Addr# address_of_C_fn + (must be an unboxed type) + + The interpreter then calls the marshall code mentioned + in the CCALL insn, passing it (& ), + that is, the addr of the topmost word in the stack. + When this returns, the placeholder will have been + filled in. The placeholder is slid down to the sequel + depth, and we RETURN. + + This arrangement makes it simple to do f-i-dynamic since the Addr# + value is the first arg anyway. It also has the virtue that the + stack is GC-understandable at all times. + + The marshalling code is generated specifically for this + call site, and so knows exactly the (Haskell) stack + offsets of the args, fn address and placeholder. It + copies the args to the C stack, calls the stacked addr, + and parks the result back in the placeholder. The interpreter + calls it as a normal C call, assuming it has a signature + void marshall_code ( StgWord* ptr_to_top_of_stack ) + -} + -- resolve static address + get_target_info + = case target of + DynamicTarget + -> returnBc (False, panic "ByteCodeGen.generateCCall(dyn)") + StaticTarget target + -> let sym_to_find = _UNPK_ target in + ioToBc (lookupSymbol sym_to_find) `thenBc` \res -> + case res of + Just aa -> returnBc (True, aa) + Nothing -> ioToBc (linkFail "ByteCodeGen.generateCCall" + sym_to_find) + CasmTarget _ + -> pprPanic "ByteCodeGen.generateCCall: casm" (ppr ccall_spec) + in + get_target_info `thenBc` \ (is_static, static_target_addr) -> + let + + -- Get the arg reps, zapping the leading Addr# in the dynamic case + a_reps -- | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???" + | is_static = a_reps_pushed_RAW + | otherwise = if null a_reps_pushed_RAW + then panic "ByteCodeGen.generateCCall: dyn with no args" + else tail a_reps_pushed_RAW + + -- push the Addr# + (push_Addr, d_after_Addr) + | is_static + = (toOL [PUSH_UBX (Right static_target_addr) addr_usizeW, + PUSH_TAG addr_usizeW], + d_after_args + addr_tsizeW) + | otherwise -- is already on the stack + = (nilOL, d_after_args) + + -- Push the return placeholder. For a call returning nothing, + -- this is a VoidRep (tag). + r_usizeW = untaggedSizeW r_rep + r_tsizeW = taggedSizeW r_rep + d_after_r = d_after_Addr + r_tsizeW + r_lit = mkDummyLiteral r_rep + push_r = (if returns_void + then nilOL + else unitOL (PUSH_UBX (Left r_lit) r_usizeW)) + `appOL` + unitOL (PUSH_TAG r_usizeW) + + -- generate the marshalling code we're going to call + r_offW = 0 + addr_offW = r_tsizeW + arg1_offW = r_tsizeW + addr_tsizeW + args_offW = map (arg1_offW +) + (init (scanl (+) 0 (map taggedSizeW a_reps))) + in + ioToBc (mkMarshalCode cconv + (r_offW, r_rep) addr_offW + (zip args_offW a_reps)) `thenBc` \ addr_of_marshaller -> + recordMallocBc addr_of_marshaller `thenBc_` + let + -- do the call + do_call = unitOL (CCALL (castPtr addr_of_marshaller)) + -- slide and return + wrapup = mkSLIDE r_tsizeW (d_after_r - r_tsizeW - s) + `snocOL` RETURN r_rep + in + --trace (show (arg1_offW, args_offW , (map taggedSizeW a_reps) )) ( + returnBc ( + push_args `appOL` + push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup + ) + --) + + +-- Make a dummy literal, to be used as a placeholder for FFI return +-- values on the stack. +mkDummyLiteral :: PrimRep -> Literal +mkDummyLiteral pr + = case pr of + CharRep -> MachChar 0 + IntRep -> MachInt 0 + WordRep -> MachWord 0 + DoubleRep -> MachDouble 0 + FloatRep -> MachFloat 0 + AddrRep | taggedSizeW AddrRep == taggedSizeW WordRep -> MachWord 0 + _ -> moan64 "mkDummyLiteral" (ppr pr) + + +-- Convert (eg) +-- PrelGHC.Char# -> PrelGHC.State# PrelGHC.RealWorld +-- -> (# PrelGHC.State# PrelGHC.RealWorld, PrelGHC.Int# #) +-- +-- to Just IntRep +-- and check that an unboxed pair is returned wherein the first arg is VoidRep'd. +-- +-- Alternatively, for call-targets returning nothing, convert +-- +-- PrelGHC.Char# -> PrelGHC.State# PrelGHC.RealWorld +-- -> (# PrelGHC.State# PrelGHC.RealWorld #) +-- +-- to Nothing + +maybe_getCCallReturnRep :: Type -> Maybe PrimRep +maybe_getCCallReturnRep fn_ty + = let (a_tys, r_ty) = splitRepFunTys fn_ty + maybe_r_rep_to_go + = if isSingleton r_reps then Nothing else Just (r_reps !! 1) + (r_tycon, r_reps) + = case splitTyConApp_maybe (repType r_ty) of + (Just (tyc, tys)) -> (tyc, map typePrimRep tys) + Nothing -> blargh + ok = ( ( r_reps `lengthIs` 2 && VoidRep == head r_reps) + || r_reps == [VoidRep] ) + && isUnboxedTupleTyCon r_tycon + && case maybe_r_rep_to_go of + Nothing -> True + Just r_rep -> r_rep /= PtrRep + -- if it was, it would be impossible + -- to create a valid return value + -- placeholder on the stack + blargh = pprPanic "maybe_getCCallReturn: can't handle:" + (pprType fn_ty) + in + --trace (showSDoc (ppr (a_reps, r_reps))) ( + if ok then maybe_r_rep_to_go else blargh + --) + +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 - approved = UPK_TAG usizeW off_h off_s `consOL` theRest - theRest = mkUnpackCode (off_h + usizeW) (off_s + tsizeW) rs - usizeW = untaggedSizeW r - tsizeW = taggedSizeW r + 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] + + +-- 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 + -- 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) + | npr `elem` [IntRep, WordRep, FloatRep, DoubleRep, CharRep, AddrRep] + = approved + | otherwise + = moan64 "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 @@ -440,48 +1127,110 @@ mkUnpackCode off_h off_s (r:rs) -- 5 and not to 4. Stack locations are numbered from zero, so a depth -- 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 :: Bool -> Int -> BCEnv -> AnnExpr' Id VarSet -> BcM (BCInstrList, Int) +pushAtom tagged d p (AnnVar v) + + | idPrimRep v == VoidRep + = if tagged then returnBc (unitOL (PUSH_TAG 0), 1) + else panic "ByteCodeGen.pushAtom(VoidRep,untaggedly)" + + | isFCallId v + = pprPanic "pushAtom: shouldn't get an FCallId here" (ppr v) + + | Just primop <- isPrimOpId_maybe v + = returnBc (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) - 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 in - --trace str' - result + returnBc result pushAtom True d p (AnnLit lit) - = let (ubx_code, ubx_size) = pushAtom False d p (AnnLit lit) - in (ubx_code `snocOL` PUSH_TAG ubx_size, 1 + ubx_size) + = pushAtom False d p (AnnLit lit) `thenBc` \ (ubx_code, ubx_size) -> + returnBc (ubx_code `snocOL` PUSH_TAG ubx_size, 1 + ubx_size) pushAtom False d p (AnnLit lit) = case lit of - MachInt i -> (code, untaggedSizeW IntRep) - MachFloat r -> (code, untaggedSizeW FloatRep) - MachDouble r -> (code, 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 = unitOL (PUSH_UBX lit) + code rep + = let size_host_words = untaggedSizeW rep + in returnBc (unitOL (PUSH_UBX (Left lit) size_host_words), + size_host_words) + + pushStr s + = let getMallocvilleAddr + = case s of + CharStr s i -> returnBc (Ptr 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 ioToBc (mallocBytes (n+1)) `thenBc` \ ptr -> + recordMallocBc ptr `thenBc_` + ioToBc ( + do memcpy ptr ba (fromIntegral n) + pokeByteOff ptr n (fromIntegral (ord '\0') :: Word8) + return ptr + ) + other -> panic "ByteCodeGen.pushAtom.pushStr" + in + getMallocvilleAddr `thenBc` \ addr -> + -- Get the addr on the stack, untaggedly + returnBc (unitOL (PUSH_UBX (Right addr) 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 "memcpy" memcpy :: 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. @@ -554,7 +1303,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 @@ -617,35 +1366,33 @@ 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 --- When I push one of these on the stack, how much does Sp move by? -taggedSizeW :: PrimRep -> Int -taggedSizeW pr - | isFollowableRep pr = 1 - | otherwise = 1{-the tag-} + getPrimRepSize pr - - --- The plain size of something, without tag. -untaggedSizeW :: PrimRep -> Int -untaggedSizeW pr - | isFollowableRep pr = 1 - | otherwise = getPrimRepSize pr - - taggedIdSizeW, untaggedIdSizeW :: Id -> Int taggedIdSizeW = taggedSizeW . typePrimRep . idType untaggedIdSizeW = untaggedSizeW . typePrimRep . idType +unboxedTupleException :: a +unboxedTupleException + = throwDyn + (Panic + ("Bytecode generator can't handle unboxed tuples. Possibly due\n" ++ + "\tto foreign import/export decls in source. Workaround:\n" ++ + "\tcompile this module to a .o file, then restart session.")) + + +mkSLIDE n d = if d == 0 then nilOL else unitOL (SLIDE n d) +bind x f = f x + \end{code} %************************************************************************ @@ -657,26 +1404,34 @@ untaggedIdSizeW = untaggedSizeW . typePrimRep . idType \begin{code} data BcM_State = BcM_State { bcos :: [ProtoBCO Name], -- accumulates completed BCOs - nextlabel :: Int } -- for generating local labels - -type BcM result = BcM_State -> (result, BcM_State) + nextlabel :: Int, -- for generating local labels + malloced :: [Ptr ()] } -- ptrs malloced for current BCO + -- Should be free()d when it is GCd +type BcM r = BcM_State -> IO (BcM_State, r) -mkBcM_State :: [ProtoBCO Name] -> Int -> BcM_State -mkBcM_State = BcM_State +ioToBc :: IO a -> BcM a +ioToBc io st = do x <- io + return (st, x) -runBc :: BcM_State -> BcM () -> BcM_State -runBc init_st m = case m init_st of { (r,st) -> st } +runBc :: BcM_State -> BcM r -> IO (BcM_State, r) +runBc st0 m = do (st1, res) <- m st0 + return (st1, res) thenBc :: BcM a -> (a -> BcM b) -> BcM b -thenBc expr cont st - = case expr st of { (result, st') -> cont result st' } +thenBc expr cont st0 + = do (st1, q) <- expr st0 + (st2, r) <- cont q st1 + return (st2, r) thenBc_ :: BcM a -> BcM b -> BcM b -thenBc_ expr cont st - = case expr st of { (result, st') -> cont st' } +thenBc_ expr cont st0 + = do (st1, q) <- expr st0 + (st2, r) <- cont st1 + return (st2, r) returnBc :: a -> BcM a -returnBc result st = (result, st) +returnBc result st = return (st, result) + mapBc :: (a -> BcM b) -> [a] -> BcM [b] mapBc f [] = returnBc [] @@ -685,360 +1440,28 @@ mapBc f (x:xs) mapBc f xs `thenBc` \ rs -> returnBc (r:rs) -emitBc :: ProtoBCO Name -> BcM () +emitBc :: ([Ptr ()] -> ProtoBCO Name) -> BcM () emitBc bco st - = ((), st{bcos = bco : bcos st}) + = return (st{bcos = bco (malloced st) : bcos st, malloced=[]}, ()) -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 -> IO AsmState -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) - - init_n_insns = 10 - init_n_lits = 4 - init_n_ptrs = 4 - in - do insns <- newXIOUArray init_n_insns :: IO (XIOUArray Word16) - lits <- newXIOUArray init_n_lits :: IO (XIOUArray Word32) - ptrs <- newXIOArray init_n_ptrs -- :: IO (XIOArray Name) - - -- pass 2: generate the instruction, ptr and nonptr bits - let init_asm_state = (insns,lits,ptrs) - final_asm_state <- mkBits findLabel init_asm_state instrs - - return final_asm_state - - --- instrs nonptrs ptrs -type AsmState = (XIOUArray Word16, XIOUArray Word32, XIOArray Name) - - --- This is where all the action is (pass 2 of the assembler) -mkBits :: (Int -> Int) -- label finder - -> AsmState - -> [BCInstr] -- instructions (in) - -> IO AsmState - -mkBits findLabel st proto_insns - = foldM doInstr st proto_insns - where - doInstr :: AsmState -> BCInstr -> IO AsmState - doInstr st i - = case i of - ARGCHECK n -> instr2 st i_ARGCHECK n -{- - PUSH_L o1 -> do { instr2 i_PUSH_L o1 } - PUSH_LL o1 o2 -> do { instr3 i_PUSH_LL o1 o2 } - PUSH_LLL o1 o2 o3 -> do { instr4 i_PUSH_LLL o1 o2 o3 } - PUSH_G nm -> do { p <- ptr nm; instr2 i_PUSH_G p } - PUSH_AS nm pk -> do { p <- ptr nm ; np <- ret_itbl pk; - instr3 i_PUSH_AS p np } - PUSH_UBX lit -> do { np <- literal lit; instr2 i_PUSH_UBX np } - PUSH_TAG tag -> do { instr2 i_PUSH_TAG tag } - SLIDE n by -> do { instr3 i_SLIDE n by } - ALLOC n -> do { instr2 i_ALLOC n } - MKAP off sz -> do { instr3 i_MKAP off sz } - UNPACK n -> do { instr2 i_UNPACK n } - UPK_TAG n m k -> do { instr4 i_UPK_TAG n m k } - PACK dcon sz -> do { np <- itbl dcon; instr3 i_PACK np sz } - LABEL lab -> do { instr0 } - TESTLT_I i l -> do { np <- int i; instr3 i_TESTLT_I np (findLabel l) } - TESTRQ_I i l -> do { np <- int i; instr3 i_TESTEQ_I np (findLabel l) } - TESTLT_F f l -> do { np <- float f; instr3 i_TESTLT_F np (findLabel l) } - TESTEQ_F f l -> do { np <- float f; instr3 i_TESTEQ_F np (findLabel l) } - TESTLT_D d l -> do { np <- double d; instr3 i_TESTLT_D np (findLabel l) } - TESTEQ_D d l -> do { np <- double d; instr3 i_TESTEQ_D np (findLabel l) } - TESTLT_P i l -> do { np <- int i; instr3 i_TESTLT_P np (findLabel l) } - TESTEQ_P i l -> do { np <- int i; instr3 i_TESTEQ_P np (findLabel l) } - CASEFAIL -> do { instr1 i_CASEFAIL } - ENTER -> do { instr1 i_ENTER } --} - where - instr2 (st_i0,st_l0,st_p0) i1 i2 - = do st_i1 <- addToXIOUArray st_i0 (i2s i1) - st_i2 <- addToXIOUArray st_i1 (i2s i2) - return (st_i2,st_l0,st_p0) - - i2s :: Int -> Word16 - i2s = fromIntegral - -{- - instr2 i1 i2 = instr i1 >> instr i2 - instr3 i1 i2 i3 = instr2 i1 i2 >> instr i3 - instr4 i1 i2 i3 i4 = instr2 i1 i2 >> instr2 i3 i4 - - instr :: Word16 -> IO Ctrs - instr i - = do n_is <- readIORef v_n_is - writeInstr n_is i - writeIORef v_n_is (n_is+1) - - - nop = go n_is n_lits n_ptrs instrs - - instr1 i1 next - = do writeInstr r_is i1 n_is - next (n_is+1) n_lits n_ptrs instrs - instr2 i1 i2 next - = do writeInstr r_is i1 n_is - writeInstr r_is i1 (n_is+1) - next (n_is+2) n_lits n_ptrs instrs - instr3 i1 i2 i3 next - = do writeInstr r_is i1 n_is - writeInstr r_is i2 (n_is+1) - writeInstr r_is i3 (n_is+2) - next (n_is+3) n_lits n_ptrs instrs - - ptr p n_is n_lits n_ptrs instrs - = do writeArray r_ptrs p n_ptrs - mkBits n_is n_lits (n_ptrs+1) instrs - - int i n_is n_lits n_ptrs instrs - = do n_lits <- doILit r_lits i n_lits - mkBits n_is n_lits n_ptrs instrs - - float f n_is n_lits n_ptrs instrs - = do n_lits <- doFLit r_lits f n_lits - mkBits n_is n_lits n_ptrs instrs - - double d n_is n_lits n_ptrs instrs - = do n_lits <- doDLit r_lits d n_lits - mkBits n_is n_lits n_ptrs instrs - - addr a n_is n_lits n_ptrs instrs - = do n_lits <- doALit r_lits a n_lits - mkBits n_is n_lits n_ptrs instrs --} +newbcoBc :: BcM () +newbcoBc st + | not (null (malloced st)) + = panic "ByteCodeGen.newbcoBc: missed prior emitBc?" + | otherwise + = return (st, ()) ---writeInstr :: MutableByteArray# -> Int -> Int -> IO () ---writeInstr arr# ix e = IO $ \s -> --- case writeWord16Array# arr# ix e of - - - --- 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 - 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 - f_arr <- castSTUArray arr - w0 <- readWord32Array f_arr 0 - return [w0] - ) +recordMallocBc :: Ptr a -> BcM () +recordMallocBc a st + = return (st{malloced = castPtr a : malloced st}, ()) -mkDLit d - = runST (do - arr <- newDoubleArray ((0::Int),0) - writeDoubleArray arr 0 d - d_arr <- castSTUArray arr - w0 <- readWord32Array d_arr 0 - w1 <- readWord32Array d_arr 1 - return [w0,w1] - ) +getLabelBc :: BcM Int +getLabelBc st + = return (st{nextlabel = 1 + nextlabel st}, nextlabel st) -mkILit i - | wORD_SIZE == 4 - = runST (do - arr <- newIntArray ((0::Int),0) - writeIntArray arr 0 i - i_arr <- castSTUArray arr - w0 <- readWord32Array i_arr 0 - return [w0] - ) - | wORD_SIZE == 8 - = runST (do - arr <- newIntArray ((0::Int),0) - writeIntArray arr 0 i - i_arr <- castSTUArray arr - w0 <- readWord32Array i_arr 0 - w1 <- readWord32Array i_arr 1 - return [w0,w1] - ) - -mkALit a - | wORD_SIZE == 4 - = runST (do - arr <- newAddrArray ((0::Int),0) - writeAddrArray arr 0 a - a_arr <- castSTUArray arr - w0 <- readWord32Array a_arr 0 - return [w0] - ) - | wORD_SIZE == 8 - = runST (do - arr <- newAddrArray ((0::Int),0) - writeAddrArray arr 0 a - a_arr <- castSTUArray arr - w0 <- readWord32Array a_arr 0 - w1 <- readWord32Array a_arr 1 - return [w0,w1] - ) - - - --- Zero-based expandable arrays -data XIOUArray ele = XIOUArray Int (IOUArray Int ele) -data XIOArray ele = XIOArray Int (IOArray Int ele) - -newXIOUArray size - = do arr <- newArray (0, size-1) - return (XIOUArray 0 arr) - -addToXIOUArray :: MArray IOUArray a IO - => XIOUArray a -> a -> IO (XIOUArray a) -addToXIOUArray (XIOUArray n_arr arr) x - = case bounds arr of - (lo, hi) -> ASSERT(lo == 0) - if n_arr > hi - then do new_arr <- newArray (0, 2*hi-1) - copy hi arr new_arr - addToXIOUArray (XIOUArray n_arr new_arr) x - else do writeArray arr n_arr x - return (XIOUArray (n_arr+1) arr) - where - copy :: MArray IOUArray a IO - => Int -> IOUArray Int a -> IOUArray Int a -> IO () - copy n src dst - | n < 0 = return () - | otherwise = do nx <- readArray src n - writeArray dst n nx - copy (n-1) src dst - - - -newXIOArray size - = do arr <- newArray (0, size-1) - return (XIOArray 0 arr) - -addToXIOArray :: XIOArray a -> a -> IO (XIOArray a) -addToXIOArray (XIOArray n_arr arr) x - = case bounds arr of - (lo, hi) -> ASSERT(lo == 0) - if n_arr > hi - then do new_arr <- newArray (0, 2*hi-1) - copy hi arr new_arr - addToXIOArray (XIOArray n_arr new_arr) x - else do writeArray arr n_arr x - return (XIOArray (n_arr+1) arr) - where - copy :: Int -> IOArray Int a -> IOArray Int a -> IO () - copy n src dst - | n < 0 = return () - | otherwise = do nx <- readArray src n - writeArray dst n nx - copy (n-1) src dst - - -#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 return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1]) \end{code}