X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FByteCodeGen.lhs;h=485a2851ce1b46bd3b1d283c4a11c8036bc98abd;hb=59c796f8e77325d35f29ddd3e724bfa780466d40;hp=989a7692548033006e593d63e9844f07f8c72873;hpb=07ab325d2f5215127147186898c9311d4684936d;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index 989a769..485a285 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -1,141 +1,125 @@ % -% (c) The University of Glasgow 2000 +% (c) The University of Glasgow 2002 % \section[ByteCodeGen]{Generate bytecode from Core} \begin{code} -module ByteCodeGen ( byteCodeGen, assembleBCO ) 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 ) -import Id ( Id, idType, isDataConId_maybe ) -import OrdList ( OrdList, consOL, snocOL, appOL, unitOL, - nilOL, toOL, concatOL, fromOL ) -import FiniteMap ( FiniteMap, addListToFM, listToFM, - addToFM, lookupFM, fmToList, emptyFM ) +import Name ( Name, getName, mkSystemName ) +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(..) ) -import PrimRep ( PrimRep(..) ) +import PprCore ( pprCoreExpr ) +import Literal ( Literal(..), literalType ) +import PrimOp ( PrimOp(..) ) import CoreFVs ( freeVars ) -import Type ( typePrimRep ) -import DataCon ( DataCon, dataConTag, fIRST_TAG ) -import Util ( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem ) +import Type ( isUnLiftedType, splitTyConApp_maybe ) +import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon, + isUnboxedTupleCon, isNullaryDataCon, dataConWorkId, + dataConRepArity ) +import TyCon ( tyConFamilySize, isDataTyCon, tyConDataCons, + isUnboxedTupleTyCon ) +import Class ( Class, classTyCon ) +import Type ( Type, repType, splitFunTys, dropForAlls, pprType ) +import Util +import DataCon ( dataConRepArity ) import Var ( isTyVar ) import VarSet ( VarSet, varSetElems ) -import PrimRep ( getPrimRepSize, isFollowableRep ) +import TysPrim ( arrayPrimTyCon, mutableArrayPrimTyCon, + byteArrayPrimTyCon, mutableByteArrayPrimTyCon + ) +import CmdLineOpts ( DynFlags, DynFlag(..) ) +import ErrUtils ( showPass, dumpIfSet_dyn ) +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 ) -import Foreign ( Addr, Word16, Word32, nullAddr ) -import ST ( runST ) -import MutableArray ( readWord32Array, - newFloatArray, writeFloatArray, - newDoubleArray, writeDoubleArray, - newIntArray, writeIntArray, - newAddrArray, writeAddrArray ) -\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 ) -Entry point. +import GHC.Exts ( Int(..), ByteArray# ) -\begin{code} -byteCodeGen :: [CoreBind] -> [ProtoBCO Name] -byteCodeGen binds - = let flatBinds = concatMap getBind binds - getBind (NonRec bndr rhs) = [(bndr, freeVars rhs)] - getBind (Rec binds) = [(bndr, freeVars rhs) | (bndr,rhs) <- binds] - final_state = runBc (BcM_State [] 0) - (mapBc schemeR flatBinds `thenBc_` returnBc ()) - in - case final_state of - BcM_State bcos final_ctr -> bcos -\end{code} +import Control.Monad ( when ) +import Data.Char ( ord, chr ) +-- ----------------------------------------------------------------------------- +-- Generating byte code for a complete module -%************************************************************************ -%* * -\subsection{Bytecodes, and Outputery.} -%* * -%************************************************************************ +byteCodeGen :: DynFlags + -> [CoreBind] + -> TypeEnv + -> IO CompiledByteCode +byteCodeGen dflags binds type_env + = do showPass dflags "ByteCodeGen" + let local_tycons = typeEnvTyCons type_env + local_classes = typeEnvClasses type_env + tycs = local_tycons ++ map classTyCon local_classes -\begin{code} + let flatBinds = [ (bndr, freeVars rhs) + | (bndr, rhs) <- flattenBinds binds] -type LocalLabel = Int - -data BCInstr - -- Messing with the stack - = ARGCHECK Int - | PUSH_L Int{-offset-} - | PUSH_G Name - | PUSHT_I Int - | PUSHT_F Float - | PUSHT_D Double - | PUSHU_I Int - | PUSHU_F Float - | PUSHU_D Double - | SLIDE Int{-this many-} Int{-down by this much-} - -- To do with the heap - | ALLOC Int - | MKAP Int{-place ptr to heap this far down stack-} Int{-# words-} - | UNPACK Int - | PACK DataCon Int - -- For doing case trees - | LABEL LocalLabel - | TESTLT_I Int LocalLabel - | TESTEQ_I Int LocalLabel - | TESTLT_F Float LocalLabel - | TESTEQ_F Float LocalLabel - | TESTLT_D Double LocalLabel - | TESTEQ_D Double LocalLabel - | TESTLT_P Int LocalLabel - | TESTEQ_P Int LocalLabel - | CASEFAIL - -- To Infinity And Beyond - | ENTER - -instance Outputable BCInstr where - ppr (ARGCHECK n) = text "ARGCHECK" <+> int n - ppr (PUSH_L offset) = text "PUSH_L " <+> int offset - ppr (PUSH_G nm) = text "PUSH_G " <+> ppr nm - ppr (PUSHT_I i) = text "PUSHT_I " <+> int i - ppr (SLIDE n d) = text "SLIDE " <+> int n <+> int d - ppr (ALLOC sz) = text "ALLOC " <+> int sz - ppr (MKAP offset sz) = text "MKAP " <+> int offset <+> int sz - ppr (UNPACK sz) = text "UNPACK " <+> int sz - ppr (PACK dcon sz) = text "PACK " <+> ppr dcon <+> ppr sz - ppr ENTER = text "ENTER" - -pprAltCode discrs_n_codes - = vcat (map f discrs_n_codes) - where f (discr, code) = ppr discr <> colon <+> vcat (map ppr (fromOL code)) - -instance Outputable a => Outputable (ProtoBCO a) where - ppr (ProtoBCO name instrs origin) - = (text "ProtoBCO" <+> ppr name <> colon) - $$ nest 6 (vcat (map ppr (fromOL instrs))) - $$ case origin of - Left alts -> vcat (map (pprCoreAlt.deAnnAlt) alts) - Right rhs -> pprCoreExpr (deAnnotate rhs) -\end{code} + (BcM_State final_ctr mallocd, proto_bcos) + <- runBc (mapM schemeTopBind flatBinds) -%************************************************************************ -%* * -\subsection{Compilation schema for the bytecode generator.} -%* * -%************************************************************************ + when (notNull mallocd) + (panic "ByteCodeGen.byteCodeGen: missing final emitBc?") -\begin{code} + dumpIfSet_dyn dflags Opt_D_dump_BCOs + "Proto-BCOs" (vcat (intersperse (char ' ') (map ppr proto_bcos))) -type BCInstrList = OrdList BCInstr + assembleBCOs proto_bcos tycs + +-- ----------------------------------------------------------------------------- +-- Generating byte code for an expression -data ProtoBCO a - = ProtoBCO a -- name, in some sense - BCInstrList -- instrs - -- what the BCO came from - (Either [AnnAlt Id VarSet] - (AnnExpr Id VarSet)) +-- Returns: (the root BCO for this expression, +-- a list of auxilary BCOs resulting from compiling closures) +coreExprToBCOs :: DynFlags + -> CoreExpr + -> 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 = mkSystemName (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)) + + when (notNull mallocd) + (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?") + + dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" (ppr proto_bco) + + assembleBCO proto_bco + + +-- ----------------------------------------------------------------------------- +-- Compilation schema for the bytecode generator + +type BCInstrList = OrdList BCInstr type Sequel = Int -- back off to this depth before ENTER @@ -143,235 +127,1008 @@ type Sequel = Int -- back off to this depth before ENTER -- to mess with it after each push/pop. type BCEnv = FiniteMap Id Int -- To find vars on the stack - - --- Compile code for the right hand side of a let binding. +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 + :: 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-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 + +schemeTopBind :: (Id, AnnExpr Id VarSet) -> BcM (ProtoBCO Name) + + +schemeTopBind (id, rhs) + | Just data_con <- isDataConWorkId_maybe id, + isNullaryDataCon 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) = schemeR_wrk rhs nm (collect [] rhs) - -collect xs (_, AnnLam x e) - = collect (if isTyVar x then xs else (x:xs)) e -collect xs not_lambda - = (reverse xs, not_lambda) - -schemeR_wrk original_body nm (args, body) - = let fvs = filter (not.isTyVar) (varSetElems (fst original_body)) - all_args = fvs ++ reverse args - szsw_args = map taggedIdSizeW all_args +-- 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 ' ' + $$ (ppr.filter (not.isTyVar).varSetElems.fst) rhs + $$ pprCoreExpr (deAnnotate rhs) + $$ char ' ' + ))) False + = undefined + | otherwise +-} + = 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) + +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 + + 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 (ProtoBCO (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) - = 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 (fvs, AnnLet binds b) +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 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_type = idType v + v_rep = typeCgRep v_type + +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 + `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 - sizes = map (\rhs_fvs -> 1 + sum (map taggedIdSizeW rhs_fvs)) fvss + n_binds = length xs + + fvss = map (fvsToEnv p' . fst) rhss + + -- 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)) + + +-- 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. -schemeE d s p (fvs, AnnCase scrut bndr alts) - = let +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( isNullaryDataCon 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 + ASSERTM( null reps ) + (push_fn, sz) <- pushAtom d p (AnnVar fn) + ASSERTM( sz == 1 ) + 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: PtrArg: rest) + = (PUSH_APPLY_PPPPPPP, 7, rest) +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) - isAlgCase - = case typePrimRep (idType bndr) 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, rhs) - | isAlgCase - = let binds_szsw = map untaggedIdSizeW binds - binds_szw = sum binds_szsw - p'' = addListToFM p' (zip binds (mkStackOffsets d' binds_szsw)) - d'' = d' + binds_szw - in schemeE d'' s p'' rhs `thenBc` \ rhs_code -> - returnBc (my_discr alt, UNPACK binds_szw `consOL` rhs_code) - | otherwise - = ASSERT(null binds) - 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) - in - mapBc codeAlt alts `thenBc` \ alt_stuff -> - mkMultiBranch alt_stuff `thenBc` \ alt_final -> + maybe_ncons + | not isAlgCase = Nothing + | otherwise + = case [dc | (DataAlt dc, _, _) <- alts] of + [] -> Nothing + (dc:_) -> Just (tyConFamilySize (dataConTyCon dc)) + + -- 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_bco_name = getName bndr - alt_bco = ProtoBCO alt_bco_name alt_final (Left alts) - in - schemeE (d + ret_frame_sizeW) - (d + ret_frame_sizeW) p scrut `thenBc` \ scrut_code -> + 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) - emitBc alt_bco `thenBc_` - returnBc (PUSH_G alt_bco_name `consOL` scrut_code) + 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 + --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] --- 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) - = let (push, arg_words) = pushAtom enTag d p (snd a) - in arg_words `seq` - push - `appOL` schemeT enTag (d+arg_words) s (narg_words+arg_words) p f - -schemeT enTag d s narg_words p (_, AnnVar f) - | Just con <- isDataConId_maybe f - = ASSERT(enTag == False) - PACK con narg_words `consOL` SLIDE 1 (d-s-1) `consOL` unitOL ENTER - | otherwise - = ASSERT(enTag == True) - let (push, arg_words) = pushAtom True d p (AnnVar f) - in arg_words `seq` - push - `snocOL` SLIDE (narg_words+arg_words) (d - s - narg_words) - `snocOL` ENTER - -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" +-- ----------------------------------------------------------------------------- +-- pushAtom -- 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). +-- stack words used. -- --- 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. - -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 = getName v - sz_t = taggedIdSizeW v - sz_u = untaggedIdSizeW v - nwords = if tagged then sz_t else sz_u - in - --trace str' - result +-- 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 True d p (AnnLit lit) - = case lit of - MachInt i -> (unitOL (PUSHT_I (fromInteger i)), taggedSizeW IntRep) - MachFloat r -> (unitOL (PUSHT_F (fromRational r)), taggedSizeW FloatRep) - MachDouble r -> (unitOL (PUSHT_D (fromRational r)), taggedSizeW DoubleRep) +pushAtom :: Int -> BCEnv -> AnnExpr' Id VarSet -> BcM (BCInstrList, Int) -pushAtom False d p (AnnLit lit) - = case lit of - MachInt i -> (unitOL (PUSHU_I (fromInteger i)), untaggedSizeW IntRep) - MachFloat r -> (unitOL (PUSHU_F (fromRational r)), untaggedSizeW FloatRep) - MachDouble r -> (unitOL (PUSHU_D (fromRational r)), untaggedSizeW DoubleRep) +pushAtom d p (AnnApp f (_, AnnType _)) + = pushAtom d p (snd f) + +pushAtom d p (AnnNote note e) + = pushAtom d p (snd e) + +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) + + | 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. + + | 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 + 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 = cgRepSizeW rep + in returnBc (unitOL (PUSH_UBX (Left lit) size_host_words), + size_host_words) + + pushStr s + = let getMallocvilleAddr + = case s of + 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 remember the pointer so we can + -- free it later. + let n = I# l + -- CAREFUL! Chars are 32 bits in ghc 4.09+ + in ioToBc (mallocBytes (n+1)) `thenBc` \ ptr -> + recordMallocBc ptr `thenBc_` + ioToBc ( + do memcpy ptr ba (fromIntegral n) + pokeByteOff ptr n (fromIntegral (ord '\0') :: Word8) + return ptr + ) + other -> panic "ByteCodeGen.pushAtom.pushStr" + in + getMallocvilleAddr `thenBc` \ addr -> + -- Get the addr on the stack, untaggedly + returnBc (unitOL (PUSH_UBX (Right addr) 1), 1) + +pushAtom d p other + = pprPanic "ByteCodeGen.pushAtom" + (pprCoreExpr (deAnnotate (undefined, other))) + +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 :: [(Discr, BCInstrList)] -> BcM BCInstrList -mkMultiBranch raw_ways + +mkMultiBranch :: Maybe Int -- # datacons in tycon, if alg alt + -- a hint; generates better code + -- Nothing is always safe + -> [(Discr, BCInstrList)] + -> BcM BCInstrList +mkMultiBranch maybe_ncons raw_ways = let d_way = filter (isNoDiscr.fst) raw_ways notd_ways = naturalMergeSortLe (\w1 w2 -> leAlt (fst w1) (fst w2)) @@ -428,10 +1185,15 @@ mkMultiBranch raw_ways DiscrD maxD ); DiscrP _ -> ( \(DiscrP i) fail_label -> TESTLT_P i fail_label, \(DiscrP i) fail_label -> TESTEQ_P i fail_label, - DiscrP minBound, - DiscrP maxBound ) + DiscrP algMinBound, + DiscrP algMaxBound ) } + (algMinBound, algMaxBound) + = case maybe_ncons of + Just n -> (0, n - 1) + Nothing -> (minBound, maxBound) + (DiscrI i1) `eqAlt` (DiscrI i2) = i1 == i2 (DiscrF f1) `eqAlt` (DiscrF f2) = f1 == f2 (DiscrD d1) `eqAlt` (DiscrD d2) = d1 == d2 @@ -464,15 +1226,9 @@ mkMultiBranch 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 @@ -490,353 +1246,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 +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.")) --- The plain size of something, without tag. -untaggedSizeW :: PrimRep -> Int -untaggedSizeW pr - | isFollowableRep pr = 1 - | otherwise = getPrimRepSize pr +mkSLIDE n d = if d == 0 then nilOL else unitOL (SLIDE n d) +bind x f = f x +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, []) -taggedIdSizeW, untaggedIdSizeW :: Id -> Int -taggedIdSizeW = taggedSizeW . typePrimRep . idType -untaggedIdSizeW = untaggedSizeW . typePrimRep . idType -\end{code} +isTypeAtom :: AnnExpr' id ann -> Bool +isTypeAtom (AnnType _) = True +isTypeAtom _ = False -%************************************************************************ -%* * -\subsection{The bytecode generator's monad} -%* * -%************************************************************************ +isVoidArgAtom :: AnnExpr' id ann -> Bool +isVoidArgAtom (AnnVar v) = typeCgRep (idType v) == VoidArg +isVoidArgAtom (AnnNote n (_,e)) = isVoidArgAtom e +isVoidArgAtom _ = False + +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))) + +isPtrAtom :: AnnExpr' Id ann -> Bool +isPtrAtom e = atomRep e == PtrArg + +-- 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)) + +-- ----------------------------------------------------------------------------- +-- The bytecode generator's monad -\begin{code} data BcM_State - = BcM_State { bcos :: [ProtoBCO Name], -- accumulates completed BCOs - nextlabel :: Int } -- for generating local labels + = BcM_State { + nextlabel :: Int, -- for generating local labels + malloced :: [Ptr ()] } -- ptrs malloced for current BCO + -- Should be free()d when it is GCd -type BcM result = BcM_State -> (result, BcM_State) +newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) -mkBcM_State :: [ProtoBCO Name] -> Int -> BcM_State -mkBcM_State = BcM_State +ioToBc :: IO a -> BcM a +ioToBc io = BcM $ \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 r -> IO (BcM_State, r) +runBc (BcM m) = m (BcM_State 0 []) thenBc :: BcM a -> (a -> BcM b) -> BcM b -thenBc expr cont st - = case expr st of { (result, st') -> cont result st' } +thenBc (BcM expr) cont = BcM $ \st0 -> do + (st1, q) <- expr st0 + let BcM k = cont q + (st2, r) <- k st1 + return (st2, r) thenBc_ :: BcM a -> BcM b -> BcM b -thenBc_ expr cont st - = case expr st of { (result, st') -> cont st' } +thenBc_ (BcM expr) (BcM cont) = BcM $ \st0 -> do + (st1, q) <- expr st0 + (st2, r) <- cont st1 + return (st2, r) returnBc :: a -> BcM a -returnBc result st = (result, st) - -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) - -emitBc :: ProtoBCO Name -> BcM () -emitBc bco st - = ((), st{bcos = bco : bcos st}) +returnBc result = BcM $ \st -> (return (st, result)) -getLabelBc :: BcM Int -getLabelBc st - = (nextlabel st, st{nextlabel = 1 + nextlabel st}) - -\end{code} +instance Monad BcM where + (>>=) = thenBc + (>>) = thenBc_ + return = returnBc -%************************************************************************ -%* * -\subsection{The bytecode assembler} -%* * -%************************************************************************ +emitBc :: ([Ptr ()] -> ProtoBCO Name) -> BcM (ProtoBCO Name) +emitBc bco + = BcM $ \st -> return (st{malloced=[]}, bco (malloced st)) -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. +recordMallocBc :: Ptr a -> BcM () +recordMallocBc a + = BcM $ \st -> return (st{malloced = castPtr a : malloced st}, ()) -\begin{code} --- An (almost) assembled BCO. -data BCO a = BCO [Word16] -- instructions - [Word32] -- literal pool - [a] -- Names or HValues - --- Top level assembler fn. -assembleBCO :: ProtoBCO Name -> BCO Name -assembleBCO (ProtoBCO nm instrs_ordlist origin) - = let - -- pass 1: collect up the offsets of the local labels - instrs = fromOL instrs_ordlist - label_env = mkLabelEnv emptyFM 0 instrs - - mkLabelEnv env i_offset [] = env - mkLabelEnv env i_offset (i:is) - = let new_env - = case i of LABEL n -> addToFM env n i_offset ; _ -> env - in mkLabelEnv new_env (i_offset + instrSizeB i) is - - findLabel lab - = case lookupFM label_env lab of - Just bco_offset -> bco_offset - Nothing -> pprPanic "assembleBCO.findLabel" (int lab) - - -- pass 2: generate the instruction, ptr and nonptr bits - (insnW16s, litW32s, ptrs) = mkBits findLabel [] 0 [] 0 [] 0 instrs - in - BCO insnW16s litW32s ptrs - - --- This is where all the action is (pass 2 of the assembler) -mkBits :: (Int -> Int) -- label finder - -> [Word16] -> Int -- reverse acc instr bits - -> [Word32] -> Int -- reverse acc literal bits - -> [Name] -> Int -- reverse acc ptrs - -> [BCInstr] -- insns! - -> ([Word16], [Word32], [Name]) - -mkBits findLabel r_is n_is r_lits n_lits r_ptrs n_ptrs [] - = (reverse r_is, reverse r_lits, reverse r_ptrs) -mkBits findLabel r_is n_is r_lits n_lits r_ptrs n_ptrs (instr:instrs) - = case instr of - ARGCHECK n -> boring2 i_ARGCHECK n - PUSH_L off -> boring2 i_PUSH_L off - PUSH_G nm -> exciting2_P i_PUSH_G n_ptrs nm - PUSHT_I i -> exciting2_I i_PUSHT_I n_lits i - PUSHT_F f -> exciting2_F i_PUSHT_F n_lits f - PUSHT_D d -> exciting2_D i_PUSHT_D n_lits d - PUSHU_I i -> exciting2_I i_PUSHU_I n_lits i - PUSHU_F f -> exciting2_F i_PUSHU_F n_lits f - PUSHU_D d -> exciting2_D i_PUSHU_D n_lits d - SLIDE n by -> boring3 i_SLIDE n by - ALLOC n -> boring2 i_ALLOC n - MKAP off sz -> boring3 i_MKAP off sz - UNPACK n -> boring2 i_UNPACK n - PACK dcon sz -> exciting3_A i_PACK sz n_lits nullAddr {-findItbl dcon-} - LABEL lab -> nop - TESTLT_I i l -> exciting3_I i_TESTLT_I n_lits (findLabel l) i - TESTEQ_I i l -> exciting3_I i_TESTEQ_I n_lits (findLabel l) i - TESTLT_F f l -> exciting3_F i_TESTLT_F n_lits (findLabel l) f - TESTEQ_F f l -> exciting3_F i_TESTEQ_F n_lits (findLabel l) f - TESTLT_D d l -> exciting3_D i_TESTLT_D n_lits (findLabel l) d - TESTEQ_D d l -> exciting3_D i_TESTEQ_D n_lits (findLabel l) d - TESTLT_P i l -> exciting3_I i_TESTLT_P n_lits (findLabel l) i - TESTEQ_P i l -> exciting3_I i_TESTEQ_P n_lits (findLabel l) i - CASEFAIL -> boring1 i_CASEFAIL - ENTER -> boring1 i_ENTER - where - r_mkILit = reverse . mkILit - r_mkFLit = reverse . mkFLit - r_mkDLit = reverse . mkDLit - r_mkALit = reverse . mkALit - - mkw :: Int -> Word16 - mkw = fromIntegral - - nop - = mkBits findLabel r_is n_is r_lits n_lits r_ptrs n_ptrs instrs - boring1 i1 - = mkBits findLabel (mkw i1 : r_is) (n_is+1) - r_lits n_lits r_ptrs n_ptrs instrs - boring2 i1 i2 - = mkBits findLabel (mkw i2 : mkw i1 : r_is) (n_is+2) - r_lits n_lits r_ptrs n_ptrs instrs - boring3 i1 i2 i3 - = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3) - r_lits n_lits r_ptrs n_ptrs instrs - - exciting2_P i1 i2 p - = mkBits findLabel (mkw i2 : mkw i1 : r_is) (n_is+2) r_lits n_lits - (p:r_ptrs) (n_ptrs+1) instrs - exciting3_P i1 i2 i3 p - = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3) r_lits n_lits - (p:r_ptrs) (n_ptrs+1) instrs - - exciting2_I i1 i2 i - = mkBits findLabel (mkw i2 : mkw i1 : r_is) (n_is+2) - (r_mkILit i ++ r_lits) (n_lits + intLitSz32s) - r_ptrs n_ptrs instrs - exciting3_I i1 i2 i3 i - = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3) - (r_mkILit i ++ r_lits) (n_lits + intLitSz32s) - r_ptrs n_ptrs instrs - - exciting2_F i1 i2 f - = mkBits findLabel (mkw i2 : mkw i1 : r_is) (n_is+2) - (r_mkFLit f ++ r_lits) (n_lits + floatLitSz32s) - r_ptrs n_ptrs instrs - exciting3_F i1 i2 i3 f - = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3) - (r_mkFLit f ++ r_lits) (n_lits + floatLitSz32s) - r_ptrs n_ptrs instrs - - exciting2_D i1 i2 d - = mkBits findLabel (mkw i2 : mkw i1 : r_is) (n_is+2) - (r_mkDLit d ++ r_lits) (n_lits + doubleLitSz32s) - r_ptrs n_ptrs instrs - exciting3_D i1 i2 i3 d - = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3) - (r_mkDLit d ++ r_lits) (n_lits + doubleLitSz32s) - r_ptrs n_ptrs instrs - - exciting3_A i1 i2 i3 d - = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3) - (r_mkALit d ++ r_lits) (n_lits + addrLitSz32s) - r_ptrs n_ptrs instrs - - --- The size in bytes of an instruction. -instrSizeB :: BCInstr -> Int -instrSizeB instr - = case instr of - ARGCHECK _ -> 4 - PUSH_L _ -> 4 - PUSH_G _ -> 4 - PUSHT_I _ -> 4 - PUSHT_F _ -> 4 - PUSHT_D _ -> 4 - PUSHU_I _ -> 4 - PUSHU_F _ -> 4 - PUSHU_D _ -> 4 - SLIDE _ _ -> 6 - ALLOC _ -> 4 - MKAP _ _ -> 6 - UNPACK _ -> 4 - PACK _ _ -> 6 - LABEL _ -> 4 - TESTLT_I _ _ -> 6 - TESTEQ_I _ _ -> 6 - TESTLT_F _ _ -> 6 - TESTEQ_F _ _ -> 6 - TESTLT_D _ _ -> 6 - TESTEQ_D _ _ -> 6 - TESTLT_P _ _ -> 6 - TESTEQ_P _ _ -> 6 - CASEFAIL -> 2 - ENTER -> 2 - - --- Sizes of Int, Float and Double literals, in units of 32-bitses -intLitSz32s, floatLitSz32s, doubleLitSz32s, addrLitSz32s :: Int -intLitSz32s = wORD_SIZE `div` 4 -floatLitSz32s = 1 -- Assume IEEE floats -doubleLitSz32s = 2 -addrLitSz32s = intLitSz32s - --- Make lists of 32-bit words for literals, so that when the --- words are placed in memory at increasing addresses, the --- bit pattern is correct for the host's word size and endianness. -mkILit :: Int -> [Word32] -mkFLit :: Float -> [Word32] -mkDLit :: Double -> [Word32] -mkALit :: Addr -> [Word32] - -mkFLit f - = runST (do - arr <- newFloatArray ((0::Int),0) - writeFloatArray arr 0 f - w0 <- readWord32Array arr 0 - return [w0] - ) - -mkDLit d - = runST (do - arr <- newDoubleArray ((0::Int),0) - writeDoubleArray arr 0 d - w0 <- readWord32Array arr 0 - w1 <- readWord32Array arr 1 - return [w0,w1] - ) - -mkILit i - | wORD_SIZE == 4 - = runST (do - arr <- newIntArray ((0::Int),0) - writeIntArray arr 0 i - w0 <- readWord32Array arr 0 - return [w0] - ) - | wORD_SIZE == 8 - = runST (do - arr <- newIntArray ((0::Int),0) - writeIntArray arr 0 i - w0 <- readWord32Array arr 0 - w1 <- readWord32Array arr 1 - return [w0,w1] - ) - -mkALit a - | wORD_SIZE == 4 - = runST (do - arr <- newAddrArray ((0::Int),0) - writeAddrArray arr 0 a - w0 <- readWord32Array arr 0 - return [w0] - ) - | wORD_SIZE == 8 - = runST (do - arr <- newAddrArray ((0::Int),0) - writeAddrArray arr 0 a - w0 <- readWord32Array arr 0 - w1 <- readWord32Array arr 1 - return [w0,w1] - ) - - - -#include "../rts/Bytecodes.h" - -i_ARGCHECK = (bci_ARGCHECK :: Int) -i_PUSH_L = (bci_PUSH_L :: Int) -i_PUSH_G = (bci_PUSH_G :: Int) -i_PUSHT_I = (bci_PUSHT_I :: Int) -i_PUSHT_F = (bci_PUSHT_F :: Int) -i_PUSHT_D = (bci_PUSHT_D :: Int) -i_PUSHU_I = (bci_PUSHU_I :: Int) -i_PUSHU_F = (bci_PUSHU_F :: Int) -i_PUSHU_D = (bci_PUSHU_D :: Int) -i_SLIDE = (bci_SLIDE :: Int) -i_ALLOC = (bci_ALLOC :: Int) -i_MKAP = (bci_MKAP :: Int) -i_UNPACK = (bci_UNPACK :: Int) -i_PACK = (bci_PACK :: Int) -i_LABEL = (bci_LABEL :: Int) -i_TESTLT_I = (bci_TESTLT_I :: Int) -i_TESTEQ_I = (bci_TESTEQ_I :: Int) -i_TESTLT_F = (bci_TESTLT_F :: Int) -i_TESTEQ_F = (bci_TESTEQ_F :: Int) -i_TESTLT_D = (bci_TESTLT_D :: Int) -i_TESTEQ_D = (bci_TESTEQ_D :: Int) -i_TESTLT_P = (bci_TESTLT_P :: Int) -i_TESTEQ_P = (bci_TESTEQ_P :: Int) -i_CASEFAIL = (bci_CASEFAIL :: Int) -i_ENTER = (bci_ENTER :: Int) +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}