X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FByteCodeGen.lhs;h=72f4d620435f42c8778a2940534d5083317d1cb8;hb=b7cc3d012a98cc49abb3441e6637d5148f57f1d1;hp=59170d5f08b3b393138972c792801f81bcaa7f3e;hpb=daf8e15b8dcad8808ad068c3b93ee5fe99ece5bf;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index 59170d5..72f4d62 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -4,64 +4,71 @@ \section[ByteCodeGen]{Generate bytecode from Core} \begin{code} -module ByteCodeGen ( UnlinkedBCO, UnlinkedBCOExpr, ItblEnv, ClosureEnv, HValue, - filterNameMap, - byteCodeGen, coreExprToBCOs +module ByteCodeGen ( UnlinkedBCO, UnlinkedBCOExpr, + byteCodeGen, coreExprToBCOs ) where #include "HsVersions.h" +import ByteCodeInstr ( BCInstr(..), ProtoBCO(..), nameOfProtoBCO, bciStackUse ) +import ByteCodeFFI ( taggedSizeW, untaggedSizeW, mkMarshalCode, moan64 ) +import ByteCodeAsm ( CompiledByteCode(..), UnlinkedBCO, UnlinkedBCOExpr, + assembleBCO, assembleBCOs, iNTERP_STACK_CHECK_THRESH ) +import ByteCodeLink ( lookupStaticPtr ) + import Outputable -import Name ( Name, getName ) +import Name ( Name, getName, mkSystemName ) import Id ( Id, idType, isDataConId_maybe, isPrimOpId_maybe, isFCallId, - idPrimRep, mkSysLocal, idName, isFCallId_maybe ) + idPrimRep, mkLocalId, isFCallId_maybe, isPrimOpId ) import ForeignCall ( ForeignCall(..), CCallTarget(..), CCallSpec(..) ) import OrdList ( OrdList, consOL, snocOL, appOL, unitOL, nilOL, toOL, concatOL, fromOL ) -import FiniteMap ( FiniteMap, addListToFM, listToFM, +import FiniteMap ( FiniteMap, addListToFM, listToFM, elemFM, addToFM, lookupFM, fmToList ) +import HscTypes ( ModGuts(..), ModGuts, typeEnvTyCons, typeEnvClasses ) +import CoreUtils ( exprType ) import CoreSyn import PprCore ( pprCoreExpr ) import Literal ( Literal(..), literalPrimRep ) import PrimRep ( PrimRep(..) ) -import PrimOp ( PrimOp(..) ) +import PrimOp ( PrimOp(..) ) import CoreFVs ( freeVars ) -import Type ( typePrimRep, splitTyConApp_maybe, isTyVarTy, splitForAllTys ) +import Type ( typePrimRep, isUnLiftedType, splitTyConApp_maybe, isTyVarTy ) import DataCon ( dataConTag, fIRST_TAG, dataConTyCon, dataConWrapId, isUnboxedTupleCon ) -import TyCon ( TyCon(..), tyConFamilySize, isDataTyCon, tyConDataCons, +import TyCon ( tyConFamilySize, isDataTyCon, tyConDataCons, isFunTyCon, isUnboxedTupleTyCon ) import Class ( Class, classTyCon ) -import Type ( Type, repType, splitRepFunTys ) -import Util ( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem ) +import Type ( Type, repType, splitFunTys, dropForAlls ) +import Util ( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem, + isSingleton, lengthIs, notNull ) +import DataCon ( dataConRepArity ) import Var ( isTyVar ) import VarSet ( VarSet, varSetElems ) -import PrimRep ( getPrimRepSize, isFollowableRep ) +import TysPrim ( foreignObjPrimTyCon, + arrayPrimTyCon, mutableArrayPrimTyCon, + byteArrayPrimTyCon, mutableByteArrayPrimTyCon + ) +import PrimRep ( isFollowableRep ) import CmdLineOpts ( DynFlags, DynFlag(..) ) import ErrUtils ( showPass, dumpIfSet_dyn ) import Unique ( mkPseudoUnique3 ) -import FastString ( FastString(..) ) +import FastString ( FastString(..), unpackFS ) 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 ByteCodeFFI ( taggedSizeW, untaggedSizeW, mkMarshalCode ) -import Linker ( lookupSymbol ) +import SMRep ( arrWordsHdrSize, arrPtrsHdrSize ) +import Constants ( wORD_SIZE ) import List ( intersperse, sortBy, zip4 ) -import Foreign ( Ptr(..), mallocBytes ) -import Addr ( Addr(..), nullAddr, addrToInt, writeCharOffAddr ) -import CTypes ( CInt ) -import Exception ( throwDyn ) +import Foreign ( Ptr, castPtr, mallocBytes, pokeByteOff, Word8 ) +import Foreign.C ( CInt ) +import Control.Exception ( throwDyn ) -import PrelBase ( Int(..) ) -import PrelGHC ( ByteArray# ) -import IOExts ( unsafePerformIO ) -import PrelIOBase ( IO(..) ) +import GHC.Exts ( Int(..), ByteArray# ) +import Monad ( when ) +import Maybe ( isJust ) +import Char ( ord ) \end{code} %************************************************************************ @@ -73,28 +80,31 @@ import PrelIOBase ( IO(..) ) \begin{code} byteCodeGen :: DynFlags - -> [CoreBind] - -> [TyCon] -> [Class] - -> IO ([UnlinkedBCO], ItblEnv) -byteCodeGen dflags binds local_tycons local_classes + -> ModGuts + -> IO CompiledByteCode +byteCodeGen dflags (ModGuts { mg_binds = binds, mg_types = type_env }) = do showPass dflags "ByteCodeGen" - let tycs = local_tycons ++ map classTyCon local_classes - itblenv <- mkITbls tycs + let local_tycons = typeEnvTyCons type_env + local_classes = typeEnvClasses type_env + tycs = local_tycons ++ map classTyCon local_classes 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 + + (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 (notNull 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) + assembleBCOs proto_bcos tycs -- Returns: (the root BCO for this expression, @@ -107,13 +117,18 @@ coreExprToBCOs dflags expr -- 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 invented_name = mkSystemName (mkPseudoUnique3 0) FSLIT("ExprTopLevel") + invented_id = mkLocalId invented_name (panic "invented_id's type") + 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 (notNull mallocd) + (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?") - 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))) @@ -156,8 +171,8 @@ ppBCEnv p -- Create a BCO and do a spot of peephole optimisation on the insns -- at the same time. -mkProtoBCO nm instrs_ordlist origin - = ProtoBCO nm maybe_with_stack_check 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 @@ -197,8 +212,8 @@ mkProtoBCO nm instrs_ordlist origin -- variable to which this value was bound, so as to give the -- resulting BCO a name. Bool indicates top-levelness. -schemeR :: Bool -> (Id, AnnExpr Id VarSet) -> BcM () -schemeR is_top (nm, rhs) +schemeR :: Bool -> [Id] -> (Id, AnnExpr Id VarSet) -> BcM () +schemeR is_top fvs (nm, rhs) {- | trace (showSDoc ( (char ' ' @@ -209,7 +224,7 @@ schemeR is_top (nm, rhs) = undefined -} | otherwise - = schemeR_wrk is_top rhs nm (collect [] rhs) + = schemeR_wrk is_top fvs rhs nm (collect [] rhs) collect xs (_, AnnNote note e) @@ -219,7 +234,7 @@ collect xs (_, AnnLam x e) collect xs not_lambda = (reverse xs, not_lambda) -schemeR_wrk is_top original_body nm (args, body) +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]) @@ -227,8 +242,7 @@ schemeR_wrk is_top original_body nm (args, body) --) | otherwise - = let fvs = filter (not.isTyVar) (varSetElems (fst original_body)) - all_args = reverse args ++ fvs + = 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)) @@ -241,7 +255,7 @@ schemeR_wrk is_top original_body nm (args, body) where maybe_toplevel_null_con_rhs | is_top && null args - = case snd body of + = case nukeTyArgs (snd body) of AnnVar v_wrk -> case isDataConId_maybe v_wrk of Nothing -> Nothing @@ -253,6 +267,10 @@ schemeR_wrk is_top original_body nm (args, body) | 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 -- should map these items to. @@ -269,31 +287,130 @@ schemeE d s p e@(fvs, AnnApp f a) = schemeT d s p (fvs, AnnApp f a) schemeE d s p e@(fvs, AnnVar v) - | isFollowableRep v_rep - = -- Ptr-ish thing; push it in the normal way + | not (isUnLiftedType v_type) + = -- Lifted-type 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 - `appOL` mkSLIDE szw (d-s) -- clear to sequel - `snocOL` RETURN v_rep) -- go + = -- Returning an unlifted value. + -- Heave it on the stack, SLIDE, and RETURN. + 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) + v_type = idType v + v_rep = typePrimRep v_type schemeE d s p (fvs, AnnLit literal) - = let (push, szw) = pushAtom True d p (AnnLit literal) - l_rep = literalPrimRep literal + = pushAtom True d p (AnnLit literal) `thenBc` \ (push, szw) -> + let l_rep = literalPrimRep literal in returnBc (push -- value onto stack `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 @@ -311,19 +428,27 @@ 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 (Left (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 False) (zip xs rhss) `thenBc_` + schemeRs fvss xs rhss `thenBc_` + genThunkCode `thenBc` \ thunkCode -> returnBc (allocCode `appOL` thunkCode `appOL` bodyCode) @@ -356,21 +481,35 @@ schemeE d s p (fvs_case, AnnCase (fvs_scrut, scrut) bndr 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") - -- ++ showSDoc (char ' ' $$ pprCoreExpr (deAnnotate new_expr) $$ char ' ')) (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. --} 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)]) - ) + -- Convert + -- case .... of x { (# VoidRep'd-thing, a #) -> ... } + -- to + -- case .... of a { DEFAULT -> ... } + -- becuse the return convention for both are identical. + -- + -- Note that it does not matter losing the void-rep thing from the + -- envt (it won't be bound now) because we never look such things up. + + = --trace "automagic mashing of case alts (# VoidRep, a #)" ( + schemeE d s p (fvs, AnnCase scrut bind2 [(DEFAULT, [], rhs)]) + -- Note: + --) + +schemeE d s p (fvs, AnnCase scrut bndr [(DataAlt dc, [bind1], rhs)]) + | isUnboxedTupleCon dc + -- Similarly, convert + -- case .... of x { (# a #) -> ... } + -- to + -- case .... of a { DEFAULT -> ... } + = --trace "automagic mashing of case alts (# a #)" ( + schemeE d s p (fvs, AnnCase scrut bind1 [(DEFAULT, [], rhs)]) + --) schemeE d s p (fvs, AnnCase scrut bndr alts) = let @@ -389,13 +528,13 @@ schemeE d s p (fvs, AnnCase scrut bndr alts) isAlgCase | 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) + | otherwise + = WARN( scrut_primrep `elem` bad_reps, + text "Dire warning: strange rep in primitive case:" <+> ppr bndr ) + -- We don't expect to see any of these + False + where + bad_reps = [CodePtrRep, DataPtrRep, RetRep, CostCentreRep] -- given an alt, return a discr and code for it. codeAlt alt@(discr, binds_f, rhs) @@ -458,7 +597,7 @@ schemeE d s p other -- and enter. Four cases: -- -- 0. (Nasty hack). --- An application "PrelGHC.tagToEnum# unboxed-int". +-- An application "GHC.Prim.tagToEnum# unboxed-int". -- The int will be on the stack. Generate a code sequence -- to convert it to the relevant constructor, SLIDE and ENTER. -- @@ -467,13 +606,16 @@ schemeE d s p other -- -- 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). +-- (the VoidRep takes up zero stack space). Also, spot +-- (# b #) and treat it as b. +-- +-- 3. The fn denotes a ccall. Defer to generateCCall. -- --- 3. Application of a non-nullary constructor, by defn saturated. +-- 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. -- --- 4. Otherwise, it must be a function call. Push the args +-- 5. Otherwise, it must be a function call. Push the args -- right to left, SLIDE and ENTER. schemeT :: Int -- Stack depth @@ -483,42 +625,51 @@ schemeT :: Int -- Stack depth -> 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 "?!?!" - -- Handle case 0 + -- Case 0 | Just (arg, constr_names) <- maybe_is_tagToEnum_call - = pushAtom True d p arg `bind` \ (push, arg_words) -> + = 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) - -- Handle case 1 + -- Case 1 | is_con_call && null args_r_to_l = returnBc ( (PUSH_G (Left (getName con)) `consOL` mkSLIDE 1 (d-s)) `snocOL` ENTER ) - -- Handle case 2 - | let isVoidRepAtom (_, AnnVar v) = VoidRep == typePrimRep (idType v) + -- Case 2 + | [arg1,arg2] <- args_r_to_l, + let + isVoidRepAtom (_, AnnVar v) = typePrimRep (idType v) == VoidRep isVoidRepAtom (_, AnnNote n e) = isVoidRepAtom e - in is_con_call && isUnboxedTupleCon con - && length args_r_to_l == 2 - && isVoidRepAtom (last (args_r_to_l)) - = trace ("schemeT: unboxed pair with Void first component") ( - schemeT d s p (head args_r_to_l) - ) + isVoidRepAtom _ = False + in + isVoidRepAtom arg2 + = --trace (if isSingleton args_r_to_l + -- then "schemeT: unboxed singleton" + -- else "schemeT: unboxed pair with Void first component") ( + schemeT d s p arg1 + --) - -- Cases 3 and 4 + -- 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 = if is_con_call && isUnboxedTupleCon con - then returnBc unboxedTupleException - else code `seq` returnBc code + then unboxedTupleException + else do_pushery d (map snd args_final_r_to_l) where -- Detect and extract relevant info for the tagToEnum kludge. @@ -527,7 +678,7 @@ schemeT d s p app = case splitTyConApp_maybe (repType ty) of (Just (tyc, [])) | isDataTyCon tyc -> map getName (tyConDataCons tyc) - other -> panic "maybe_is_tagToEnum_call.extract_constr_Ids" + other -> panic "maybe_is_tagToEnum_call.extract_constr_Ids" in case app of (_, AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg) @@ -537,23 +688,34 @@ schemeT d s p app other -> Nothing -- Extract the args (R->L) and fn - (args_r_to_l_raw, fn) = chomp app + (args_r_to_l, fn) = chomp app chomp expr = case snd expr of AnnVar v -> ([], v) - AnnApp f a -> case chomp f of (az, f) -> (a:az, f) + 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))) - - args_r_to_l = filter (not.isTypeAtom.snd) args_r_to_l_raw + (ppr (deAnnotate (panic "schemeT.chomp", other))) + + n_args = length args_r_to_l + 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 + -- 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 @@ -564,159 +726,284 @@ schemeT d s p app where isPtr = isFollowableRep . atomRep -- make code to push the args and then do the SLIDE-ENTER thing - code = do_pushery d (map snd args_final_r_to_l) 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) - = let (push, arg_words) = pushAtom tag_when_push d p arg - in push `appOL` do_pushery (d+arg_words) 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 [] - - -- CCALL ! - | Just (CCall (CCallSpec (StaticTarget target) - cconv safety)) <- isFCallId_maybe fn - = let -- Get the arg and result reps. - (a_reps, r_rep) = getCCallPrimReps (idType fn) - tys_str = showSDoc (ppr (a_reps, r_rep)) - {- - 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 - target_addr - = let unpacked = _UNPK_ target - in case unsafePerformIO (lookupSymbol unpacked) of - Just aa -> case aa of Ptr a# -> A# a# - Nothing -> panic ("interpreted ccall: can't resolve: " - ++ unpacked) - - -- push the Addr# - addr_usizeW = untaggedSizeW AddrRep - addr_tsizeW = taggedSizeW AddrRep - push_Addr = toOL [PUSH_UBX (Right target_addr) addr_usizeW, - PUSH_TAG addr_usizeW] - d_after_Addr = d + addr_tsizeW - -- push the return placeholder - r_lit = mkDummyLiteral r_rep - r_usizeW = untaggedSizeW r_rep - r_tsizeW = 1{-tag-} + r_usizeW - push_r = toOL [PUSH_UBX (Left r_lit) r_usizeW, - PUSH_TAG r_usizeW] - d_after_r = d_after_Addr + r_tsizeW - -- do the call - do_call = unitOL (CCALL addr_of_marshaller) - -- slide and return - wrapup = mkSLIDE r_tsizeW - (d_after_r - r_tsizeW - s) - `snocOL` RETURN r_rep - - -- 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))) - addr_of_marshaller - = mkMarshalCode (r_offW, r_rep) addr_offW - (zip args_offW a_reps) - in - --trace (show (arg1_offW, args_offW , (map taggedSizeW a_reps) )) ( - target_addr - `seq` - (push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup) - --) - + | Just (CCall ccall_spec) <- isFCallId_maybe fn + = panic "schemeT.do_pushery: unexpected ccall" | otherwise = case maybe_dcon of - Just con -> PACK con narg_words `consOL` ( - mkSLIDE 1 (d - narg_words - s) `snocOL` ENTER) + Just con -> returnBc ( + (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 + -> 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 -mkSLIDE n d - = if d == 0 then nilOL else unitOL (SLIDE n d) -bind x f - = f x +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 arg_ty = repType (exprType (deAnnotate' a)) + + in case splitTyConApp_maybe arg_ty of + -- Don't push the FO; instead push the Addr# it + -- contains. + Just (t, _) + | t == foreignObjPrimTyCon + -> pushAtom False{-irrelevant-} d p a + `thenBc` \ (push_fo, _) -> + let foro_szW = taggedSizeW PtrRep + 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) + + | t == arrayPrimTyCon || t == mutableArrayPrimTyCon + -> pargs (d + addr_tsizeW) az `thenBc` \ rest -> + parg_ArrayishRep arrPtrsHdrSize d p a + `thenBc` \ code -> + returnBc ((code,AddrRep):rest) + + | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon + -> 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, atomRep a) : 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 + -> ioToBc (lookupStaticPtr target) `thenBc` \res -> + returnBc (True, res) + 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 - _ -> pprPanic "mkDummyLiteral" (ppr pr) + _ -> moan64 "mkDummyLiteral" (ppr pr) -- Convert (eg) --- PrelGHC.Int# -> PrelGHC.State# PrelGHC.RealWorld --- -> (# PrelGHC.State# PrelGHC.RealWorld, PrelGHC.Int# #) +-- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld +-- -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #) +-- +-- to Just IntRep +-- and check that an unboxed pair is returned wherein the first arg is VoidRep'd. -- --- to [IntRep] -> IntRep --- and check that the last arg is VoidRep'd and that an unboxed pair is --- returned wherein the first arg is VoidRep'd. - -getCCallPrimReps :: Type -> ([PrimRep], PrimRep) -getCCallPrimReps fn_ty - = let (a_tys, r_ty) = splitRepFunTys fn_ty - a_reps = map typePrimRep a_tys +-- Alternatively, for call-targets returning nothing, convert +-- +-- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld +-- -> (# GHC.Prim.State# GHC.Prim.RealWorld #) +-- +-- to Nothing + +maybe_getCCallReturnRep :: Type -> Maybe PrimRep +maybe_getCCallReturnRep fn_ty + = let (a_tys, r_ty) = splitFunTys (dropForAlls 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 = length a_reps >= 1 && VoidRep == last a_reps - && length r_reps == 2 && VoidRep == head r_reps - && isUnboxedTupleTyCon r_tycon - && PtrRep /= r_rep_to_go -- if it was, it would be impossible - -- to create a valid return value - -- placeholder on the stack - a_reps_to_go = init a_reps - r_rep_to_go = r_reps !! 1 - blargh = pprPanic "getCCallPrimReps: can't handle:" - (pprType fn_ty) + 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 (a_reps_to_go, r_rep_to_go) else blargh + if ok then maybe_r_rep_to_go else blargh --) atomRep (AnnVar v) = typePrimRep (idType v) @@ -726,13 +1013,12 @@ 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)) + = ASSERT( notNull names ) getLabelsBc (length names) `thenBc` \ labels -> getLabelBc `thenBc` \ label_fail -> getLabelBc `thenBc` \ label_exit -> @@ -811,10 +1097,11 @@ mkUnpackCode vars d p 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, FloatRep, DoubleRep, CharRep, AddrRep] + | npr `elem` [IntRep, WordRep, FloatRep, DoubleRep, + CharRep, AddrRep, StablePtrRep] = approved | otherwise - = pprPanic "ByteCodeGen.mkUnpackCode" (ppr npr) + = 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 @@ -846,18 +1133,18 @@ mkUnpackCode vars d p -- 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 :: Bool -> Int -> BCEnv -> AnnExpr' Id VarSet -> BcM (BCInstrList, Int) pushAtom tagged d p (AnnVar v) | idPrimRep v == VoidRep - = ASSERT(tagged) - (unitOL (PUSH_TAG 0), 1) + = 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 - = (unitOL (PUSH_G (Right primop)), 1) + = returnBc (unitOL (PUSH_G (Right primop)), 1) | otherwise = let {- @@ -884,14 +1171,15 @@ pushAtom tagged d p (AnnVar v) sz_u = untaggedIdSizeW v nwords = if tagged then sz_t else sz_u in - 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 + MachLabel fs -> code CodePtrRep MachWord w -> code WordRep MachInt i -> code IntRep MachFloat r -> code FloatRep @@ -901,13 +1189,12 @@ pushAtom False d p (AnnLit lit) where code rep = let size_host_words = untaggedSizeW rep - in (unitOL (PUSH_UBX (Left lit) size_host_words), size_host_words) + in returnBc (unitOL (PUSH_UBX (Left lit) size_host_words), + size_host_words) pushStr s - = let mallocvilleAddr + = let getMallocvilleAddr = 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 @@ -916,16 +1203,18 @@ pushAtom False d p (AnnLit lit) -- 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#) + 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 ) - _ -> panic "StgInterp.lit2expr: unhandled string constant type" + other -> panic "ByteCodeGen.pushAtom.pushStr" in + getMallocvilleAddr `thenBc` \ addr -> -- Get the addr on the stack, untaggedly - (unitOL (PUSH_UBX (Right mallocvilleAddr) 1), 1) + returnBc (unitOL (PUSH_UBX (Right addr) 1), 1) @@ -945,7 +1234,7 @@ pushAtom tagged d p other = pprPanic "ByteCodeGen.pushAtom" (pprCoreExpr (deAnnotate (undefined, other))) -foreign import "strncpy" strncpy :: Ptr a -> ByteArray# -> CInt -> IO () +foreign import "memcpy" memcpy :: Ptr a -> ByteArray# -> CInt -> IO () -- Given a bunch of alts code and their discrs, do the donkey work @@ -1105,6 +1394,10 @@ unboxedTupleException "\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} %************************************************************************ @@ -1116,23 +1409,34 @@ unboxedTupleException \begin{code} data BcM_State = BcM_State { bcos :: [ProtoBCO Name], -- accumulates completed BCOs - nextlabel :: Int } -- for generating local labels + 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) -type BcM result = BcM_State -> (result, 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 [] @@ -1141,17 +1445,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=[]}, ()) + +newbcoBc :: BcM () +newbcoBc st + | notNull (malloced st) + = panic "ByteCodeGen.newbcoBc: missed prior emitBc?" + | otherwise + = return (st, ()) + +recordMallocBc :: Ptr a -> BcM () +recordMallocBc a st + = return (st{malloced = castPtr a : malloced st}, ()) getLabelBc :: BcM Int getLabelBc st - = (nextlabel st, st{nextlabel = 1 + nextlabel st}) + = return (st{nextlabel = 1 + nextlabel st}, nextlabel st) getLabelsBc :: Int -> BcM [Int] getLabelsBc n st = let ctr = nextlabel st - in ([ctr .. ctr+n-1], st{nextlabel = ctr+n}) + in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1]) \end{code}