X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FByteCodeGen.lhs;h=5f9fe003054988fed405aae3fc0e4c88bcd33494;hb=8e67f5502e2e316245806ee3735a2f41a844b611;hp=a5b10ca47e9555e425ddb5ec255804ab868384eb;hpb=f6e250ab5064795e7243954f1b0c7d5c1d961ddb;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index a5b10ca..5f9fe00 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -1,359 +1,247 @@ % -% (c) The University of Glasgow 2000 +% (c) The University of Glasgow 2002 % \section[ByteCodeGen]{Generate bytecode from Core} \begin{code} -module ByteCodeGen ( UnlinkedBCO, UnlinkedBCOExpr, ItblEnv, ClosureEnv, HValue, - filterNameMap, - byteCodeGen, coreExprToBCOs, - linkIModules, linkIExpr - ) where +module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where #include "HsVersions.h" +import ByteCodeInstr +import ByteCodeFFI ( mkMarshalCode, moan64 ) +import ByteCodeAsm ( CompiledByteCode(..), UnlinkedBCO, + assembleBCO, assembleBCOs, iNTERP_STACK_CHECK_THRESH ) +import ByteCodeLink ( lookupStaticPtr ) + import Outputable -import Name ( Name, getName, nameModule, mkSysLocalName, toRdrName ) -import RdrName ( rdrNameOcc, rdrNameModule ) -import OccName ( occNameString ) -import Id ( Id, idType, isDataConId_maybe, mkVanillaId ) -import OrdList ( OrdList, consOL, snocOL, appOL, unitOL, - nilOL, toOL, concatOL, fromOL ) -import FiniteMap ( FiniteMap, addListToFM, listToFM, filterFM, - addToFM, lookupFM, fmToList, emptyFM, plusFM ) +import Name ( Name, getName, mkSystemVarName ) +import Id +import FiniteMap +import ForeignCall ( ForeignCall(..), CCallTarget(..), CCallSpec(..) ) +import HscTypes ( TypeEnv, typeEnvTyCons, typeEnvClasses ) +import CoreUtils ( exprType ) import CoreSyn -import PprCore ( pprCoreExpr, pprCoreAlt ) -import Literal ( Literal(..), literalPrimRep ) -import PrimRep ( PrimRep(..) ) +import PprCore ( pprCoreExpr ) +import Literal ( Literal(..), literalType ) +import PrimOp ( PrimOp(..) ) import CoreFVs ( freeVars ) -import Type ( typePrimRep ) +import Type ( isUnLiftedType, splitTyConApp_maybe ) import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon, - dataConRepArgTys ) -import TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons ) + isUnboxedTupleCon, isNullaryRepDataCon, dataConWorkId, + dataConRepArity ) +import TyCon ( tyConFamilySize, isDataTyCon, tyConDataCons, + isUnboxedTupleTyCon ) import Class ( Class, classTyCon ) -import Util ( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem, global ) +import Type ( Type, repType, splitFunTys, dropForAlls, pprType ) +import Util +import DataCon ( dataConRepArity ) import Var ( isTyVar ) import VarSet ( VarSet, varSetElems ) -import PrimRep ( getPrimRepSize, isFollowableRep ) -import Constants ( wORD_SIZE ) +import TysPrim ( arrayPrimTyCon, mutableArrayPrimTyCon, + byteArrayPrimTyCon, mutableByteArrayPrimTyCon + ) import CmdLineOpts ( DynFlags, DynFlag(..) ) import ErrUtils ( showPass, dumpIfSet_dyn ) -import ClosureInfo ( mkVirtHeapOffsets ) -import Module ( ModuleName, moduleName, moduleNameFS ) -import Unique ( mkPseudoUnique3 ) -import Linker ( lookupSymbol ) -import FastString ( FastString(..) ) - - -import List ( intersperse ) -import Monad ( foldM ) -import ST ( runST ) -import MArray ( castSTUArray, - newFloatArray, writeFloatArray, - newDoubleArray, writeDoubleArray, - newIntArray, writeIntArray, - newAddrArray, writeAddrArray ) -import Foreign ( Storable(..), Word8, Word16, Word32, Ptr(..), - malloc, castPtr, plusPtr, mallocBytes ) -import Addr ( Word, addrToInt, nullAddr, writeCharOffAddr ) -import Bits ( Bits(..), shiftR ) -import CTypes ( CInt ) - -import PrelBase ( Int(..) ) -import PrelAddr ( Addr(..) ) -import PrelGHC ( BCO#, newBCO#, unsafeCoerce#, - ByteArray#, Array#, addrToHValue# ) -import IOExts ( IORef, fixIO, unsafePerformIO ) -import ArrayBase -import PrelArr ( Array(..) ) -import PrelIOBase ( IO(..) ) +import Unique ( mkPseudoUniqueE ) +import FastString ( FastString(..), unpackFS ) +import Panic ( GhcException(..) ) +import SMRep ( typeCgRep, arrWordsHdrSize, arrPtrsHdrSize, StgWord, + CgRep(..), cgRepSizeW, isFollowableArg, idCgRep ) +import Bitmap ( intsToReverseBitmap, mkBitmap ) +import OrdList +import Constants ( wORD_SIZE ) -\end{code} +import Data.List ( intersperse, sortBy, zip4, zip5, partition ) +import Foreign ( Ptr, castPtr, mallocBytes, pokeByteOff, Word8 ) +import Foreign.C ( CInt ) +import Control.Exception ( throwDyn ) -%************************************************************************ -%* * -\subsection{Functions visible from outside this module.} -%* * -%************************************************************************ +import GHC.Exts ( Int(..), ByteArray# ) -\begin{code} +import Control.Monad ( when ) +import Data.Char ( ord, chr ) + +-- ----------------------------------------------------------------------------- +-- Generating byte code for a complete module byteCodeGen :: DynFlags - -> [CoreBind] - -> [TyCon] -> [Class] - -> IO ([UnlinkedBCO], ItblEnv) -byteCodeGen dflags binds local_tycons local_classes + -> [CoreBind] + -> TypeEnv + -> IO CompiledByteCode +byteCodeGen dflags binds 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 flatBinds `thenBc_` returnBc ()) - (BcM_State proto_bcos final_ctr) = final_state + let flatBinds = [ (bndr, freeVars rhs) + | (bndr, rhs) <- flattenBinds binds] - dumpIfSet_dyn dflags Opt_D_dump_BCOs - "Proto-bcos" (vcat (intersperse (char ' ') (map ppr proto_bcos))) + (BcM_State final_ctr mallocd, proto_bcos) + <- runBc (mapM schemeTopBind flatBinds) + + when (notNull mallocd) + (panic "ByteCodeGen.byteCodeGen: missing final emitBc?") - bcos <- mapM assembleBCO proto_bcos + dumpIfSet_dyn dflags Opt_D_dump_BCOs + "Proto-BCOs" (vcat (intersperse (char ' ') (map ppr proto_bcos))) - return (bcos, itblenv) + assembleBCOs proto_bcos tycs +-- ----------------------------------------------------------------------------- +-- Generating byte code for an expression -- Returns: (the root BCO for this expression, -- a list of auxilary BCOs resulting from compiling closures) coreExprToBCOs :: DynFlags -> CoreExpr - -> IO UnlinkedBCOExpr + -> IO UnlinkedBCO 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_name = mkSysLocalName (mkPseudoUnique3 0) SLIT("Expr-Top-Level") - let invented_id = mkVanillaId invented_name (panic "invented_id's type") - - let (BcM_State all_proto_bcos final_ctr) - = runBc (BcM_State [] 0) - (schemeR (invented_id, freeVars expr)) - dumpIfSet_dyn dflags Opt_D_dump_BCOs - "Proto-bcos" (vcat (intersperse (char ' ') (map ppr all_proto_bcos))) - - let root_proto_bco - = case filter ((== invented_name).nameOfProtoBCO) all_proto_bcos of - [root_bco] -> root_bco - auxiliary_proto_bcos - = filter ((/= invented_name).nameOfProtoBCO) all_proto_bcos - - auxiliary_bcos <- mapM assembleBCO auxiliary_proto_bcos - root_bco <- assembleBCO root_proto_bco - - return (root_bco, auxiliary_bcos) - - --- 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 - --- Link a bunch of BCOs and return them + updated closure env. -linkSomeBCOs :: ItblEnv -> ClosureEnv -> [UnlinkedBCO] - -> IO (ClosureEnv, [HValue]) -linkSomeBCOs ie ce_in ul_bcos - = do let nms = map nameOfUnlinkedBCO ul_bcos - hvals <- fixIO - ( \ hvs -> let ce_out = addListToFM ce_in (zipLazily nms hvs) - in mapM (linkBCO ie ce_out) ul_bcos ) - let ce_out = addListToFM ce_in (zip nms hvals) - return (ce_out, hvals) - where - -- A lazier zip, in which no demand is propagated to the second - -- list unless some demand is propagated to the snd of one of the - -- result list elems. - zipLazily [] ys = [] - zipLazily (x:xs) ys = (x, head ys) : zipLazily xs (tail ys) - - -data UnlinkedBCO - = UnlinkedBCO Name - (SizedSeq Word16) -- insns - (SizedSeq Word) -- literals - (SizedSeq Name) -- ptrs - (SizedSeq Name) -- itbl refs - -nameOfUnlinkedBCO (UnlinkedBCO nm _ _ _ _) = nm - --- When translating expressions, we need to distinguish the root --- BCO for the expression -type UnlinkedBCOExpr = (UnlinkedBCO, [UnlinkedBCO]) - -instance Outputable UnlinkedBCO where - ppr (UnlinkedBCO nm insns lits ptrs itbls) - = sep [text "BCO", ppr nm, text "with", - int (sizeSS insns), text "insns", - int (sizeSS lits), text "lits", - int (sizeSS ptrs), text "ptrs", - int (sizeSS itbls), text "itbls"] - - --- these need a proper home -type ItblEnv = FiniteMap Name (Ptr StgInfoTable) -type ClosureEnv = FiniteMap Name HValue -data HValue = HValue -- dummy type, actually a pointer to some Real Code. - --- remove all entries for a given set of modules from the environment -filterNameMap :: [ModuleName] -> FiniteMap Name a -> FiniteMap Name a -filterNameMap mods env - = filterFM (\n _ -> moduleName (nameModule n) `notElem` mods) env -\end{code} + let invented_name = mkSystemVarName (mkPseudoUniqueE 0) FSLIT("ExprTopLevel") + invented_id = mkLocalId invented_name (panic "invented_id's type") + + (BcM_State final_ctr mallocd, proto_bco) + <- runBc (schemeTopBind (invented_id, freeVars expr)) -%************************************************************************ -%* * -\subsection{Bytecodes, and Outputery.} -%* * -%************************************************************************ + when (notNull mallocd) + (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?") -\begin{code} + dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" (ppr proto_bco) -type LocalLabel = Int - -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 Int - -- push this int/float/double, NO TAG, on the stack - -- Int is # of words to copy from literal pool - | 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 - -- after assembly, the DataCon is an index into the - -- itbl array - -- 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 - - -- The Int value is a constructor number and therefore - -- stored in the insn stream rather than as an offset into - -- the literal pool. - | TESTLT_P Int LocalLabel - | TESTEQ_P Int LocalLabel - - | CASEFAIL - -- To Infinity And Beyond - | ENTER - | RETURN PrimRep - -- 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 (PUSH_UBX lit nw) = text "PUSH_UBX" <+> parens (int nw) <+> ppr lit - ppr (PUSH_TAG n) = text "PUSH_TAG" <+> int n - ppr (SLIDE n d) = text "SLIDE " <+> int n <+> int d - ppr (ALLOC sz) = text "ALLOC " <+> int sz - ppr (MKAP offset sz) = text "MKAP " <+> int sz <+> text "words," - <+> int offset <+> text "stkoff" - ppr (UNPACK sz) = text "UNPACK " <+> int sz - ppr (UPK_TAG n m k) = text "UPK_TAG " <+> int n <> text "words" - <+> int m <> text "conoff" - <+> int k <> text "stkoff" - 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 pk) = text "RETURN " <+> ppr pk - -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) -\end{code} + assembleBCO proto_bco -%************************************************************************ -%* * -\subsection{Compilation schema for the bytecode generator.} -%* * -%************************************************************************ -\begin{code} +-- ----------------------------------------------------------------------------- +-- Compilation schema for the bytecode generator 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)) - -nameOfProtoBCO (ProtoBCO nm insns origin) = nm - - 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 <+> ppr (idCgRep 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 (id {-peep-} (fromOL instrs_ordlist)) origin +mkProtoBCO + :: name + -> BCInstrList + -> Either [AnnAlt Id VarSet] (AnnExpr Id VarSet) + -> Int + -> Int + -> [StgWord] + -> Bool -- True <=> is a return point, rather than a function + -> [Ptr ()] + -> ProtoBCO name +mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap + is_ret mallocd_blocks + = ProtoBCO { + protoBCOName = nm, + protoBCOInstrs = maybe_with_stack_check, + protoBCOBitmap = bitmap, + protoBCOBitmapSize = bitmap_size, + protoBCOArity = arity, + protoBCOExpr = origin, + protoBCOPtrs = 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 + | is_ret = peep_d + -- don't do stack checks at return points; + -- everything is aggregated up to the top BCO + -- (which must be a function) + | 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) + + -- 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 [] = [] +argBits :: [CgRep] -> [Bool] +argBits [] = [] +argBits (rep : args) + | isFollowableArg rep = False : argBits args + | otherwise = take (cgRepSizeW rep) (repeat True) ++ argBits args + +-- ----------------------------------------------------------------------------- +-- schemeTopBind + +-- Compile code for the right-hand side of a top-level binding --- Compile code for the right hand side of a let binding. +schemeTopBind :: (Id, AnnExpr Id VarSet) -> BcM (ProtoBCO Name) + + +schemeTopBind (id, rhs) + | Just data_con <- isDataConWorkId_maybe id, + isNullaryRepDataCon data_con + = -- Special case for the worker of a nullary data con. + -- It'll look like this: Nil = /\a -> Nil a + -- If we feed it into schemeR, we'll get + -- Nil = Nil + -- because mkConAppCode treats nullary constructor applications + -- by just re-using the single top-level definition. So + -- for the worker itself, we must allocate it directly. + emitBc (mkProtoBCO (getName id) (toOL [PACK data_con 0, ENTER]) + (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-}) + + | otherwise + = schemeR [{- No free variables -}] (id, rhs) + +-- ----------------------------------------------------------------------------- +-- schemeR + +-- Compile code for a right-hand side, to give a BCO that, +-- when executed with the free variables and arguments on top of the stack, +-- will return with a pointer to the result on top of the stack, after +-- removing the free variables and arguments. +-- -- 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) +-- resulting BCO a name. + +schemeR :: [Id] -- Free vars of the RHS, ordered as they + -- will appear in the thunk. Empty for + -- top-level things, which have no free vars. + -> (Id, AnnExpr Id VarSet) + -> BcM (ProtoBCO Name) +schemeR fvs (nm, rhs) {- | trace (showSDoc ( (char ' ' @@ -362,141 +250,469 @@ schemeR (nm, rhs) $$ char ' ' ))) False = undefined --} | otherwise - = schemeR_wrk rhs nm (collect [] rhs) +-} + = schemeR_wrk fvs nm rhs (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) -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 fvs nm original_body (args, body) + = let + all_args = reverse args ++ fvs + arity = length all_args + -- all_args are the args in reverse order. We're compiling a function + -- \fv1..fvn x1..xn -> e + -- i.e. the fvs come first -schemeR_wrk original_body nm (args, body) - = let fvs = filter (not.isTyVar) (varSetElems (fst original_body)) - all_args = fvs ++ reverse args - szsw_args = map taggedIdSizeW all_args + szsw_args = map idSizeW 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) + + -- make the arg bitmap + bits = argBits (reverse (map idCgRep all_args)) + bitmap_size = length bits + bitmap = mkBitmap bits 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) body_code (Right original_body) + arity bitmap_size bitmap False{-not alts-}) --- 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. -mkStackOffsets :: Int -> [Int] -> [Int] -mkStackOffsets original_depth szsw - = map (subtract 1) (tail (scanl (+) original_depth szsw)) + +fvsToEnv :: BCEnv -> VarSet -> [Id] +-- Takes the free variables of a right-hand side, and +-- delivers an ordered list of the local variables that will +-- be captured in the thunk for the RHS +-- The BCEnv argument tells which variables are in the local +-- environment: these are the ones that should be captured +-- +-- The code that constructs the thunk, and the code that executes +-- it, have to agree about this layout +fvsToEnv p fvs = [v | v <- varSetElems fvs, + isId v, -- Could be a type variable + v `elemFM` p] + +-- ----------------------------------------------------------------------------- +-- schemeE -- Compile code to apply the given expression to the remaining args -- on the stack, returning a HNF. -schemeE :: Int -> Sequel -> BCEnv -> AnnExpr Id VarSet -> BcM BCInstrList +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)) -schemeE d s p e@(fvs, AnnVar v) - | isFollowableRep v_rep - = returnBc (schemeT (should_args_be_tagged e) d s 0 p (fvs, AnnVar v)) +schemeE d s p e@(AnnApp f a) + = schemeT d s p e + +schemeE d s p e@(AnnVar v) + | not (isUnLiftedType v_type) + = -- Lifted-type thing; push it in the normal way + schemeT d s p e + | 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 v_rep) -- go + = -- Returning an unlifted value. + -- Heave it on the stack, SLIDE, and RETURN. + pushAtom d p (AnnVar v) `thenBc` \ (push, szw) -> + returnBc (push -- value onto stack + `appOL` mkSLIDE szw (d-s) -- clear to sequel + `snocOL` RETURN_UBX v_rep) -- go where - v_rep = typePrimRep (idType v) + v_type = idType v + v_rep = typeCgRep v_type -schemeE d s p (fvs, AnnLit literal) - = let (push, szw) = pushAtom True d p (AnnLit literal) - l_rep = literalPrimRep literal +schemeE d s p (AnnLit literal) + = pushAtom d p (AnnLit literal) `thenBc` \ (push, szw) -> + let l_rep = typeCgRep (literalType literal) in returnBc (push -- value onto stack - `snocOL` SLIDE szw (d-s) -- clear to sequel - `snocOL` RETURN l_rep) -- go - -schemeE d s p (fvs, AnnLet binds b) + `appOL` mkSLIDE szw (d-s) -- clear to sequel + `snocOL` RETURN_UBX l_rep) -- go + + +schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body)) + | (AnnVar v, args_r_to_l) <- splitApp rhs, + Just data_con <- isDataConWorkId_maybe v, + dataConRepArity data_con == length args_r_to_l + = -- Special case for a non-recursive let whose RHS is a + -- saturatred constructor application. + -- Just allocate the constructor and carry on + mkConAppCode d s p data_con args_r_to_l `thenBc` \ alloc_code -> + schemeE (d+1) s (addToFM p x d) body `thenBc` \ body_code -> + returnBc (alloc_code `appOL` body_code) + +-- General case for let. Generates correct, if inefficient, code in +-- all situations. +schemeE d s p (AnnLet binds (_,body)) = 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 + n_binds = length xs + + fvss = map (fvsToEnv p' . fst) rhss - -- Sizes of tagged free vars, + 1 for the fn - sizes = map (\rhs_fvs -> 1 + sum (map taggedIdSizeW rhs_fvs)) fvss + -- Sizes of free vars + sizes = map (\rhs_fvs -> sum (map idSizeW rhs_fvs)) fvss + + -- the arity of each rhs + arities = map (length . fst . collect []) rhss -- This p', d' defn is safe because all the items being pushed -- are ptrs, so all have size 1. d' and p' reflect the stack -- after the closures have been allocated in the heap (but not -- filled in), and pointers to them parked on the stack. - p' = addListToFM p (zipE xs (mkStackOffsets d (nOfThem n 1))) - d' = d + n - - infos = zipE4 fvss sizes xs [n, n-1 .. 1] + p' = addListToFM p (zipE xs (mkStackOffsets d (nOfThem n_binds 1))) + d' = d + n_binds zipE = zipEqual "schemeE" - zipE4 = zipWith4Equal "schemeE" (\a b c d -> (a,b,c,d)) -- ToDo: don't build thunks for things with no free variables - buildThunk dd ([], size, id, off) - = PUSH_G (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) - - thunkCode = concatOL (map (buildThunk d') infos) - allocCode = toOL (map ALLOC sizes) - in - schemeE d' s p' b `thenBc` \ bodyCode -> - mapBc schemeR (zip xs rhss) `thenBc_` - returnBc (allocCode `appOL` thunkCode `appOL` bodyCode) + build_thunk dd [] size bco off + = returnBc (PUSH_BCO bco + `consOL` unitOL (MKAP (off+size) size)) + build_thunk dd (fv:fvs) size bco off = do + (push_code, pushed_szw) <- pushAtom dd p' (AnnVar fv) + more_push_code <- build_thunk (dd+pushed_szw) fvs size bco off + returnBc (push_code `appOL` more_push_code) + + alloc_code = toOL (zipWith mkAlloc sizes arities) + where mkAlloc sz 0 = ALLOC_AP sz + mkAlloc sz arity = ALLOC_PAP arity sz + + compile_bind d' fvs x rhs size off = do + bco <- schemeR fvs (x,rhs) + build_thunk d' fvs size bco off + + compile_binds = + [ compile_bind d' fvs x rhs size n + | (fvs, x, rhs, size, n) <- + zip5 fvss xs rhss sizes [n_binds, n_binds-1 .. 1] + ] + in do + body_code <- schemeE d' s p' body + thunk_codes <- sequence compile_binds + returnBc (alloc_code `appOL` concatOL thunk_codes `appOL` body_code) + + + +schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)]) + | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind1) + -- Convert + -- case .... of x { (# VoidArg'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 (# VoidArg, a #)" $ + doCase d s p scrut bind2 [(DEFAULT, [], rhs)] True{-unboxed tuple-} + + | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind2) + = --trace "automagic mashing of case alts (# a, VoidArg #)" $ + doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-} + +schemeE d s p (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 #)" $ + doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-} + +schemeE d s p (AnnCase scrut bndr _ alts) + = doCase d s p scrut bndr alts False{-not an unboxed tuple-} + +schemeE d s p (AnnNote note (_, body)) + = schemeE d s p body + +schemeE d s p other + = pprPanic "ByteCodeGen.schemeE: unhandled case" + (pprCoreExpr (deAnnotate' other)) -schemeE d s p (fvs, AnnCase scrut bndr alts) - = let +-- 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 "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. +-- +-- 1. The fn denotes a ccall. Defer to generateCCall. +-- +-- 2. (Another nasty hack). Spot (# a::VoidArg, b #) and treat +-- it simply as b -- since the representations are identical +-- (the VoidArg takes up zero stack space). Also, spot +-- (# b #) and treat it as b. +-- +-- 3. Application of a 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 +-- right to left, SLIDE and ENTER. + +schemeT :: Int -- Stack depth + -> Sequel -- Sequel depth + -> BCEnv -- stack env + -> 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 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 + | Just (CCall ccall_spec) <- isFCallId_maybe fn + = generateCCall d s p ccall_spec fn args_r_to_l + + -- Case 2: Constructor application + | Just con <- maybe_saturated_dcon, + isUnboxedTupleCon con + = case args_r_to_l of + [arg1,arg2] | isVoidArgAtom arg1 -> + unboxedTupleReturn d s p arg2 + [arg1,arg2] | isVoidArgAtom arg2 -> + unboxedTupleReturn d s p arg1 + _other -> unboxedTupleException + + -- Case 3: Ordinary data constructor + | Just con <- maybe_saturated_dcon + = mkConAppCode d s p con args_r_to_l `thenBc` \ alloc_con -> + returnBc (alloc_con `appOL` + mkSLIDE 1 (d - s) `snocOL` + ENTER) + + -- Case 4: Tail call of function + | otherwise + = doTailCall d s p fn args_r_to_l + + where + -- Detect and extract relevant info for the tagToEnum kludge. + maybe_is_tagToEnum_call + = let extract_constr_Names ty + | Just (tyc, []) <- splitTyConApp_maybe (repType ty), + isDataTyCon tyc + = map (getName . dataConWorkId) (tyConDataCons tyc) + -- NOTE: use the worker name, not the source name of + -- the DataCon. See DataCon.lhs for details. + | otherwise + = 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 + -- The function will necessarily be a variable, + -- because we are compiling a tail call + (AnnVar fn, args_r_to_l) = splitApp app + + -- Only consider this to be a constructor application iff it is + -- saturated. Otherwise, we'll call the constructor wrapper. + n_args = length args_r_to_l + maybe_saturated_dcon + = case isDataConWorkId_maybe fn of + Just con | dataConRepArity con == n_args -> Just con + _ -> Nothing + +-- ----------------------------------------------------------------------------- +-- Generate code to build a constructor application, +-- leaving it on top of the stack + +mkConAppCode :: Int -> Sequel -> BCEnv + -> DataCon -- The data constructor + -> [AnnExpr' Id VarSet] -- Args, in *reverse* order + -> BcM BCInstrList + +mkConAppCode orig_d s p con [] -- Nullary constructor + = ASSERT( isNullaryRepDataCon con ) + returnBc (unitOL (PUSH_G (getName (dataConWorkId con)))) + -- Instead of doing a PACK, which would allocate a fresh + -- copy of this constructor, use the single shared version. + +mkConAppCode orig_d s p con args_r_to_l + = ASSERT( dataConRepArity con == length args_r_to_l ) + do_pushery orig_d (non_ptr_args ++ ptr_args) + where + -- The args are already in reverse order, which is the way PACK + -- expects them to be. We must push the non-ptrs after the ptrs. + (ptr_args, non_ptr_args) = partition isPtrAtom args_r_to_l + + do_pushery d (arg:args) + = pushAtom 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 [] + = returnBc (unitOL (PACK con n_arg_words)) + where + n_arg_words = d - orig_d + + +-- ----------------------------------------------------------------------------- +-- Returning an unboxed tuple with one non-void component (the only +-- case we can handle). +-- +-- Remember, we don't want to *evaluate* the component that is being +-- returned, even if it is a pointed type. We always just return. + +unboxedTupleReturn + :: Int -> Sequel -> BCEnv + -> AnnExpr' Id VarSet -> BcM BCInstrList +unboxedTupleReturn d s p arg = do + (push, sz) <- pushAtom d p arg + returnBc (push `appOL` + mkSLIDE sz (d-s) `snocOL` + RETURN_UBX (atomRep arg)) + +-- ----------------------------------------------------------------------------- +-- Generate code for a tail-call + +doTailCall + :: Int -> Sequel -> BCEnv + -> Id -> [AnnExpr' Id VarSet] + -> BcM BCInstrList +doTailCall init_d s p fn args + = do_pushes init_d args (map atomRep args) + where + do_pushes d [] reps = do + ASSERT( null reps ) return () + (push_fn, sz) <- pushAtom d p (AnnVar fn) + ASSERT( sz == 1 ) return () + returnBc (push_fn `appOL` ( + mkSLIDE ((d-init_d) + 1) (init_d - s) `appOL` + unitOL ENTER)) + do_pushes d args reps = do + let (push_apply, n, rest_of_reps) = findPushSeq reps + (these_args, rest_of_args) = splitAt n args + (next_d, push_code) <- push_seq d these_args + instrs <- do_pushes (next_d + 1) rest_of_args rest_of_reps + -- ^^^ for the PUSH_APPLY_ instruction + returnBc (push_code `appOL` (push_apply `consOL` instrs)) + + push_seq d [] = return (d, nilOL) + push_seq d (arg:args) = do + (push_code, sz) <- pushAtom d p arg + (final_d, more_push_code) <- push_seq (d+sz) args + return (final_d, push_code `appOL` more_push_code) + +-- v. similar to CgStackery.findMatch, ToDo: merge +findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: rest) + = (PUSH_APPLY_PPPPPP, 6, rest) +findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: rest) + = (PUSH_APPLY_PPPPP, 5, rest) +findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: rest) + = (PUSH_APPLY_PPPP, 4, rest) +findPushSeq (PtrArg: PtrArg: PtrArg: rest) + = (PUSH_APPLY_PPP, 3, rest) +findPushSeq (PtrArg: PtrArg: rest) + = (PUSH_APPLY_PP, 2, rest) +findPushSeq (PtrArg: rest) + = (PUSH_APPLY_P, 1, rest) +findPushSeq (VoidArg: rest) + = (PUSH_APPLY_V, 1, rest) +findPushSeq (NonPtrArg: rest) + = (PUSH_APPLY_N, 1, rest) +findPushSeq (FloatArg: rest) + = (PUSH_APPLY_F, 1, rest) +findPushSeq (DoubleArg: rest) + = (PUSH_APPLY_D, 1, rest) +findPushSeq (LongArg: rest) + = (PUSH_APPLY_L, 1, rest) +findPushSeq _ + = panic "ByteCodeGen.findPushSeq" + +-- ----------------------------------------------------------------------------- +-- Case expressions + +doCase :: Int -> Sequel -> BCEnv + -> AnnExpr Id VarSet -> Id -> [AnnAlt Id VarSet] + -> Bool -- True <=> is an unboxed tuple case, don't enter the result + -> BcM BCInstrList +doCase d s p (_,scrut) + bndr alts is_unboxed_tuple + = let -- Top of stack is the return itbl, as usual. -- underneath it is the pointer to the alt_code BCO. -- When an alt is entered, it assumes the returned value is -- on top of the itbl. ret_frame_sizeW = 2 - -- Env and depth in which to compile the alts, not including + -- An unlifted value gets an extra info table pushed on top + -- when it is returned. + unlifted_itbl_sizeW | isAlgCase = 0 + | otherwise = 1 + + -- depth of stack after the return value has been pushed + d_bndr = d + ret_frame_sizeW + idSizeW bndr + + -- depth of stack after the extra info table for an unboxed return + -- has been pushed, if any. This is the stack depth at the + -- continuation. + d_alts = d_bndr + unlifted_itbl_sizeW + + -- Env in which to compile the alts, not including -- any vars bound by the alts themselves - d' = d + ret_frame_sizeW + taggedIdSizeW bndr - p' = addToFM p bndr (d' - 1) + p_alts = addToFM p bndr (d_bndr - 1) - scrut_primrep = typePrimRep (idType bndr) - isAlgCase - = case scrut_primrep of - IntRep -> False ; FloatRep -> False ; DoubleRep -> False - PtrRep -> True - other -> pprPanic "ByteCodeGen.schemeE" (ppr other) + bndr_ty = idType bndr + isAlgCase = not (isUnLiftedType bndr_ty) && not is_unboxed_tuple -- 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) - | 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 - fIRST_TAG) + codeALt alt@(DEFAULT, _, (_,rhs)) + = schemeE d_alts s p_alts rhs `thenBc` \ rhs_code -> + returnBc (NoDiscr, rhs_code) + codeAlt alt@(discr, bndrs, (_,rhs)) + -- primitive or nullary constructor alt: no need to UNPACK + | null real_bndrs = do + rhs_code <- schemeE d_alts s p_alts rhs + returnBc (my_discr alt, rhs_code) + -- algebraic alt with some binders + | ASSERT(isAlgCase) otherwise = + let + (ptrs,nptrs) = partition (isFollowableArg.idCgRep) real_bndrs + ptr_sizes = map idSizeW ptrs + nptrs_sizes = map idSizeW nptrs + bind_sizes = ptr_sizes ++ nptrs_sizes + size = sum ptr_sizes + sum nptrs_sizes + -- the UNPACK instruction unpacks in reverse order... + p' = addListToFM p_alts + (zip (reverse (ptrs ++ nptrs)) + (mkStackOffsets d_alts (reverse bind_sizes))) + in do + rhs_code <- schemeE (d_alts+size) s p' rhs + return (my_discr alt, unitOL (UNPACK size) `appOL` rhs_code) + where + real_bndrs = filter (not.isTyVar) bndrs + + + my_discr (DEFAULT, binds, rhs) = NoDiscr {-shouldn't really happen-} + 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 (ord i) + _ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l) maybe_ncons | not isAlgCase = Nothing @@ -505,207 +721,406 @@ schemeE d s p (fvs, AnnCase scrut bndr alts) [] -> Nothing (dc:_) -> Just (tyConFamilySize (dataConTyCon dc)) - in - mapBc codeAlt alts `thenBc` \ alt_stuff -> - mkMultiBranch maybe_ncons alt_stuff `thenBc` \ alt_final -> + -- the bitmap is relative to stack depth d, i.e. before the + -- BCO, info table and return value are pushed on. + -- This bit of code is v. similar to buildLivenessMask in CgBindery, + -- except that here we build the bitmap from the known bindings of + -- things that are pointers, whereas in CgBindery the code builds the + -- bitmap from the free slots and unboxed bindings. + -- (ToDo: merge?) + bitmap = intsToReverseBitmap d{-size-} (sortLe (<=) rel_slots) + where + binds = fmToList p + rel_slots = concat (map spread binds) + spread (id, offset) + | isFollowableArg (idCgRep id) = [ rel_offset ] + | otherwise = [] + where rel_offset = d - offset - 1 + + in do + alt_stuff <- mapM codeAlt alts + alt_final <- mkMultiBranch maybe_ncons alt_stuff let - alt_final_ac = ARGCHECK (taggedIdSizeW bndr) `consOL` alt_final alt_bco_name = getName bndr - alt_bco = mkProtoBCO alt_bco_name alt_final_ac (Left alts) + alt_bco = mkProtoBCO alt_bco_name alt_final (Left alts) + 0{-no arity-} d{-bitmap size-} bitmap True{-is alts-} + -- in +-- trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++ +-- "\n bitmap = " ++ show bitmap) $ do + scrut_code <- schemeE (d + ret_frame_sizeW) (d + ret_frame_sizeW) p scrut + alt_bco' <- emitBc alt_bco + let push_alts + | isAlgCase = PUSH_ALTS alt_bco' + | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeCgRep bndr_ty) + returnBc (push_alts `consOL` scrut_code) + + +-- ----------------------------------------------------------------------------- +-- Deal with a CCall. + +-- Taggedly push the args onto the stack R->L, +-- deferencing ForeignObj#s and 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_sizeW = cgRepSizeW NonPtrArg + + -- 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 + -- CgRep 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 == arrayPrimTyCon || t == mutableArrayPrimTyCon + -> pargs (d + addr_sizeW) az `thenBc` \ rest -> + parg_ArrayishRep arrPtrsHdrSize d p a + `thenBc` \ code -> + returnBc ((code,NonPtrArg):rest) + + | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon + -> pargs (d + addr_sizeW) az `thenBc` \ rest -> + parg_ArrayishRep arrWordsHdrSize d p a + `thenBc` \ code -> + returnBc ((code,NonPtrArg):rest) + + -- Default case: push taggedly, but otherwise intact. + other + -> pushAtom 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 hdrSize d p a + = pushAtom d p a `thenBc` \ (push_fo, _) -> + -- The ptr points at the header. Advance it over the + -- header and then pretend this is an Addr#. + returnBc (push_fo `snocOL` SWIZZLE 0 hdrSize) + + 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 cgRepSizeW a_reps_pushed_r_to_l) + a_reps_pushed_RAW + | null a_reps_pushed_r_to_l || head a_reps_pushed_r_to_l /= VoidArg + = 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, VoidArg) + 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 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. + + 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) + 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_sizeW], + d_after_args + addr_sizeW) + | otherwise -- is already on the stack + = (nilOL, d_after_args) + + -- Push the return placeholder. For a call returning nothing, + -- this is a VoidArg (tag). + r_sizeW = cgRepSizeW r_rep + d_after_r = d_after_Addr + r_sizeW + r_lit = mkDummyLiteral r_rep + push_r = (if returns_void + then nilOL + else unitOL (PUSH_UBX (Left r_lit) r_sizeW)) + + -- generate the marshalling code we're going to call + r_offW = 0 + addr_offW = r_sizeW + arg1_offW = r_sizeW + addr_sizeW + args_offW = map (arg1_offW +) + (init (scanl (+) 0 (map cgRepSizeW 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 + -- Offset of the next stack frame down the stack. The CCALL + -- instruction needs to describe the chunk of stack containing + -- the ccall args to the GC, so it needs to know how large it + -- is. See comment in Interpreter.c with the CCALL instruction. + stk_offset = d_after_r - s + + -- do the call + do_call = unitOL (CCALL stk_offset (castPtr addr_of_marshaller)) + -- slide and return + wrapup = mkSLIDE r_sizeW (d_after_r - r_sizeW - s) + `snocOL` RETURN_UBX r_rep in - schemeE (d + ret_frame_sizeW) - (d + ret_frame_sizeW) p scrut `thenBc` \ scrut_code -> + --trace (show (arg1_offW, args_offW , (map cgRepSizeW 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 :: CgRep -> Literal +mkDummyLiteral pr + = case pr of + NonPtrArg -> MachWord 0 + DoubleArg -> MachDouble 0 + FloatArg -> MachFloat 0 + _ -> moan64 "mkDummyLiteral" (ppr pr) + + +-- Convert (eg) +-- 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 VoidArg'd. +-- +-- 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 CgRep +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 typeCgRep tys) + Nothing -> blargh + ok = ( ( r_reps `lengthIs` 2 && VoidArg == head r_reps) + || r_reps == [VoidArg] ) + && isUnboxedTupleTyCon r_tycon + && case maybe_r_rep_to_go of + Nothing -> True + Just r_rep -> r_rep /= PtrArg + -- 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 + +-- 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( notNull 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 name_for_n, + JMP l_exit] - emitBc alt_bco `thenBc_` - returnBc (PUSH_AS alt_bco_name scrut_primrep `consOL` scrut_code) +-- ----------------------------------------------------------------------------- +-- pushAtom -schemeE d s p (fvs, AnnNote note body) - = schemeE d s p body +-- Push an atom onto the stack, returning suitable code & number of +-- stack words used. +-- +-- The env p must map each variable to the highest- numbered stack +-- slot for it. For example, if the stack has depth 4 and we +-- tagged-ly push (v :: Int#) on it, the value will be in stack[4], +-- the tag in stack[5], the stack will have depth 6, and p must map v +-- to 5 and not to 4. Stack locations are numbered from zero, so a +-- depth 6 stack has valid words 0 .. 5. -schemeE d s p other - = pprPanic "ByteCodeGen.schemeE: unhandled case" - (pprCoreExpr (deAnnotate other)) +pushAtom :: Int -> BCEnv -> AnnExpr' Id VarSet -> BcM (BCInstrList, Int) +pushAtom d p (AnnApp f (_, AnnType _)) + = pushAtom d p (snd f) --- Compile code to do a tail call. Doesn't need to be monadic. -schemeT :: Bool -- do tagging? - -> 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) - --trace ("schemeT: d = " ++ show d ++ ", s = " ++ show s ++ ", naw = " ++ show narg_words) ( - PACK con narg_words `consOL` (mkSLIDE 1 (d - narg_words - s) `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 - | otherwise - = case r of - IntRep -> approved - FloatRep -> approved - DoubleRep -> approved - 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 +pushAtom d p (AnnNote note e) + = pushAtom d p (snd e) --- Push an atom onto the stack, returning suitable code & number of --- stack words used. Pushes it either tagged or untagged, since --- pushAtom is used to set up the stack prior to copying into the --- heap for both APs (requiring tags) and constructors (which don't). --- --- NB this means NO GC between pushing atoms for a constructor and --- copying them into the heap. It probably also means that --- tail calls MUST be of the form atom{atom ... atom} since if the --- expression head was allowed to be arbitrary, there could be GC --- in between pushing the arg atoms and completing the head. --- (not sure; perhaps the allocate/doYouWantToGC interface means this --- isn't a problem; but only if arbitrary graph construction for the --- head doesn't leave this BCO, since GC might happen at the start of --- each BCO (we consult doYouWantToGC there). --- --- Blargh. JRS 001206 --- --- NB (further) that the env p must map each variable to the highest- --- numbered stack slot for it. For example, if the stack has depth 4 --- and we tagged-ly push (v :: Int#) on it, the value will be in stack[4], --- the tag in stack[5], the stack will have depth 6, and p must map v to --- 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" ++ - 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) - - nm = case isDataConId_maybe v of - Just c -> getName c - Nothing -> getName v - - sz_t = taggedIdSizeW v - sz_u = untaggedIdSizeW v - nwords = if tagged then sz_t else sz_u - in - --trace str' - result +pushAtom d p (AnnLam x e) + | isTyVar x + = pushAtom d p (snd e) + +pushAtom d p (AnnVar v) + + | idCgRep v == VoidArg + = returnBc (nilOL, 0) + + | isFCallId v + = pprPanic "pushAtom: shouldn't get an FCallId here" (ppr v) + + | Just primop <- isPrimOpId_maybe v + = returnBc (unitOL (PUSH_PRIMOP primop), 1) -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) + | Just d_v <- lookupBCEnv_maybe p v -- v is a local variable + = returnBc (toOL (nOfThem sz (PUSH_L (d-d_v+sz-2))), sz) + -- d - d_v the number of words between the TOS + -- and the 1st slot of the object + -- + -- d - d_v - 1 the offset from the TOS of the 1st slot + -- + -- d - d_v - 1 + sz - 1 the offset from the TOS of the last slot + -- of the object. + -- + -- Having found the last slot, we proceed to copy the right number of + -- slots on to the top of the stack. -pushAtom False d p (AnnLit lit) + | otherwise -- v must be a global variable + = ASSERT(sz == 1) + returnBc (unitOL (PUSH_G (getName v)), sz) + + where + sz = idSizeW v + + +pushAtom d p (AnnLit lit) = case lit of - MachInt i -> code IntRep - MachFloat r -> code FloatRep - MachDouble r -> code DoubleRep - MachChar c -> code CharRep - MachStr s -> pushStr s + MachLabel fs _ -> code NonPtrArg + MachWord w -> code NonPtrArg + MachInt i -> code PtrArg + MachFloat r -> code FloatArg + MachDouble r -> code DoubleArg + MachChar c -> code NonPtrArg + MachStr s -> pushStr s where code rep - = let size_host_words = untaggedSizeW rep - in (unitOL (PUSH_UBX lit size_host_words), size_host_words) + = let size_host_words = cgRepSizeW rep + 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 -- a string literal is Addr#. So, copy the string - -- into C land and introduce a memory leak - -- at the same time. + -- into C land and remember the pointer so we can + -- free it later. let n = I# l -- CAREFUL! Chars are 32 bits in ghc 4.09+ - in unsafePerformIO ( - do a@(Ptr addr) <- mallocBytes (n+1) - strncpy a ba (fromIntegral n) - writeCharOffAddr addr n '\0' - return addr + 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) -pushAtom tagged d p (AnnApp f (_, AnnType _)) - = pushAtom tagged d p (snd f) - -pushAtom tagged d p other +pushAtom d p other = pprPanic "ByteCodeGen.pushAtom" (pprCoreExpr (deAnnotate (undefined, other))) -foreign import "strncpy" strncpy :: Ptr a -> ByteArray# -> CInt -> IO () +foreign import ccall unsafe "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. -- What a load of hassle! + mkMultiBranch :: Maybe Int -- # datacons in tycon, if alg alt -- a hint; generates better code -- Nothing is always safe @@ -713,7 +1128,7 @@ mkMultiBranch :: Maybe Int -- # datacons in tycon, if alg alt -> BcM BCInstrList mkMultiBranch maybe_ncons raw_ways = let d_way = filter (isNoDiscr.fst) raw_ways - notd_ways = naturalMergeSortLe + notd_ways = sortLe (\w1 w2 -> leAlt (fst w1) (fst w2)) (filter (not.isNoDiscr.fst) raw_ways) @@ -809,15 +1224,9 @@ mkMultiBranch maybe_ncons raw_ways in mkTree notd_ways init_lo init_hi -\end{code} -%************************************************************************ -%* * -\subsection{Supporting junk for the compilation schemes} -%* * -%************************************************************************ - -\begin{code} +-- ----------------------------------------------------------------------------- +-- Supporting junk for the compilation schemes -- Describes case alts data Discr @@ -835,704 +1244,115 @@ instance Outputable Discr where ppr NoDiscr = text "DEF" --- 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_maybe :: BCEnv -> Id -> Maybe Int lookupBCEnv_maybe = lookupFM +idSizeW :: Id -> Int +idSizeW id = cgRepSizeW (typeCgRep (idType id)) --- 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.")) -\end{code} - -%************************************************************************ -%* * -\subsection{The bytecode generator's monad} -%* * -%************************************************************************ - -\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) - -runBc :: BcM_State -> BcM () -> BcM_State -runBc init_st m = case m init_st of { (r,st) -> st } - -thenBc :: BcM a -> (a -> BcM b) -> BcM b -thenBc expr cont st - = case expr st of { (result, st') -> cont result st' } - -thenBc_ :: BcM a -> BcM b -> BcM b -thenBc_ expr cont st - = case expr st of { (result, st') -> cont st' } -returnBc :: a -> BcM a -returnBc result st = (result, st) +mkSLIDE n d = if d == 0 then nilOL else unitOL (SLIDE n d) +bind x f = f x -mapBc :: (a -> BcM b) -> [a] -> BcM [b] -mapBc f [] = returnBc [] -mapBc f (x:xs) - = f x `thenBc` \ r -> - mapBc f xs `thenBc` \ rs -> - returnBc (r:rs) +splitApp :: AnnExpr' id ann -> (AnnExpr' id ann, [AnnExpr' id ann]) + -- The arguments are returned in *right-to-left* order +splitApp (AnnApp (_,f) (_,a)) + | isTypeAtom a = splitApp f + | otherwise = case splitApp f of + (f', as) -> (f', a:as) +splitApp (AnnNote n (_,e)) = splitApp e +splitApp e = (e, []) -emitBc :: ProtoBCO Name -> BcM () -emitBc bco st - = ((), st{bcos = bco : bcos st}) -getLabelBc :: BcM Int -getLabelBc st - = (nextlabel st, st{nextlabel = 1 + nextlabel st}) - -\end{code} +isTypeAtom :: AnnExpr' id ann -> Bool +isTypeAtom (AnnType _) = True +isTypeAtom _ = False -%************************************************************************ -%* * -\subsection{The bytecode assembler} -%* * -%************************************************************************ +isVoidArgAtom :: AnnExpr' id ann -> Bool +isVoidArgAtom (AnnVar v) = typeCgRep (idType v) == VoidArg +isVoidArgAtom (AnnNote n (_,e)) = isVoidArgAtom e +isVoidArgAtom _ = False -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. +atomRep :: AnnExpr' Id ann -> CgRep +atomRep (AnnVar v) = typeCgRep (idType v) +atomRep (AnnLit l) = typeCgRep (literalType 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))) -\begin{code} --- Top level assembler fn. -assembleBCO :: ProtoBCO Name -> IO UnlinkedBCO - -assembleBCO (ProtoBCO nm instrs origin) - = let - -- pass 1: collect up the offsets of the local labels. - -- Remember that the first insn starts at offset 1 since offset 0 - -- (eventually) will hold the total # of insns. - label_env = mkLabelEnv emptyFM 1 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 + instrSize16s i) is - - findLabel lab - = case lookupFM label_env lab of - Just bco_offset -> bco_offset - Nothing -> pprPanic "assembleBCO.findLabel" (int lab) - in - do -- pass 2: generate the instruction, ptr and nonptr bits - insns <- return emptySS :: IO (SizedSeq Word16) - lits <- return emptySS :: IO (SizedSeq Word) - ptrs <- return emptySS :: IO (SizedSeq Name) - itbls <- return emptySS :: IO (SizedSeq Name) - let init_asm_state = (insns,lits,ptrs,itbls) - (final_insns, final_lits, final_ptrs, final_itbls) - <- mkBits findLabel init_asm_state instrs - - return (UnlinkedBCO nm final_insns final_lits final_ptrs final_itbls) - --- instrs nonptrs ptrs itbls -type AsmState = (SizedSeq Word16, SizedSeq Word, SizedSeq Name, SizedSeq Name) - -data SizedSeq a = SizedSeq !Int [a] -emptySS = SizedSeq 0 [] -addToSS (SizedSeq n r_xs) x = return (SizedSeq (n+1) (x:r_xs)) -addListToSS (SizedSeq n r_xs) xs - = return (SizedSeq (n + length xs) (reverse xs ++ r_xs)) -sizeSS (SizedSeq n r_xs) = n -listFromSS (SizedSeq n r_xs) = return (reverse r_xs) - - --- 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 -> instr2 st i_PUSH_L o1 - PUSH_LL o1 o2 -> instr3 st i_PUSH_LL o1 o2 - PUSH_LLL o1 o2 o3 -> instr4 st i_PUSH_LLL o1 o2 o3 - PUSH_G nm -> do (p, st2) <- ptr st nm - instr2 st2 i_PUSH_G p - PUSH_AS nm pk -> do (p, st2) <- ptr st nm - (np, st3) <- ctoi_itbl st2 pk - instr3 st3 i_PUSH_AS p np - PUSH_UBX lit nws -> do (np, st2) <- literal st lit - instr3 st2 i_PUSH_UBX np nws - PUSH_TAG tag -> instr2 st i_PUSH_TAG tag - SLIDE n by -> instr3 st i_SLIDE n by - ALLOC n -> instr2 st i_ALLOC n - MKAP off sz -> instr3 st i_MKAP off sz - UNPACK n -> instr2 st i_UNPACK n - UPK_TAG n m k -> instr4 st i_UPK_TAG n m k - PACK dcon sz -> do (itbl_no,st2) <- itbl st dcon - instr3 st2 i_PACK itbl_no sz - LABEL lab -> return st - TESTLT_I i l -> do (np, st2) <- int st i - instr3 st2 i_TESTLT_I np (findLabel l) - TESTEQ_I i l -> do (np, st2) <- int st i - instr3 st2 i_TESTEQ_I np (findLabel l) - TESTLT_F f l -> do (np, st2) <- float st f - instr3 st2 i_TESTLT_F np (findLabel l) - TESTEQ_F f l -> do (np, st2) <- float st f - instr3 st2 i_TESTEQ_F np (findLabel l) - TESTLT_D d l -> do (np, st2) <- double st d - instr3 st2 i_TESTLT_D np (findLabel l) - TESTEQ_D d l -> do (np, st2) <- double st d - instr3 st2 i_TESTEQ_D np (findLabel l) - TESTLT_P i l -> instr3 st i_TESTLT_P i (findLabel l) - TESTEQ_P i l -> instr3 st i_TESTEQ_P i (findLabel l) - CASEFAIL -> instr1 st i_CASEFAIL - ENTER -> instr1 st i_ENTER - RETURN rep -> do (itbl_no,st2) <- itoc_itbl st rep - instr2 st2 i_RETURN itbl_no - - i2s :: Int -> Word16 - i2s = fromIntegral - - instr1 (st_i0,st_l0,st_p0,st_I0) i1 - = do st_i1 <- addToSS st_i0 (i2s i1) - return (st_i1,st_l0,st_p0,st_I0) - - instr2 (st_i0,st_l0,st_p0,st_I0) i1 i2 - = do st_i1 <- addToSS st_i0 (i2s i1) - st_i2 <- addToSS st_i1 (i2s i2) - return (st_i2,st_l0,st_p0,st_I0) - - instr3 (st_i0,st_l0,st_p0,st_I0) i1 i2 i3 - = do st_i1 <- addToSS st_i0 (i2s i1) - st_i2 <- addToSS st_i1 (i2s i2) - st_i3 <- addToSS st_i2 (i2s i3) - return (st_i3,st_l0,st_p0,st_I0) - - instr4 (st_i0,st_l0,st_p0,st_I0) i1 i2 i3 i4 - = do st_i1 <- addToSS st_i0 (i2s i1) - st_i2 <- addToSS st_i1 (i2s i2) - st_i3 <- addToSS st_i2 (i2s i3) - st_i4 <- addToSS st_i3 (i2s i4) - return (st_i4,st_l0,st_p0,st_I0) - - float (st_i0,st_l0,st_p0,st_I0) f - = do let ws = mkLitF f - st_l1 <- addListToSS st_l0 ws - return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0)) - - double (st_i0,st_l0,st_p0,st_I0) d - = do let ws = mkLitD d - st_l1 <- addListToSS st_l0 ws - return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0)) - - int (st_i0,st_l0,st_p0,st_I0) i - = do let ws = mkLitI i - st_l1 <- addListToSS st_l0 ws - return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0)) - - addr (st_i0,st_l0,st_p0,st_I0) a - = do let ws = mkLitA a - st_l1 <- addListToSS st_l0 ws - return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0)) - - ptr (st_i0,st_l0,st_p0,st_I0) p - = do st_p1 <- addToSS st_p0 p - return (sizeSS st_p0, (st_i0,st_l0,st_p1,st_I0)) - - itbl (st_i0,st_l0,st_p0,st_I0) dcon - = do st_I1 <- addToSS st_I0 (getName dcon) - return (sizeSS st_I0, (st_i0,st_l0,st_p0,st_I1)) - - literal st (MachInt j) = int st (fromIntegral j) - literal st (MachFloat r) = float st (fromRational r) - literal st (MachDouble r) = double st (fromRational r) - literal st (MachChar c) = int st c - - ctoi_itbl st pk - = addr st ret_itbl_addr - where - ret_itbl_addr = case pk of - PtrRep -> stg_ctoi_ret_R1_info - IntRep -> stg_ctoi_ret_R1_info - FloatRep -> stg_ctoi_ret_F1_info - DoubleRep -> stg_ctoi_ret_D1_info - _ -> pprPanic "mkBits.ctoi_itbl" (ppr pk) - where -- TEMP HACK - stg_ctoi_ret_F1_info = nullAddr - stg_ctoi_ret_D1_info = nullAddr - - itoc_itbl st pk - = addr st ret_itbl_addr - where - ret_itbl_addr = case pk of - IntRep -> stg_gc_unbx_r1_info - FloatRep -> stg_gc_f1_info - DoubleRep -> stg_gc_d1_info - -foreign label "stg_ctoi_ret_R1_info" stg_ctoi_ret_R1_info :: Addr ---foreign label "stg_ctoi_ret_F1_info" stg_ctoi_ret_F1_info :: Addr ---foreign label "stg_ctoi_ret_D1_info" stg_ctoi_ret_D1_info :: Addr - -foreign label "stg_gc_unbx_r1_info" stg_gc_unbx_r1_info :: Addr -foreign label "stg_gc_f1_info" stg_gc_f1_info :: Addr -foreign label "stg_gc_d1_info" stg_gc_d1_info :: Addr - --- The size in 16-bit entities of an instruction. -instrSize16s :: BCInstr -> Int -instrSize16s instr - = case instr of - ARGCHECK _ -> 2 - PUSH_L _ -> 2 - PUSH_LL _ _ -> 3 - PUSH_LLL _ _ _ -> 4 - PUSH_G _ -> 2 - PUSH_AS _ _ -> 3 - PUSH_UBX _ _ -> 3 - PUSH_TAG _ -> 2 - SLIDE _ _ -> 3 - ALLOC _ -> 2 - MKAP _ _ -> 3 - UNPACK _ -> 2 - UPK_TAG _ _ _ -> 4 - PACK _ _ -> 3 - LABEL _ -> 0 -- !! - TESTLT_I _ _ -> 3 - TESTEQ_I _ _ -> 3 - TESTLT_F _ _ -> 3 - TESTEQ_F _ _ -> 3 - TESTLT_D _ _ -> 3 - TESTEQ_D _ _ -> 3 - TESTLT_P _ _ -> 3 - TESTEQ_P _ _ -> 3 - CASEFAIL -> 1 - ENTER -> 1 - RETURN _ -> 2 - - --- Make lists of host-sized 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. -mkLitI :: Int -> [Word] -mkLitF :: Float -> [Word] -mkLitD :: Double -> [Word] -mkLitA :: Addr -> [Word] - -mkLitF f - = runST (do - arr <- newFloatArray ((0::Int),0) - writeFloatArray arr 0 f - f_arr <- castSTUArray arr - w0 <- readWordArray f_arr 0 - return [w0] - ) - -mkLitD d - | wORD_SIZE == 4 - = runST (do - arr <- newDoubleArray ((0::Int),0) - writeDoubleArray arr 0 d - d_arr <- castSTUArray arr - w0 <- readWordArray d_arr 0 - w1 <- readWordArray d_arr 1 - return [w0,w1] - ) - | wORD_SIZE == 8 - = runST (do - arr <- newDoubleArray ((0::Int),0) - writeDoubleArray arr 0 d - d_arr <- castSTUArray arr - w0 <- readWordArray d_arr 0 - return [w0] - ) - -mkLitI i - = runST (do - arr <- newIntArray ((0::Int),0) - writeIntArray arr 0 i - i_arr <- castSTUArray arr - w0 <- readWordArray i_arr 0 - return [w0] - ) - -mkLitA a - = runST (do - arr <- newAddrArray ((0::Int),0) - writeAddrArray arr 0 a - a_arr <- castSTUArray arr - w0 <- readWordArray a_arr 0 - return [w0] - ) +isPtrAtom :: AnnExpr' Id ann -> Bool +isPtrAtom e = atomRep e == PtrArg -\end{code} +-- 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. +mkStackOffsets :: Int -> [Int] -> [Int] +mkStackOffsets original_depth szsw + = map (subtract 1) (tail (scanl (+) original_depth szsw)) -%************************************************************************ -%* * -\subsection{Linking interpretables into something we can run} -%* * -%************************************************************************ +-- ----------------------------------------------------------------------------- +-- The bytecode generator's monad -\begin{code} +data BcM_State + = BcM_State { + nextlabel :: Int, -- for generating local labels + malloced :: [Ptr ()] } -- ptrs malloced for current BCO + -- Should be free()d when it is GCd -{- -data BCO# = BCO# ByteArray# -- instrs :: array Word16# - ByteArray# -- literals :: array Word32# - PtrArray# -- ptrs :: Array HValue - ByteArray# -- itbls :: Array Addr# --} +newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) -GLOBAL_VAR(v_cafTable, [], [HValue]) - ---addCAF :: HValue -> IO () ---addCAF x = do xs <- readIORef v_cafTable; writeIORef v_cafTable (x:xs) - ---bcosToHValue :: ItblEnv -> ClosureEnv -> UnlinkedBCOExpr -> IO HValue ---bcosToHValue ie ce (root_bco, other_bcos) --- = do linked_expr <- linkIExpr ie ce (root_bco, other_bcos) --- return linked_expr - -linkBCO ie ce (UnlinkedBCO nm insnsSS literalsSS ptrsSS itblsSS) - = do insns <- listFromSS insnsSS - literals <- listFromSS literalsSS - ptrs <- listFromSS ptrsSS - itbls <- listFromSS itblsSS - - linked_ptrs <- mapM (lookupCE ce) ptrs - linked_itbls <- mapM (lookupIE ie) itbls - - let n_insns = sizeSS insnsSS - n_literals = sizeSS literalsSS - n_ptrs = sizeSS ptrsSS - n_itbls = sizeSS itblsSS - - let ptrs_arr = array (0, n_ptrs-1) (indexify linked_ptrs) - :: Array Int HValue - ptrs_parr = case ptrs_arr of Array lo hi parr -> parr - - itbls_arr = array (0, n_itbls-1) (indexify linked_itbls) - :: UArray Int Addr - itbls_barr = case itbls_arr of UArray lo hi barr -> barr - - insns_arr | n_insns > 65535 - = panic "linkBCO: >= 64k insns in BCO" - | otherwise - = array (0, n_insns) - (indexify (fromIntegral n_insns:insns)) - :: UArray Int Word16 - insns_barr = case insns_arr of UArray lo hi barr -> barr - - literals_arr = array (0, n_literals-1) (indexify literals) - :: UArray Int Word - literals_barr = case literals_arr of UArray lo hi barr -> barr - - indexify :: [a] -> [(Int, a)] - indexify xs = zip [0..] xs - - BCO bco# <- newBCO insns_barr literals_barr ptrs_parr itbls_barr - - return (unsafeCoerce# bco#) - - -data BCO = BCO BCO# - -newBCO :: ByteArray# -> ByteArray# -> Array# a -> ByteArray# -> IO BCO -newBCO a b c d - = IO (\s -> case newBCO# a b c d s of (# s1, bco #) -> (# s1, BCO bco #)) - - -lookupCE :: ClosureEnv -> Name -> IO HValue -lookupCE ce nm - = case lookupFM ce nm of - Just aa -> return aa - Nothing - -> do m <- lookupSymbol (nameToCLabel nm "closure") - case m of - Just (A# addr) -> case addrToHValue# addr of - (# hval #) -> return hval - Nothing -> pprPanic "ByteCodeGen.lookupCE" (ppr nm) - -lookupIE :: ItblEnv -> Name -> IO Addr -lookupIE ie con_nm - = case lookupFM ie con_nm of - Just (Ptr a) -> return a - Nothing - -> do -- try looking up in the object files. - m <- lookupSymbol (nameToCLabel con_nm "con_info") - case m of - Just addr -> return addr - Nothing - -> do -- perhaps a nullary constructor? - n <- lookupSymbol (nameToCLabel con_nm "static_info") - case n of - Just addr -> return addr - Nothing -> pprPanic "ByteCodeGen.lookupIE" (ppr con_nm) - --- HACK!!! ToDo: cleaner -nameToCLabel :: Name -> String{-suffix-} -> String -nameToCLabel n suffix - = _UNPK_(moduleNameFS (rdrNameModule rn)) - ++ '_':occNameString(rdrNameOcc rn) ++ '_':suffix - where rn = toRdrName n +ioToBc :: IO a -> BcM a +ioToBc io = BcM $ \st -> do + x <- io + return (st, x) -\end{code} +runBc :: BcM r -> IO (BcM_State, r) +runBc (BcM m) = m (BcM_State 0 []) -%************************************************************************ -%* * -\subsection{Manufacturing of info tables for DataCons} -%* * -%************************************************************************ +thenBc :: BcM a -> (a -> BcM b) -> BcM b +thenBc (BcM expr) cont = BcM $ \st0 -> do + (st1, q) <- expr st0 + let BcM k = cont q + (st2, r) <- k st1 + return (st2, r) -\begin{code} +thenBc_ :: BcM a -> BcM b -> BcM b +thenBc_ (BcM expr) (BcM cont) = BcM $ \st0 -> do + (st1, q) <- expr st0 + (st2, r) <- cont st1 + return (st2, r) -#if __GLASGOW_HASKELL__ <= 408 -type ItblPtr = Addr -#else -type ItblPtr = Ptr StgInfoTable -#endif - --- Make info tables for the data decls in this module -mkITbls :: [TyCon] -> IO ItblEnv -mkITbls [] = return emptyFM -mkITbls (tc:tcs) = do itbls <- mkITbl tc - itbls2 <- mkITbls tcs - return (itbls `plusFM` itbls2) - -mkITbl :: TyCon -> IO ItblEnv -mkITbl tc - | not (isDataTyCon tc) - = return emptyFM - | n == length dcs -- paranoia; this is an assertion. - = make_constr_itbls dcs - where - dcs = tyConDataCons tc - n = tyConFamilySize tc - -cONSTR :: Int -cONSTR = 1 -- as defined in ghc/includes/ClosureTypes.h - --- Assumes constructors are numbered from zero, not one -make_constr_itbls :: [DataCon] -> IO ItblEnv -make_constr_itbls cons - | length cons <= 8 - = do is <- mapM mk_vecret_itbl (zip cons [0..]) - return (listToFM is) - | otherwise - = do is <- mapM mk_dirret_itbl (zip cons [0..]) - return (listToFM is) - where - mk_vecret_itbl (dcon, conNo) - = mk_itbl dcon conNo (vecret_entry conNo) - mk_dirret_itbl (dcon, conNo) - = mk_itbl dcon conNo stg_interp_constr_entry - - mk_itbl :: DataCon -> Int -> Addr -> IO (Name,ItblPtr) - mk_itbl dcon conNo entry_addr - = let (tot_wds, ptr_wds, _) - = mkVirtHeapOffsets typePrimRep (dataConRepArgTys dcon) - ptrs = ptr_wds - nptrs = tot_wds - ptr_wds - itbl = StgInfoTable { - ptrs = fromIntegral ptrs, nptrs = fromIntegral nptrs, - tipe = fromIntegral cONSTR, - srtlen = fromIntegral conNo, - code0 = fromIntegral code0, code1 = fromIntegral code1, - code2 = fromIntegral code2, code3 = fromIntegral code3, - code4 = fromIntegral code4, code5 = fromIntegral code5, - code6 = fromIntegral code6, code7 = fromIntegral code7 - } - -- Make a piece of code to jump to "entry_label". - -- This is the only arch-dependent bit. - -- On x86, if entry_label has an address 0xWWXXYYZZ, - -- emit movl $0xWWXXYYZZ,%eax ; jmp *%eax - -- which is - -- B8 ZZ YY XX WW FF E0 - (code0,code1,code2,code3,code4,code5,code6,code7) - = (0xB8, byte 0 entry_addr_w, byte 1 entry_addr_w, - byte 2 entry_addr_w, byte 3 entry_addr_w, - 0xFF, 0xE0, - 0x90 {-nop-}) - - entry_addr_w :: Word32 - entry_addr_w = fromIntegral (addrToInt entry_addr) - in - do addr <- malloc - --putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl)) - --putStrLn ("# ptrs of itbl is " ++ show ptrs) - --putStrLn ("# nptrs of itbl is " ++ show nptrs) - poke addr itbl - return (getName dcon, addr `plusPtr` 8) - - -byte :: Int -> Word32 -> Word32 -byte 0 w = w .&. 0xFF -byte 1 w = (w `shiftR` 8) .&. 0xFF -byte 2 w = (w `shiftR` 16) .&. 0xFF -byte 3 w = (w `shiftR` 24) .&. 0xFF - - -vecret_entry 0 = stg_interp_constr1_entry -vecret_entry 1 = stg_interp_constr2_entry -vecret_entry 2 = stg_interp_constr3_entry -vecret_entry 3 = stg_interp_constr4_entry -vecret_entry 4 = stg_interp_constr5_entry -vecret_entry 5 = stg_interp_constr6_entry -vecret_entry 6 = stg_interp_constr7_entry -vecret_entry 7 = stg_interp_constr8_entry - --- entry point for direct returns for created constr itbls -foreign label "stg_interp_constr_entry" stg_interp_constr_entry :: Addr --- and the 8 vectored ones -foreign label "stg_interp_constr1_entry" stg_interp_constr1_entry :: Addr -foreign label "stg_interp_constr2_entry" stg_interp_constr2_entry :: Addr -foreign label "stg_interp_constr3_entry" stg_interp_constr3_entry :: Addr -foreign label "stg_interp_constr4_entry" stg_interp_constr4_entry :: Addr -foreign label "stg_interp_constr5_entry" stg_interp_constr5_entry :: Addr -foreign label "stg_interp_constr6_entry" stg_interp_constr6_entry :: Addr -foreign label "stg_interp_constr7_entry" stg_interp_constr7_entry :: Addr -foreign label "stg_interp_constr8_entry" stg_interp_constr8_entry :: Addr - - - - - --- Ultra-minimalist version specially for constructors -data StgInfoTable = StgInfoTable { - ptrs :: Word16, - nptrs :: Word16, - srtlen :: Word16, - tipe :: Word16, - code0, code1, code2, code3, code4, code5, code6, code7 :: Word8 -} - - -instance Storable StgInfoTable where - - sizeOf itbl - = (sum . map (\f -> f itbl)) - [fieldSz ptrs, fieldSz nptrs, fieldSz srtlen, fieldSz tipe, - fieldSz code0, fieldSz code1, fieldSz code2, fieldSz code3, - fieldSz code4, fieldSz code5, fieldSz code6, fieldSz code7] - - alignment itbl - = (sum . map (\f -> f itbl)) - [fieldAl ptrs, fieldAl nptrs, fieldAl srtlen, fieldAl tipe, - fieldAl code0, fieldAl code1, fieldAl code2, fieldAl code3, - fieldAl code4, fieldAl code5, fieldAl code6, fieldAl code7] - - poke a0 itbl - = do a1 <- store (ptrs itbl) (castPtr a0) - a2 <- store (nptrs itbl) a1 - a3 <- store (tipe itbl) a2 - a4 <- store (srtlen itbl) a3 - a5 <- store (code0 itbl) a4 - a6 <- store (code1 itbl) a5 - a7 <- store (code2 itbl) a6 - a8 <- store (code3 itbl) a7 - a9 <- store (code4 itbl) a8 - aA <- store (code5 itbl) a9 - aB <- store (code6 itbl) aA - aC <- store (code7 itbl) aB - return () - - peek a0 - = do (a1,ptrs) <- load (castPtr a0) - (a2,nptrs) <- load a1 - (a3,tipe) <- load a2 - (a4,srtlen) <- load a3 - (a5,code0) <- load a4 - (a6,code1) <- load a5 - (a7,code2) <- load a6 - (a8,code3) <- load a7 - (a9,code4) <- load a8 - (aA,code5) <- load a9 - (aB,code6) <- load aA - (aC,code7) <- load aB - return StgInfoTable { ptrs = ptrs, nptrs = nptrs, - srtlen = srtlen, tipe = tipe, - code0 = code0, code1 = code1, code2 = code2, - code3 = code3, code4 = code4, code5 = code5, - code6 = code6, code7 = code7 } - -fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int -fieldSz sel x = sizeOf (sel x) - -fieldAl :: (Storable a, Storable b) => (a -> b) -> a -> Int -fieldAl sel x = alignment (sel x) - -store :: Storable a => a -> Ptr a -> IO (Ptr b) -store x addr = do poke addr x - return (castPtr (addr `plusPtr` sizeOf x)) - -load :: Storable a => Ptr a -> IO (Ptr b, a) -load addr = do x <- peek addr - return (castPtr (addr `plusPtr` sizeOf x), x) +returnBc :: a -> BcM a +returnBc result = BcM $ \st -> (return (st, result)) -\end{code} +instance Monad BcM where + (>>=) = thenBc + (>>) = thenBc_ + return = returnBc -%************************************************************************ -%* * -\subsection{Connect to actual values for bytecode opcodes} -%* * -%************************************************************************ +emitBc :: ([Ptr ()] -> ProtoBCO Name) -> BcM (ProtoBCO Name) +emitBc bco + = BcM $ \st -> return (st{malloced=[]}, bco (malloced st)) -\begin{code} +recordMallocBc :: Ptr a -> BcM () +recordMallocBc a + = BcM $ \st -> return (st{malloced = castPtr a : malloced st}, ()) -#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_PUSH_UBX = (bci_PUSH_UBX :: Int) -i_PUSH_TAG = (bci_PUSH_TAG :: Int) -i_SLIDE = (bci_SLIDE :: Int) -i_ALLOC = (bci_ALLOC :: Int) -i_MKAP = (bci_MKAP :: Int) -i_UNPACK = (bci_UNPACK :: Int) -i_UPK_TAG = (bci_UPK_TAG :: Int) -i_PACK = (bci_PACK :: 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) +getLabelBc :: BcM Int +getLabelBc + = BcM $ \st -> return (st{nextlabel = 1 + nextlabel st}, nextlabel st) +getLabelsBc :: Int -> BcM [Int] +getLabelsBc n + = BcM $ \st -> let ctr = nextlabel st + in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1]) \end{code}