X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FByteCodeGen.lhs;h=f6cf787493f313f95913187a0dfa6f09bbd3a52b;hb=2cc5b907318f97e19b28b2ad8ed9ff8c1f401dcc;hp=7afcb10f028e16d01a27643c64b4c26b9f632072;hpb=fa43635750d12f6c2c3cbf7ad62851399345a64a;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index 7afcb10..f6cf787 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -6,54 +6,65 @@ \begin{code} module ByteCodeGen ( UnlinkedBCO, UnlinkedBCOExpr, ItblEnv, ClosureEnv, HValue, filterNameMap, - byteCodeGen, coreExprToBCOs, - linkIModules, linkIExpr + byteCodeGen, coreExprToBCOs ) where #include "HsVersions.h" import Outputable -import Name ( Name, getName, mkSysLocalName ) -import Id ( Id, idType, isDataConId_maybe, mkVanillaId, - isPrimOpId_maybe ) +import Name ( Name, getName ) +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, plusFM ) +import FiniteMap ( FiniteMap, addListToFM, listToFM, elemFM, + addToFM, lookupFM, fmToList ) import CoreSyn import PprCore ( pprCoreExpr ) import Literal ( Literal(..), literalPrimRep ) import PrimRep ( PrimRep(..) ) -import PrimOp ( PrimOp(..) ) +import PrimOp ( PrimOp(..) ) import CoreFVs ( freeVars ) -import Type ( typePrimRep ) -import DataCon ( dataConTag, fIRST_TAG, dataConTyCon, dataConWrapId ) -import TyCon ( TyCon, tyConFamilySize ) +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 Util ( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem ) +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 ByteCodeInstr ( BCInstr(..), ProtoBCO(..), nameOfProtoBCO ) +import SMRep ( arrWordsHdrSize, arrPtrsHdrSize ) +import Constants ( wORD_SIZE ) +import ByteCodeInstr ( BCInstr(..), ProtoBCO(..), nameOfProtoBCO, bciStackUse ) import ByteCodeItbls ( ItblEnv, mkITbls ) import ByteCodeLink ( UnlinkedBCO, UnlinkedBCOExpr, assembleBCO, - ClosureEnv, HValue, linkSomeBCOs, filterNameMap ) + ClosureEnv, HValue, filterNameMap, linkFail, + iNTERP_STACK_CHECK_THRESH ) +import ByteCodeFFI ( taggedSizeW, untaggedSizeW, mkMarshalCode, moan64 ) +import Linker ( lookupSymbol ) -import List ( intersperse, sortBy ) -import Foreign ( Ptr(..), mallocBytes ) -import Addr ( Addr(..), addrToInt, writeCharOffAddr ) +import List ( intersperse, sortBy, zip4 ) +import Foreign ( Ptr(..), castPtr, mallocBytes, pokeByteOff, Word8 ) import CTypes ( CInt ) +import Exception ( throwDyn ) -import PrelBase ( Int(..) ) -import PrelGHC ( ByteArray# ) -import IOExts ( unsafePerformIO ) -import PrelIOBase ( IO(..) ) +import GlaExts ( Int(..), ByteArray# ) +import Monad ( when ) +import Maybe ( isJust ) +import Char ( ord ) \end{code} %************************************************************************ @@ -76,10 +87,15 @@ byteCodeGen dflags binds local_tycons 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 (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))) @@ -99,12 +115,20 @@ 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_name = mkSysLocalName (mkPseudoUnique3 0) SLIT("Expr-Top-Level") - let invented_id = mkVanillaId invented_name (panic "invented_id's type") + 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?") - 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))) @@ -118,27 +142,6 @@ coreExprToBCOs dflags expr root_bco <- assembleBCO root_proto_bco return (root_bco, auxiliary_bcos) - - --- Linking stuff -linkIModules :: ItblEnv -- incoming global itbl env; returned updated - -> ClosureEnv -- incoming global closure env; returned updated - -> [([UnlinkedBCO], ItblEnv)] - -> IO ([HValue], ItblEnv, ClosureEnv) -linkIModules gie gce mods - = do let (bcoss, ies) = unzip mods - bcos = concat bcoss - final_gie = foldr plusFM gie ies - (final_gce, linked_bcos) <- linkSomeBCOs final_gie gce bcos - return (linked_bcos, final_gie, final_gce) - - -linkIExpr :: ItblEnv -> ClosureEnv -> UnlinkedBCOExpr - -> IO HValue -- IO BCO# really -linkIExpr ie ce (root_ul_bco, aux_ul_bcos) - = do (aux_ce, _) <- linkSomeBCOs ie ce aux_ul_bcos - (_, [root_bco]) <- linkSomeBCOs ie aux_ce [root_ul_bco] - return root_bco \end{code} %************************************************************************ @@ -168,13 +171,36 @@ 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 (id {-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 [] @@ -186,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 ' ' @@ -198,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) @@ -208,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]) @@ -216,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)) @@ -230,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 @@ -242,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. @@ -255,32 +284,131 @@ 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 d s p (fvs, AnnApp f a)) + = schemeT d s p (fvs, AnnApp f a) + schemeE d s p e@(fvs, AnnVar v) | isFollowableRep v_rep - = returnBc (schemeT d s p (fvs, AnnVar v)) + = -- 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 - `appOL` mkSLIDE szw (d-s) -- clear to sequel - `snocOL` RETURN v_rep) -- 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) - 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 @@ -298,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 (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) + + + +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. @@ -329,17 +519,21 @@ schemeE d s p (fvs, AnnCase scrut bndr alts) scrut_primrep = typePrimRep (idType bndr) isAlgCase - = case scrut_primrep of - CharRep -> False ; AddrRep -> False - 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 (unpack_code, d_after_unpack, p_after_unpack) - = mkUnpackCode binds_f d' p' + = 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) @@ -348,8 +542,12 @@ schemeE d s p (fvs, AnnCase scrut bndr alts) 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 - fIRST_TAG) + 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) @@ -387,95 +585,452 @@ schemeE d s p other (pprCoreExpr (deAnnotate other)) --- Compile code to do a tail call. Three cases: +-- Compile code to do a tail call. Specifically, push the fn, +-- slide the on-stack app back down to the sequel depth, +-- and enter. Four cases: +-- +-- 0. (Nasty hack). +-- An application "PrelGHC.tagToEnum# unboxed-int". +-- The int will be on the stack. Generate a code sequence +-- to convert it to the relevant constructor, SLIDE and ENTER. -- -- 1. A nullary constructor. Push its closure on the stack -- and SLIDE and RETURN. -- --- 2. Application of a non-nullary constructor, by defn saturated. +-- 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. -- --- 3. 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 -> Sequel -- Sequel depth -> BCEnv -- stack env -> AnnExpr Id VarSet - -> BCInstrList + -> BcM BCInstrList schemeT d s p app + -- | trace ("schemeT: env in = \n" ++ showSDocDebug (ppBCEnv p)) False -- = panic "schemeT ?!?!" - -- Handle case 1 +-- | 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 - = (PUSH_G (Left (getName con)) `consOL` mkSLIDE 1 (d-s)) - `snocOL` ENTER + = 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) + --) - -- Cases 2 and 3 + -- 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 - = code + = if is_con_call && isUnboxedTupleCon con + then unboxedTupleException + else do_pushery d (map snd args_final_r_to_l) - where - -- Extract the args (R->L) and fn - (args_r_to_l_raw, fn) = chomp app - chomp expr - = case snd expr of - AnnVar v -> ([], v) - AnnApp f a -> case chomp f of (az, f) -> (snd a:az, f) - other -> pprPanic "schemeT" - (ppr (deAnnotate (panic "schemeT.chomp", other))) - - args_r_to_l = filter (not.isTypeAtom) args_r_to_l_raw - isTypeAtom (AnnType _) = True - isTypeAtom _ = False - - -- decide if this is a constructor call, and rearrange - -- args appropriately. - maybe_dcon = isDataConId_maybe fn - is_con_call = case maybe_dcon of Nothing -> False; Just _ -> True - (Just con) = maybe_dcon - - args_final_r_to_l - | not is_con_call - = args_r_to_l + 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 - = filter (not.isPtr) args_r_to_l ++ filter isPtr args_r_to_l - where isPtr = isFollowableRep . atomRep - - -- make code to push the args and then do the SLIDE-ENTER thing - code = do_pushery d args_final_r_to_l - - tag_when_push = not is_con_call - narg_words = sum (map (get_arg_szw . atomRep) args_r_to_l) - get_arg_szw = if tag_when_push then taggedSizeW else untaggedSizeW - - do_pushery d (arg:args) - = let (push, arg_words) = pushAtom tag_when_push d p arg - in push `appOL` do_pushery (d+arg_words) args - do_pushery d [] - = case maybe_dcon of - Just con -> PACK con narg_words `consOL` ( - mkSLIDE 1 (d - narg_words - s) `snocOL` ENTER) - Nothing - -> let (push, arg_words) = pushAtom True d p (AnnVar fn) - in push - `appOL` mkSLIDE (narg_words+arg_words) - (d - s - narg_words) - `snocOL` ENTER - -mkSLIDE n d - = if d == 0 then nilOL else unitOL (SLIDE n d) + = 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 + 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 @@ -537,11 +1092,10 @@ 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) - = case npr of - IntRep -> approved ; FloatRep -> approved - DoubleRep -> approved ; AddrRep -> approved - CharRep -> approved - _ -> pprPanic "ByteCodeGen.mkUnpackCode" (ppr npr) + | 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 @@ -573,15 +1127,22 @@ 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 + = 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 - = case primop of - CCallOp _ -> panic "pushAtom: byte code generator can't handle CCalls" - other -> (unitOL (PUSH_G (Right primop)), 1) + = returnBc (unitOL (PUSH_G (Right primop)), 1) | otherwise - = let str = "\npushAtom " ++ showSDocDebug (ppr v) + = let {- + str = "\npushAtom " ++ showSDocDebug (ppr v) ++ " :: " ++ showSDocDebug (pprType (idType v)) ++ ", depth = " ++ show d ++ ", tagged = " ++ show tagged ++ ", env =\n" ++ @@ -589,9 +1150,7 @@ pushAtom tagged d p (AnnVar v) ++ " --> words: " ++ show (snd result) ++ "\n" ++ showSDoc (nest 4 (vcat (map ppr (fromOL (fst result))))) ++ "\nendPushAtom " ++ showSDocDebug (ppr v) - where - cmp_snd x y = compare (snd x) (snd y) - str' = if str == str then str else str + -} result = case lookupBCEnv_maybe p v of @@ -606,15 +1165,15 @@ pushAtom tagged d p (AnnVar 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 + MachWord w -> code WordRep MachInt i -> code IntRep MachFloat r -> code FloatRep MachDouble r -> code DoubleRep @@ -623,12 +1182,13 @@ pushAtom False d p (AnnLit lit) where code rep = let size_host_words = untaggedSizeW rep - in (unitOL (PUSH_UBX 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 + CharStr s i -> returnBc (Ptr s) FastString _ l ba -> -- sigh, a string in the heap is no good to us. @@ -638,19 +1198,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" - - addrLit - = MachInt (toInteger (addrToInt mallocvilleAddr)) + other -> panic "ByteCodeGen.pushAtom.pushStr" in + getMallocvilleAddr `thenBc` \ addr -> -- Get the addr on the stack, untaggedly - (unitOL (PUSH_UBX addrLit 1), 1) + returnBc (unitOL (PUSH_UBX (Right addr) 1), 1) @@ -662,11 +1221,15 @@ pushAtom tagged d p (AnnApp f (_, AnnType _)) pushAtom tagged d p (AnnNote note e) = pushAtom tagged d p (snd e) +pushAtom tagged d p (AnnLam x e) + | isTyVar x + = pushAtom tagged d p (snd e) + pushAtom tagged d p other = pprPanic "ByteCodeGen.pushAtom" (pprCoreExpr (deAnnotate (undefined, other))) -foreign import "strncpy" strncpy :: Ptr a -> ByteArray# -> CInt -> IO () +foreign import "memcpy" memcpy :: Ptr a -> ByteArray# -> CInt -> IO () -- Given a bunch of alts code and their discrs, do the donkey work @@ -814,24 +1377,22 @@ 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} %************************************************************************ @@ -843,23 +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 + 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 [] @@ -868,12 +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=[]}, ()) + +newbcoBc :: BcM () +newbcoBc st + | not (null (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 return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1]) \end{code}