X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FByteCodeGen.lhs;h=5b0aa6709d0b7d8ae9ffabe588f4241ea1466872;hb=1222d1f1cd463d17cfd3109c5da8234b63117bf1;hp=81327f4f154584015288be2320930468d753c72b;hpb=c50463bd883aa01f655318f924f76df43b8f41aa;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index 81327f4..5b0aa67 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -4,138 +4,138 @@ \section[ByteCodeGen]{Generate bytecode from Core} \begin{code} -module ByteCodeGen ( byteCodeGen, assembleBCO ) where +module ByteCodeGen ( UnlinkedBCO, UnlinkedBCOExpr, ItblEnv, ClosureEnv, HValue, + filterNameMap, + byteCodeGen, coreExprToBCOs + ) where #include "HsVersions.h" import Outputable import Name ( Name, getName ) -import Id ( Id, idType, isDataConId_maybe ) +import Id ( Id, idType, isDataConId_maybe, isPrimOpId_maybe, isFCallId, + idPrimRep, mkSysLocal, idName, isFCallId_maybe ) +import ForeignCall ( ForeignCall(..), CCallTarget(..), CCallSpec(..) ) import OrdList ( OrdList, consOL, snocOL, appOL, unitOL, nilOL, toOL, concatOL, fromOL ) -import FiniteMap ( FiniteMap, addListToFM, listToFM, - addToFM, lookupFM, fmToList, emptyFM ) +import FiniteMap ( FiniteMap, addListToFM, listToFM, + addToFM, lookupFM, fmToList ) import CoreSyn -import PprCore ( pprCoreExpr, pprCoreAlt ) -import Literal ( Literal(..) ) +import PprCore ( pprCoreExpr ) +import Literal ( Literal(..), literalPrimRep ) import PrimRep ( PrimRep(..) ) +import PrimOp ( PrimOp(..) ) import CoreFVs ( freeVars ) -import Type ( typePrimRep ) -import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon ) -import TyCon ( tyConFamilySize ) +import Type ( typePrimRep, splitTyConApp_maybe, isTyVarTy ) +import DataCon ( dataConTag, fIRST_TAG, dataConTyCon, + dataConWrapId, isUnboxedTupleCon ) +import TyCon ( TyCon(..), tyConFamilySize, isDataTyCon, tyConDataCons, + isFunTyCon, isUnboxedTupleTyCon ) +import Class ( Class, classTyCon ) +import Type ( Type, repType, splitRepFunTys ) import Util ( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem ) import Var ( isTyVar ) import VarSet ( VarSet, varSetElems ) -import PrimRep ( getPrimRepSize, isFollowableRep ) +import PrimRep ( isFollowableRep ) +import CmdLineOpts ( DynFlags, DynFlag(..) ) +import ErrUtils ( showPass, dumpIfSet_dyn ) +import Unique ( mkPseudoUnique3 ) +import FastString ( FastString(..) ) +import Panic ( GhcException(..) ) +import PprType ( pprType ) +import SMRep ( arrWordsHdrSize, arrPtrsHdrSize ) import Constants ( wORD_SIZE ) +import ByteCodeInstr ( BCInstr(..), ProtoBCO(..), nameOfProtoBCO, bciStackUse ) +import ByteCodeItbls ( ItblEnv, mkITbls ) +import ByteCodeLink ( UnlinkedBCO, UnlinkedBCOExpr, assembleBCO, + ClosureEnv, HValue, filterNameMap, + iNTERP_STACK_CHECK_THRESH ) +import ByteCodeFFI ( taggedSizeW, untaggedSizeW, mkMarshalCode ) +import Linker ( lookupSymbol ) + +import List ( intersperse, sortBy, zip4 ) +import Foreign ( Ptr(..), mallocBytes ) +import Addr ( Addr(..), writeCharOffAddr ) +import CTypes ( CInt ) +import Exception ( throwDyn ) + +import PrelBase ( Int(..) ) +import PrelGHC ( ByteArray# ) +import PrelIOBase ( IO(..) ) +import Monad ( when ) -import Foreign ( Addr, Word16, Word32, nullAddr ) -import ST ( runST ) -import MutableArray ( readWord32Array, - newFloatArray, writeFloatArray, - newDoubleArray, writeDoubleArray, - newIntArray, writeIntArray, - newAddrArray, writeAddrArray ) \end{code} -Entry point. - -\begin{code} -byteCodeGen :: [CoreBind] -> [ProtoBCO Name] -byteCodeGen binds - = let flatBinds = concatMap getBind binds - getBind (NonRec bndr rhs) = [(bndr, freeVars rhs)] - getBind (Rec binds) = [(bndr, freeVars rhs) | (bndr,rhs) <- binds] - final_state = runBc (BcM_State [] 0) - (mapBc schemeR flatBinds `thenBc_` returnBc ()) - in - case final_state of - BcM_State bcos final_ctr -> bcos -\end{code} - - %************************************************************************ %* * -\subsection{Bytecodes, and Outputery.} +\subsection{Functions visible from outside this module.} %* * %************************************************************************ \begin{code} -type LocalLabel = Int - -data BCInstr - -- Messing with the stack - = ARGCHECK Int - | PUSH_L Int{-offset-} - | PUSH_G Name - | PUSH_AS 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 -- unpack N ptr words from t.o.s Constr - | UNPACK_I Int -- unpack and tag an Int, from t.o.s Constr @ offset - | UNPACK_F Int -- unpack and tag a Float, from t.o.s Constr @ offset - | UNPACK_D Int -- unpack and tag a Double, from t.o.s Constr @ offset - | 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 (PUSH_AS nm) = text "PUSH_AS " <+> 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 (UNPACK_I sz) = text "UNPACK_I" <+> int sz - ppr (UNPACK_F sz) = text "UNPACK_F" <+> int sz - ppr (UNPACK_D sz) = text "UNPACK_D" <+> int sz - ppr (PACK dcon sz) = text "PACK " <+> ppr dcon <+> ppr sz - ppr (LABEL lab) = text "__" <> int lab <> colon - ppr (TESTLT_I i lab) = text "TESTLT_I" <+> int i <+> text "__" <> int lab - ppr (TESTEQ_I i lab) = text "TESTEQ_I" <+> int i <+> text "__" <> int lab - ppr (TESTLT_F f lab) = text "TESTLT_F" <+> float f <+> text "__" <> int lab - ppr (TESTEQ_F f lab) = text "TESTEQ_F" <+> float f <+> text "__" <> int lab - ppr (TESTLT_D d lab) = text "TESTLT_D" <+> double d <+> text "__" <> int lab - ppr (TESTEQ_D d lab) = text "TESTEQ_D" <+> double d <+> text "__" <> int lab - ppr (TESTLT_P i lab) = text "TESTLT_P" <+> int i <+> text "__" <> int lab - ppr (TESTEQ_P i lab) = text "TESTEQ_P" <+> int i <+> text "__" <> int lab - ppr CASEFAIL = text "CASEFAIL" - ppr ENTER = text "ENTER" - -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) +byteCodeGen :: DynFlags + -> [CoreBind] + -> [TyCon] -> [Class] + -> IO ([UnlinkedBCO], ItblEnv) +byteCodeGen dflags binds local_tycons local_classes + = do showPass dflags "ByteCodeGen" + let tycs = local_tycons ++ map classTyCon local_classes + itblenv <- mkITbls tycs + + let flatBinds = concatMap getBind binds + getBind (NonRec bndr rhs) = [(bndr, freeVars rhs)] + getBind (Rec binds) = [(bndr, freeVars rhs) | (bndr,rhs) <- binds] + + (BcM_State proto_bcos final_ctr mallocd, ()) + <- runBc (BcM_State [] 0 []) + (mapBc (schemeR True) flatBinds `thenBc_` returnBc ()) + + when (not (null mallocd)) + (panic "ByteCodeGen.byteCodeGen: missing final emitBc?") + + dumpIfSet_dyn dflags Opt_D_dump_BCOs + "Proto-bcos" (vcat (intersperse (char ' ') (map ppr proto_bcos))) + + bcos <- mapM assembleBCO proto_bcos + + return (bcos, itblenv) + + +-- Returns: (the root BCO for this expression, +-- a list of auxilary BCOs resulting from compiling closures) +coreExprToBCOs :: DynFlags + -> CoreExpr + -> IO UnlinkedBCOExpr +coreExprToBCOs dflags expr + = do showPass dflags "ByteCodeGen" + + -- create a totally bogus name for the top-level BCO; this + -- should be harmless, since it's never used for anything + let invented_id = mkSysLocal SLIT("Expr-Top-Level") (mkPseudoUnique3 0) + (panic "invented_id's type") + let invented_name = idName invented_id + + (BcM_State all_proto_bcos final_ctr mallocd, ()) + <- runBc (BcM_State [] 0 []) + (schemeR True (invented_id, freeVars expr)) + + when (not (null mallocd)) + (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?") + + dumpIfSet_dyn dflags Opt_D_dump_BCOs + "Proto-bcos" (vcat (intersperse (char ' ') (map ppr all_proto_bcos))) + + let root_proto_bco + = case filter ((== invented_name).nameOfProtoBCO) all_proto_bcos of + [root_bco] -> root_bco + auxiliary_proto_bcos + = filter ((/= invented_name).nameOfProtoBCO) all_proto_bcos + + auxiliary_bcos <- mapM assembleBCO auxiliary_proto_bcos + root_bco <- assembleBCO root_proto_bco + + return (root_bco, auxiliary_bcos) \end{code} %************************************************************************ @@ -148,44 +148,119 @@ instance Outputable a => Outputable (ProtoBCO a) where type BCInstrList = OrdList BCInstr -data ProtoBCO a - = ProtoBCO a -- name, in some sense - BCInstrList -- instrs - -- what the BCO came from - (Either [AnnAlt Id VarSet] - (AnnExpr Id VarSet)) - - type Sequel = Int -- back off to this depth before ENTER -- Maps Ids to the offset from the stack _base_ so we don't have -- to mess with it after each push/pop. type BCEnv = FiniteMap Id Int -- To find vars on the stack +ppBCEnv :: BCEnv -> SDoc +ppBCEnv p + = text "begin-env" + $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (fmToList p)))) + $$ text "end-env" + where + pp_one (var, offset) = int offset <> colon <+> ppr var + cmp_snd x y = compare (snd x) (snd y) + +-- Create a BCO and do a spot of peephole optimisation on the insns +-- at the same time. +mkProtoBCO nm instrs_ordlist origin mallocd_blocks + = ProtoBCO nm maybe_with_stack_check origin mallocd_blocks + where + -- Overestimate the stack usage (in words) of this BCO, + -- and if >= iNTERP_STACK_CHECK_THRESH, add an explicit + -- stack check. (The interpreter always does a stack check + -- for iNTERP_STACK_CHECK_THRESH words at the start of each + -- BCO anyway, so we only need to add an explicit on in the + -- (hopefully rare) cases when the (overestimated) stack use + -- exceeds iNTERP_STACK_CHECK_THRESH. + maybe_with_stack_check + | stack_overest >= 65535 + = pprPanic "mkProtoBCO: stack use won't fit in 16 bits" + (int stack_overest) + | stack_overest >= iNTERP_STACK_CHECK_THRESH + = (STKCHECK stack_overest) : peep_d + | otherwise + = peep_d -- the supposedly common case + + stack_overest = sum (map bciStackUse peep_d) + + 10 {- just to be really really sure -} + + + -- Merge local pushes + peep_d = peep (fromOL instrs_ordlist) + + peep (PUSH_L off1 : PUSH_L off2 : PUSH_L off3 : rest) + = PUSH_LLL off1 (off2-1) (off3-2) : peep rest + peep (PUSH_L off1 : PUSH_L off2 : rest) + = PUSH_LL off1 (off2-1) : peep rest + peep (i:rest) + = i : peep rest + peep [] + = [] -- Compile code for the right hand side of a let binding. -- Park the resulting BCO in the monad. Also requires the -- variable to which this value was bound, so as to give the --- resulting BCO a name. -schemeR :: (Id, AnnExpr Id VarSet) -> BcM () -schemeR (nm, rhs) = schemeR_wrk rhs nm (collect [] rhs) +-- resulting BCO a name. Bool indicates top-levelness. + +schemeR :: Bool -> (Id, AnnExpr Id VarSet) -> BcM () +schemeR is_top (nm, rhs) +{- + | trace (showSDoc ( + (char ' ' + $$ (ppr.filter (not.isTyVar).varSetElems.fst) rhs + $$ pprCoreExpr (deAnnotate rhs) + $$ char ' ' + ))) False + = undefined +-} + | otherwise + = schemeR_wrk is_top rhs nm (collect [] rhs) + +collect xs (_, AnnNote note e) + = collect xs e collect xs (_, AnnLam x e) = collect (if isTyVar x then xs else (x:xs)) e collect xs not_lambda = (reverse xs, not_lambda) -schemeR_wrk original_body nm (args, body) +schemeR_wrk is_top original_body nm (args, body) + | Just dcon <- maybe_toplevel_null_con_rhs + = --trace ("nullary constructor! " ++ showSDocDebug (ppr nm)) ( + emitBc (mkProtoBCO (getName nm) (toOL [PACK dcon 0, ENTER]) + (Right original_body)) + --) + + | otherwise = let fvs = filter (not.isTyVar) (varSetElems (fst original_body)) - all_args = fvs ++ reverse args + all_args = reverse args ++ fvs szsw_args = map taggedIdSizeW all_args szw_args = sum szsw_args p_init = listToFM (zip all_args (mkStackOffsets 0 szsw_args)) - argcheck = if null args then nilOL else unitOL (ARGCHECK szw_args) + argcheck = unitOL (ARGCHECK szw_args) in schemeE szw_args 0 p_init body `thenBc` \ body_code -> - emitBc (ProtoBCO (getName nm) (appOL argcheck body_code) (Right original_body)) + emitBc (mkProtoBCO (getName nm) (appOL argcheck body_code) + (Right original_body)) + + where + maybe_toplevel_null_con_rhs + | is_top && null args + = case snd body of + AnnVar v_wrk + -> case isDataConId_maybe v_wrk of + Nothing -> Nothing + Just dc_wrk | nm == dataConWrapId dc_wrk + -> Just dc_wrk + | otherwise + -> Nothing + other -> Nothing + | otherwise + = Nothing -- 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 @@ -200,15 +275,36 @@ schemeE :: Int -> Sequel -> BCEnv -> AnnExpr Id VarSet -> BcM BCInstrList -- Delegate tail-calls to schemeT. schemeE d s p e@(fvs, AnnApp f a) - = returnBc (schemeT (should_args_be_tagged e) d s 0 p (fvs, AnnApp f a)) + = schemeT d s p (fvs, AnnApp f a) + schemeE d s p e@(fvs, AnnVar v) - = returnBc (schemeT (should_args_be_tagged e) d s 0 p (fvs, AnnVar v)) + | isFollowableRep v_rep + = -- Ptr-ish thing; push it in the normal way + schemeT d s p (fvs, AnnVar v) + + | otherwise + = -- returning an unboxed value. Heave it on the stack, SLIDE, and RETURN. + pushAtom True d p (AnnVar v) `thenBc` \ (push, szw) -> + returnBc (push -- value onto stack + `appOL` mkSLIDE szw (d-s) -- clear to sequel + `snocOL` RETURN v_rep) -- go + where + v_rep = typePrimRep (idType v) + +schemeE d s p (fvs, AnnLit literal) + = pushAtom True d p (AnnLit literal) `thenBc` \ (push, szw) -> + let l_rep = literalPrimRep literal + in returnBc (push -- value onto stack + `appOL` mkSLIDE szw (d-s) -- clear to sequel + `snocOL` RETURN l_rep) -- go schemeE d s p (fvs, AnnLet binds b) = let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs]) AnnRec xs_n_rhss -> unzip xs_n_rhss n = length xs fvss = map (filter (not.isTyVar).varSetElems.fst) rhss + + -- Sizes of tagged free vars, + 1 for the fn sizes = map (\rhs_fvs -> 1 + sum (map taggedIdSizeW rhs_fvs)) fvss -- This p', d' defn is safe because all the items being pushed @@ -224,22 +320,80 @@ schemeE d s p (fvs, AnnLet binds b) -- ToDo: don't build thunks for things with no free variables buildThunk dd ([], size, id, off) - = PUSH_G (getName id) - `consOL` unitOL (MKAP (off+size-1) size) + = returnBc (PUSH_G (Left (getName id)) + `consOL` unitOL (MKAP (off+size-1) size)) buildThunk dd ((fv:fvs), size, id, off) - = case pushAtom True dd p' (AnnVar fv) of - (push_code, pushed_szw) - -> push_code `appOL` - buildThunk (dd+pushed_szw) (fvs, size, id, off) + = pushAtom True dd p' (AnnVar fv) + `thenBc` \ (push_code, pushed_szw) -> + buildThunk (dd+pushed_szw) (fvs, size, id, off) + `thenBc` \ more_push_code -> + returnBc (push_code `appOL` more_push_code) + + genThunkCode = mapBc (buildThunk d') infos `thenBc` \ tcodes -> + returnBc (concatOL tcodes) - thunkCode = concatOL (map (buildThunk d') infos) allocCode = toOL (map ALLOC sizes) in schemeE d' s p' b `thenBc` \ bodyCode -> - mapBc schemeR (zip xs rhss) `thenBc_` + mapBc (schemeR False) (zip xs rhss) `thenBc_` + genThunkCode `thenBc` \ thunkCode -> returnBc (allocCode `appOL` thunkCode `appOL` bodyCode) + + + +schemeE d s p (fvs_case, AnnCase (fvs_scrut, scrut) bndr + [(DEFAULT, [], (fvs_rhs, rhs))]) + + | let isFunType var_type + = case splitTyConApp_maybe var_type of + Just (tycon,_) | isFunTyCon tycon -> True + _ -> False + ty_bndr = repType (idType bndr) + in isFunType ty_bndr || isTyVarTy ty_bndr + + -- Nasty hack; treat + -- case scrut::suspect of bndr { DEFAULT -> rhs } + -- as + -- let bndr = scrut in rhs + -- when suspect is polymorphic or arrowtyped + -- So the required strictness properties are not observed. + -- At some point, must fix this properly. + = let new_expr + = (fvs_case, + AnnLet + (AnnNonRec bndr (fvs_scrut, scrut)) (fvs_rhs, rhs) + ) + + in trace ("WARNING: ignoring polymorphic case in interpreted mode.\n" ++ + " Possibly due to strict polymorphic/functional constructor args.\n" ++ + " Your program may leak space unexpectedly.\n") + (schemeE d s p new_expr) + + + +{- Convert case .... of (# VoidRep'd-thing, a #) -> ... + as + case .... of a -> ... + Use a as the name of the binder too. + + Also case .... of (# a #) -> ... + to + case .... of a -> ... +-} +schemeE d s p (fvs, AnnCase scrut bndr [(DataAlt dc, [bind1, bind2], rhs)]) + | isUnboxedTupleCon dc && VoidRep == typePrimRep (idType bind1) + = --trace "automagic mashing of case alts (# VoidRep, a #)" ( + schemeE d s p (fvs, AnnCase scrut bind2 [(DEFAULT, [bind2], rhs)]) + --) + +schemeE d s p (fvs, AnnCase scrut bndr [(DataAlt dc, [bind1], rhs)]) + | isUnboxedTupleCon dc + = --trace "automagic mashing of case alts (# a #)" ( + schemeE d s p (fvs, AnnCase scrut bind1 [(DEFAULT, [bind1], rhs)]) + --) + schemeE d s p (fvs, AnnCase scrut bndr alts) = let -- Top of stack is the return itbl, as usual. @@ -253,35 +407,43 @@ schemeE d s p (fvs, AnnCase scrut bndr alts) d' = d + ret_frame_sizeW + taggedIdSizeW bndr p' = addToFM p bndr (d' - 1) + scrut_primrep = typePrimRep (idType bndr) isAlgCase - = case typePrimRep (idType bndr) of - IntRep -> False ; FloatRep -> False ; DoubleRep -> False - PtrRep -> True - other -> pprPanic "ByteCodeGen.schemeE" (ppr other) + | scrut_primrep == PtrRep + = True + | scrut_primrep `elem` + [CharRep, AddrRep, WordRep, IntRep, FloatRep, DoubleRep, + VoidRep, Int8Rep, Int16Rep, Int32Rep, Int64Rep, + Word8Rep, Word16Rep, Word32Rep, Word64Rep] + = False + | otherwise + = pprPanic "ByteCodeGen.schemeE" (ppr scrut_primrep) -- given an alt, return a discr and code for it. codeAlt alt@(discr, binds_f, rhs) | isAlgCase - = let binds_r = reverse binds_f - binds_r_szsw = map untaggedIdSizeW binds_r - binds_szw = sum binds_r_szsw - p'' = addListToFM - p' (zip binds_r (mkStackOffsets d' binds_r_szsw)) - d'' = d' + binds_szw - unpack_code = mkUnpackCode 0 (map (typePrimRep.idType) binds_f) - in schemeE d'' s p'' rhs `thenBc` \ rhs_code -> - returnBc (my_discr alt, unpack_code `appOL` rhs_code) + = let (unpack_code, d_after_unpack, p_after_unpack) + = mkUnpackCode (filter (not.isTyVar) binds_f) d' p' + in schemeE d_after_unpack s p_after_unpack rhs + `thenBc` \ rhs_code -> + returnBc (my_discr alt, unpack_code `appOL` rhs_code) | otherwise = ASSERT(null binds_f) schemeE d' s p' rhs `thenBc` \ rhs_code -> returnBc (my_discr alt, rhs_code) - my_discr (DEFAULT, binds, rhs) = NoDiscr - my_discr (DataAlt dc, binds, rhs) = DiscrP (dataConTag dc) + my_discr (DEFAULT, binds, rhs) = NoDiscr + my_discr (DataAlt dc, binds, rhs) + | isUnboxedTupleCon dc + = unboxedTupleException + | otherwise + = DiscrP (dataConTag dc - fIRST_TAG) my_discr (LitAlt l, binds, rhs) = case l of MachInt i -> DiscrI (fromInteger i) MachFloat r -> DiscrF (fromRational r) MachDouble r -> DiscrD (fromRational r) + MachChar i -> DiscrI i + _ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l) maybe_ncons | not isAlgCase = Nothing @@ -294,14 +456,15 @@ schemeE d s p (fvs, AnnCase scrut bndr alts) mapBc codeAlt alts `thenBc` \ alt_stuff -> mkMultiBranch maybe_ncons alt_stuff `thenBc` \ alt_final -> let + alt_final_ac = ARGCHECK (taggedIdSizeW bndr) `consOL` alt_final alt_bco_name = getName bndr - alt_bco = ProtoBCO alt_bco_name alt_final (Left alts) + alt_bco = mkProtoBCO alt_bco_name alt_final_ac (Left alts) in schemeE (d + ret_frame_sizeW) (d + ret_frame_sizeW) p scrut `thenBc` \ scrut_code -> emitBc alt_bco `thenBc_` - returnBc (PUSH_AS alt_bco_name `consOL` scrut_code) + returnBc (PUSH_AS alt_bco_name scrut_primrep `consOL` scrut_code) schemeE d s p (fvs, AnnNote note body) @@ -312,63 +475,510 @@ schemeE d s p other (pprCoreExpr (deAnnotate other)) --- Compile code to do a tail call. Doesn't need to be monadic. -schemeT :: Bool -- do tagging? - -> Int -- Stack depth +-- Compile code to do a tail call. Specifically, push the fn, +-- slide the on-stack app back down to the sequel depth, +-- and enter. Four cases: +-- +-- 0. (Nasty hack). +-- An application "PrelGHC.tagToEnum# unboxed-int". +-- The int will be on the stack. Generate a code sequence +-- to convert it to the relevant constructor, SLIDE and ENTER. +-- +-- 1. A nullary constructor. Push its closure on the stack +-- and SLIDE and RETURN. +-- +-- 2. (Another nasty hack). Spot (# a::VoidRep, b #) and treat +-- it simply as b -- since the representations are identical +-- (the VoidRep takes up zero stack space). Also, spot +-- (# b #) and treat it as b. +-- +-- 3. Application of a non-nullary constructor, by defn saturated. +-- Split the args into ptrs and non-ptrs, and push the nonptrs, +-- then the ptrs, and then do PACK and RETURN. +-- +-- 4. Otherwise, it must be a function call. Push the args +-- right to left, SLIDE and ENTER. + +schemeT :: Int -- Stack depth -> Sequel -- Sequel depth - -> Int -- # arg words so far -> BCEnv -- stack env - -> AnnExpr Id VarSet -> BCInstrList - -schemeT enTag d s narg_words p (_, AnnApp f a) - = case snd a of - AnnType _ -> schemeT enTag d s narg_words p f - other - -> let (push, arg_words) = pushAtom enTag d p (snd a) - in push - `appOL` schemeT enTag (d+arg_words) s (narg_words+arg_words) p f - -schemeT enTag d s narg_words p (_, AnnVar f) - | Just con <- isDataConId_maybe f - = ASSERT(enTag == False) - PACK con narg_words `consOL` (mkSLIDE 1 (d-s-1) `snocOL` ENTER) - | otherwise - = ASSERT(enTag == True) - let (push, arg_words) = pushAtom True d p (AnnVar f) - in push - `appOL` mkSLIDE (narg_words+arg_words) (d - s - narg_words) - `snocOL` ENTER - -mkSLIDE n d - = if d == 0 then nilOL else unitOL (SLIDE n d) - -should_args_be_tagged (_, AnnVar v) - = case isDataConId_maybe v of - Just dcon -> False; Nothing -> True -should_args_be_tagged (_, AnnApp f a) - = should_args_be_tagged f -should_args_be_tagged (_, other) - = panic "should_args_be_tagged: tail call to non-con, non-var" - - --- Make code to unpack a constructor onto the stack, adding --- tags for the unboxed bits. Takes the PrimReps of the constructor's --- arguments, and a travelling offset along the *constructor*. -mkUnpackCode :: Int -> [PrimRep] -> BCInstrList -mkUnpackCode off [] = nilOL -mkUnpackCode off (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) - UNPACK ptrs_szw `consOL` mkUnpackCode (off+ptrs_szw) rs_nptr + -> AnnExpr Id VarSet + -> BcM BCInstrList + +schemeT d s p app + +-- | trace ("schemeT: env in = \n" ++ showSDocDebug (ppBCEnv p)) False +-- = panic "schemeT ?!?!" + +-- | trace ("\nschemeT\n" ++ showSDoc (pprCoreExpr (deAnnotate app)) ++ "\n") False +-- = error "?!?!" + + -- Handle case 0 + | Just (arg, constr_names) <- maybe_is_tagToEnum_call + = pushAtom True d p arg `thenBc` \ (push, arg_words) -> + implement_tagToId constr_names `thenBc` \ tagToId_sequence -> + returnBc (push `appOL` tagToId_sequence + `appOL` mkSLIDE 1 (d+arg_words-s) + `snocOL` ENTER) + + -- Handle case 1 + | is_con_call && null args_r_to_l + = returnBc ( + (PUSH_G (Left (getName con)) `consOL` mkSLIDE 1 (d-s)) + `snocOL` ENTER + ) + + -- Handle case 2 + | let isVoidRepAtom (_, AnnVar v) = VoidRep == typePrimRep (idType v) + isVoidRepAtom (_, AnnNote n e) = isVoidRepAtom e + in is_con_call && isUnboxedTupleCon con + && ( (length args_r_to_l == 2 && isVoidRepAtom (last (args_r_to_l))) + || (length args_r_to_l == 1) + ) + = --trace (if length args_r_to_l == 1 + -- then "schemeT: unboxed singleton" + -- else "schemeT: unboxed pair with Void first component") ( + schemeT d s p (head args_r_to_l) + --) + + | Just (CCall ccall_spec) <- isFCallId_maybe fn + = generateCCall d s p ccall_spec fn args_r_to_l + + -- Cases 3 and 4 | otherwise - = case r of - IntRep -> UNPACK_I off `consOL` theRest - FloatRep -> UNPACK_F off `consOL` theRest - DoubleRep -> UNPACK_D off `consOL` theRest + = if is_con_call && isUnboxedTupleCon con + then unboxedTupleException + else do_pushery d (map snd args_final_r_to_l) + + where + -- Detect and extract relevant info for the tagToEnum kludge. + maybe_is_tagToEnum_call + = let extract_constr_Names ty + = case splitTyConApp_maybe (repType ty) of + (Just (tyc, [])) | isDataTyCon tyc + -> map getName (tyConDataCons tyc) + other -> panic "maybe_is_tagToEnum_call.extract_constr_Ids" + in + case app of + (_, AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg) + -> case isPrimOpId_maybe v of + Just TagToEnumOp -> Just (snd arg, extract_constr_Names t) + other -> Nothing + other -> Nothing + + -- Extract the args (R->L) and fn + (args_r_to_l_raw, fn) = chomp app + chomp expr + = case snd expr of + AnnVar v -> ([], v) + AnnApp f a -> case chomp f of (az, f) -> (a:az, f) + AnnNote n e -> chomp e + other -> pprPanic "schemeT" + (ppr (deAnnotate (panic "schemeT.chomp", other))) + + args_r_to_l = filter (not.isTypeAtom.snd) args_r_to_l_raw + isTypeAtom (AnnType _) = True + isTypeAtom _ = False + + -- decide if this is a constructor call, and rearrange + -- args appropriately. + maybe_dcon = isDataConId_maybe fn + is_con_call = case maybe_dcon of Nothing -> False; Just _ -> True + (Just con) = maybe_dcon + + args_final_r_to_l + | not is_con_call + = args_r_to_l + | otherwise + = filter (not.isPtr.snd) args_r_to_l ++ filter (isPtr.snd) args_r_to_l + where isPtr = isFollowableRep . atomRep + + -- make code to push the args and then do the SLIDE-ENTER thing + tag_when_push = not is_con_call + narg_words = sum (map (get_arg_szw . atomRep . snd) args_r_to_l) + get_arg_szw = if tag_when_push then taggedSizeW else untaggedSizeW + + do_pushery d (arg:args) + = pushAtom tag_when_push d p arg `thenBc` \ (push, arg_words) -> + do_pushery (d+arg_words) args `thenBc` \ more_push_code -> + returnBc (push `appOL` more_push_code) + do_pushery d [] + | Just (CCall ccall_spec) <- isFCallId_maybe fn + = panic "schemeT.do_pushery: unexpected ccall" + | otherwise + = case maybe_dcon of + Just con -> returnBc ( + (PACK con narg_words `consOL` + mkSLIDE 1 (d - narg_words - s)) `snocOL` + ENTER + ) + Nothing + -> pushAtom True d p (AnnVar fn) + `thenBc` \ (push, arg_words) -> + returnBc (push `appOL` mkSLIDE (narg_words+arg_words) + (d - s - narg_words) + `snocOL` ENTER) + + + +{- Deal with a CCall. Taggedly push the args onto the stack R->L, + deferencing ForeignObj#s and (ToDo: adjusting addrs to point to + payloads in Ptr/Byte arrays). Then, generate the marshalling + (machine) code for the ccall, and create bytecodes to call that and + then return in the right way. +-} +generateCCall :: Int -> Sequel -- stack and sequel depths + -> BCEnv + -> CCallSpec -- where to call + -> Id -- of target, for type info + -> [AnnExpr Id VarSet] -- args (atoms) + -> BcM BCInstrList + +generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l + = let + -- useful constants + addr_usizeW = untaggedSizeW AddrRep + addr_tsizeW = taggedSizeW AddrRep + + -- Get the args on the stack, with tags and suitably + -- dereferenced for the CCall. For each arg, return the + -- depth to the first word of the bits for that arg, and the + -- PrimRep of what was actually pushed. + + pargs d [] = returnBc [] + pargs d ((_,a):az) + = let rep_arg = atomRep a + in case rep_arg of + -- Don't push the FO; instead push the Addr# it + -- contains. + ForeignObjRep + -> pushAtom False{-irrelevant-} d p a + `thenBc` \ (push_fo, _) -> + let foro_szW = taggedSizeW ForeignObjRep + d_now = d + addr_tsizeW + code = push_fo `appOL` toOL [ + UPK_TAG addr_usizeW 0 0, + SLIDE addr_tsizeW foro_szW + ] + in pargs d_now az `thenBc` \ rest -> + returnBc ((code, AddrRep) : rest) + + ArrayRep + -> pargs (d + addr_tsizeW) az `thenBc` \ rest -> + parg_ArrayishRep arrPtrsHdrSize d p a + `thenBc` \ code -> + returnBc ((code,AddrRep):rest) + + ByteArrayRep + -> pargs (d + addr_tsizeW) az `thenBc` \ rest -> + parg_ArrayishRep arrWordsHdrSize d p a + `thenBc` \ code -> + returnBc ((code,AddrRep):rest) + + -- Default case: push taggedly, but otherwise intact. + other + -> pushAtom True d p a `thenBc` \ (code_a, sz_a) -> + pargs (d+sz_a) az `thenBc` \ rest -> + returnBc ((code_a, rep_arg) : rest) + + -- Do magic for Ptr/Byte arrays. Push a ptr to the array on + -- the stack but then advance it over the headers, so as to + -- point to the payload. + parg_ArrayishRep hdrSizeW d p a + = pushAtom False{-irrel-} d p a `thenBc` \ (push_fo, _) -> + -- The ptr points at the header. Advance it over the + -- header and then pretend this is an Addr# (push a tag). + returnBc (push_fo `snocOL` + SWIZZLE 0 (hdrSizeW * untaggedSizeW PtrRep + * wORD_SIZE) + `snocOL` + PUSH_TAG addr_usizeW) + + in + pargs d0 args_r_to_l `thenBc` \ code_n_reps -> + let + (pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps + + push_args = concatOL pushs_arg + d_after_args = d0 + sum (map taggedSizeW a_reps_pushed_r_to_l) + a_reps_pushed_RAW + | null a_reps_pushed_r_to_l || head a_reps_pushed_r_to_l /= VoidRep + = panic "ByteCodeGen.generateCCall: missing or invalid World token?" + | otherwise + = reverse (tail a_reps_pushed_r_to_l) + + -- Now: a_reps_pushed_RAW are the reps which are actually on the stack. + -- push_args is the code to do that. + -- d_after_args is the stack depth once the args are on. + + -- Get the result rep. + (returns_void, r_rep) + = case maybe_getCCallReturnRep (idType fn) of + Nothing -> (True, VoidRep) + Just rr -> (False, rr) + {- + Because the Haskell stack grows down, the a_reps refer to + lowest to highest addresses in that order. The args for the call + are on the stack. Now push an unboxed, tagged Addr# indicating + the C function to call. Then push a dummy placeholder for the + result. Finally, emit a CCALL insn with an offset pointing to the + Addr# just pushed, and a literal field holding the mallocville + address of the piece of marshalling code we generate. + So, just prior to the CCALL insn, the stack looks like this + (growing down, as usual): + + + ... + + Addr# address_of_C_fn + (must be an unboxed type) + + The interpreter then calls the marshall code mentioned + in the CCALL insn, passing it (& ), + that is, the addr of the topmost word in the stack. + When this returns, the placeholder will have been + filled in. The placeholder is slid down to the sequel + depth, and we RETURN. + + This arrangement makes it simple to do f-i-dynamic since the Addr# + value is the first arg anyway. It also has the virtue that the + stack is GC-understandable at all times. + + The marshalling code is generated specifically for this + call site, and so knows exactly the (Haskell) stack + offsets of the args, fn address and placeholder. It + copies the args to the C stack, calls the stacked addr, + and parks the result back in the placeholder. The interpreter + calls it as a normal C call, assuming it has a signature + void marshall_code ( StgWord* ptr_to_top_of_stack ) + -} + -- resolve static address + get_target_info + = case target of + DynamicTarget + -> returnBc (False, panic "ByteCodeGen.generateCCall(dyn)") + StaticTarget target + -> ioToBc (lookupSymbol (_UNPK_ target)) `thenBc` \res -> + case res of + Just aa -> case aa of Ptr a# -> returnBc (True, A# a#) + Nothing -> returnBc invalid + CasmTarget _ + -> returnBc invalid + where + invalid = pprPanic ("ByteCodeGen.generateCCall: unfindable " + ++ "symbol or otherwise invalid target") + (ppr ccall_spec) + in + get_target_info `thenBc` \ (is_static, static_target_addr) -> + let + + -- Get the arg reps, zapping the leading Addr# in the dynamic case + a_reps -- | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???" + | is_static = a_reps_pushed_RAW + | otherwise = if null a_reps_pushed_RAW + then panic "ByteCodeGen.generateCCall: dyn with no args" + else tail a_reps_pushed_RAW + + -- push the Addr# + (push_Addr, d_after_Addr) + | is_static + = (toOL [PUSH_UBX (Right static_target_addr) addr_usizeW, + PUSH_TAG addr_usizeW], + d_after_args + addr_tsizeW) + | otherwise -- is already on the stack + = (nilOL, d_after_args) + + -- Push the return placeholder. For a call returning nothing, + -- this is a VoidRep (tag). + r_usizeW = untaggedSizeW r_rep + r_tsizeW = taggedSizeW r_rep + d_after_r = d_after_Addr + r_tsizeW + r_lit = mkDummyLiteral r_rep + push_r = (if returns_void + then nilOL + else unitOL (PUSH_UBX (Left r_lit) r_usizeW)) + `appOL` + unitOL (PUSH_TAG r_usizeW) + + -- generate the marshalling code we're going to call + r_offW = 0 + addr_offW = r_tsizeW + arg1_offW = r_tsizeW + addr_tsizeW + args_offW = map (arg1_offW +) + (init (scanl (+) 0 (map taggedSizeW a_reps))) + in + ioToBc (mkMarshalCode cconv + (r_offW, r_rep) addr_offW + (zip args_offW a_reps)) `thenBc` \ addr_of_marshaller -> + recordMallocBc addr_of_marshaller `thenBc_` + let + -- do the call + do_call = unitOL (CCALL addr_of_marshaller) + -- slide and return + wrapup = mkSLIDE r_tsizeW (d_after_r - r_tsizeW - s) + `snocOL` RETURN r_rep + in + --trace (show (arg1_offW, args_offW , (map taggedSizeW a_reps) )) ( + returnBc ( + push_args `appOL` + push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup + ) + --) + + +-- Make a dummy literal, to be used as a placeholder for FFI return +-- values on the stack. +mkDummyLiteral :: PrimRep -> Literal +mkDummyLiteral pr + = case pr of + IntRep -> MachInt 0 + DoubleRep -> MachDouble 0 + FloatRep -> MachFloat 0 + AddrRep | taggedSizeW AddrRep == taggedSizeW WordRep -> MachWord 0 + _ -> pprPanic "mkDummyLiteral" (ppr pr) + + +-- Convert (eg) +-- PrelGHC.Char# -> PrelGHC.State# PrelGHC.RealWorld +-- -> (# PrelGHC.State# PrelGHC.RealWorld, PrelGHC.Int# #) +-- +-- to Just IntRep +-- and check that an unboxed pair is returned wherein the first arg is VoidRep'd. +-- +-- Alternatively, for call-targets returning nothing, convert +-- +-- PrelGHC.Char# -> PrelGHC.State# PrelGHC.RealWorld +-- -> (# PrelGHC.State# PrelGHC.RealWorld #) +-- +-- to Nothing + +maybe_getCCallReturnRep :: Type -> Maybe PrimRep +maybe_getCCallReturnRep fn_ty + = let (a_tys, r_ty) = splitRepFunTys fn_ty + maybe_r_rep_to_go + = if length r_reps == 1 then Nothing else Just (r_reps !! 1) + (r_tycon, r_reps) + = case splitTyConApp_maybe (repType r_ty) of + (Just (tyc, tys)) -> (tyc, map typePrimRep tys) + Nothing -> blargh + ok = ( (length r_reps == 2 && VoidRep == head r_reps) + || r_reps == [VoidRep] ) + && isUnboxedTupleTyCon r_tycon + && case maybe_r_rep_to_go of + Nothing -> True + Just r_rep -> r_rep /= PtrRep + -- if it was, it would be impossible + -- to create a valid return value + -- placeholder on the stack + blargh = pprPanic "maybe_getCCallReturn: can't handle:" + (pprType fn_ty) + in + --trace (showSDoc (ppr (a_reps, r_reps))) ( + if ok then maybe_r_rep_to_go else blargh + --) + +atomRep (AnnVar v) = typePrimRep (idType v) +atomRep (AnnLit l) = literalPrimRep l +atomRep (AnnNote n b) = atomRep (snd b) +atomRep (AnnApp f (_, AnnType _)) = atomRep (snd f) +atomRep (AnnLam x e) | isTyVar x = atomRep (snd e) +atomRep other = pprPanic "atomRep" (ppr (deAnnotate (undefined,other))) + + +-- Compile code which expects an unboxed Int on the top of stack, +-- (call it i), and pushes the i'th closure in the supplied list +-- as a consequence. +implement_tagToId :: [Name] -> BcM BCInstrList +implement_tagToId names + = ASSERT(not (null names)) + getLabelsBc (length names) `thenBc` \ labels -> + getLabelBc `thenBc` \ label_fail -> + getLabelBc `thenBc` \ label_exit -> + zip4 labels (tail labels ++ [label_fail]) + [0 ..] names `bind` \ infos -> + map (mkStep label_exit) infos `bind` \ steps -> + returnBc (concatOL steps + `appOL` + toOL [LABEL label_fail, CASEFAIL, LABEL label_exit]) + where + mkStep l_exit (my_label, next_label, n, name_for_n) + = toOL [LABEL my_label, + TESTEQ_I n next_label, + PUSH_G (Left name_for_n), + JMP l_exit] + + +-- Make code to unpack the top-of-stack constructor onto the stack, +-- adding tags for the unboxed bits. Takes the PrimReps of the +-- constructor's arguments. off_h and off_s are travelling offsets +-- along the constructor and the stack. +-- +-- Supposing a constructor in the heap has layout +-- +-- Itbl p_1 ... p_i np_1 ... np_j +-- +-- then we add to the stack, shown growing down, the following: +-- +-- (previous stack) +-- p_i +-- ... +-- p_1 +-- np_j +-- tag_for(np_j) +-- .. +-- np_1 +-- tag_for(np_1) +-- +-- so that in the common case (ptrs only) a single UNPACK instr can +-- copy all the payload of the constr onto the stack with no further ado. + +mkUnpackCode :: [Id] -- constr args + -> Int -- depth before unpack + -> BCEnv -- env before unpack + -> (BCInstrList, Int, BCEnv) +mkUnpackCode vars d p + = --trace ("mkUnpackCode: " ++ showSDocDebug (ppr vars) + -- ++ " --> " ++ show d' ++ "\n" ++ showSDocDebug (ppBCEnv p') + -- ++ "\n") ( + (code_p `appOL` code_np, d', p') + --) where - theRest = mkUnpackCode (off+untaggedSizeW r) rs + -- vars with reps + vreps = [(var, typePrimRep (idType var)) | var <- vars] + + -- ptrs and nonptrs, forward + vreps_p = filter (isFollowableRep.snd) vreps + vreps_np = filter (not.isFollowableRep.snd) vreps + + -- the order in which we will augment the environment + vreps_env = reverse vreps_p ++ reverse vreps_np + + -- new env and depth + vreps_env_tszsw = map (taggedSizeW.snd) vreps_env + p' = addListToFM p (zip (map fst vreps_env) + (mkStackOffsets d vreps_env_tszsw)) + d' = d + sum vreps_env_tszsw + + -- code to unpack the ptrs + ptrs_szw = sum (map (untaggedSizeW.snd) vreps_p) + code_p | null vreps_p = nilOL + | otherwise = unitOL (UNPACK ptrs_szw) + + -- code to unpack the nonptrs + vreps_env_uszw = sum (map (untaggedSizeW.snd) vreps_env) + code_np = do_nptrs vreps_env_uszw ptrs_szw (reverse (map snd vreps_np)) + do_nptrs off_h off_s [] = nilOL + do_nptrs off_h off_s (npr:nprs) + | npr `elem` [IntRep, WordRep, FloatRep, DoubleRep, CharRep, AddrRep] + = approved + | otherwise + = pprPanic "ByteCodeGen.mkUnpackCode" (ppr npr) + where + approved = UPK_TAG usizeW (off_h-usizeW) off_s `consOL` theRest + theRest = do_nptrs (off_h-usizeW) (off_s + tsizeW) nprs + usizeW = untaggedSizeW npr + tsizeW = taggedSizeW npr + -- Push an atom onto the stack, returning suitable code & number of -- stack words used. Pushes it either tagged or untagged, since @@ -394,44 +1004,110 @@ mkUnpackCode off (r:rs) -- 5 and not to 4. Stack locations are numbered from zero, so a depth -- 6 stack has valid words 0 .. 5. -pushAtom tagged d p (AnnVar v) - = let str = "\npushAtom " ++ showSDocDebug (ppr v) ++ ", depth = " ++ show d - ++ ", env =\n" ++ - showSDocDebug (nest 4 (vcat (map ppr (fmToList p)))) - ++ " -->\n" ++ +pushAtom :: Bool -> Int -> BCEnv -> AnnExpr' Id VarSet -> BcM (BCInstrList, Int) +pushAtom tagged d p (AnnVar v) + + | idPrimRep v == VoidRep + = if tagged then returnBc (unitOL (PUSH_TAG 0), 1) + else panic "ByteCodeGen.pushAtom(VoidRep,untaggedly)" + + | isFCallId v + = pprPanic "pushAtom: shouldn't get an FCallId here" (ppr v) + + | Just primop <- isPrimOpId_maybe v + = returnBc (unitOL (PUSH_G (Right primop)), 1) + + | otherwise + = let {- + str = "\npushAtom " ++ showSDocDebug (ppr v) + ++ " :: " ++ showSDocDebug (pprType (idType v)) + ++ ", depth = " ++ show d + ++ ", tagged = " ++ show tagged ++ ", env =\n" ++ + showSDocDebug (ppBCEnv p) + ++ " --> words: " ++ show (snd result) ++ "\n" ++ showSDoc (nest 4 (vcat (map ppr (fromOL (fst result))))) ++ "\nendPushAtom " ++ showSDocDebug (ppr v) - str' = if str == str then str else str + -} result = case lookupBCEnv_maybe p v of - Just d_v -> (toOL (nOfThem nwords (PUSH_L (d-d_v+sz_t-2))), sz_t) - Nothing -> ASSERT(sz_t == 1) (unitOL (PUSH_G nm), sz_t) + Just d_v -> (toOL (nOfThem nwords (PUSH_L (d-d_v+sz_t-2))), nwords) + Nothing -> ASSERT(sz_t == 1) (unitOL (PUSH_G (Left nm)), nwords) + + nm = case isDataConId_maybe v of + Just c -> getName c + Nothing -> getName v - nm = getName v sz_t = taggedIdSizeW v sz_u = untaggedIdSizeW v nwords = if tagged then sz_t else sz_u in - --trace str' - result + returnBc result pushAtom True d p (AnnLit lit) - = 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 False d p (AnnLit lit) `thenBc` \ (ubx_code, ubx_size) -> + returnBc (ubx_code `snocOL` PUSH_TAG ubx_size, 1 + ubx_size) pushAtom False d p (AnnLit lit) = case lit of - MachInt i -> (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) + MachWord w -> code WordRep + MachInt i -> code IntRep + MachFloat r -> code FloatRep + MachDouble r -> code DoubleRep + MachChar c -> code CharRep + MachStr s -> pushStr s + where + code rep + = let size_host_words = untaggedSizeW rep + in returnBc (unitOL (PUSH_UBX (Left lit) size_host_words), + size_host_words) + + pushStr s + = let getMallocvilleAddr + = case s of + CharStr s i -> returnBc (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. + let n = I# l + -- CAREFUL! Chars are 32 bits in ghc 4.09+ + in ioToBc (mallocBytes (n+1)) `thenBc` \ (Ptr a#) -> + recordMallocBc (A# a#) `thenBc_` + ioToBc ( + do strncpy (Ptr a#) ba (fromIntegral n) + writeCharOffAddr (A# a#) n '\0' + return (A# a#) + ) + other -> panic "ByteCodeGen.pushAtom.pushStr" + in + getMallocvilleAddr `thenBc` \ addr -> + -- Get the addr on the stack, untaggedly + returnBc (unitOL (PUSH_UBX (Right addr) 1), 1) + + + + + +pushAtom tagged d p (AnnApp f (_, AnnType _)) + = pushAtom tagged d p (snd f) + +pushAtom tagged d p (AnnNote note e) + = pushAtom tagged d p (snd e) + +pushAtom tagged d p (AnnLam x e) + | isTyVar x + = pushAtom tagged d p (snd e) pushAtom tagged d p other = pprPanic "ByteCodeGen.pushAtom" (pprCoreExpr (deAnnotate (undefined, other))) +foreign import "strncpy" strncpy :: 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. @@ -504,7 +1180,7 @@ mkMultiBranch maybe_ncons raw_ways (algMinBound, algMaxBound) = case maybe_ncons of - Just n -> (fIRST_TAG, fIRST_TAG + n - 1) + Just n -> (0, n - 1) Nothing -> (minBound, maxBound) (DiscrI i1) `eqAlt` (DiscrI i2) = i1 == i2 @@ -567,35 +1243,33 @@ instance Outputable Discr where -- Find things in the BCEnv (the what's-on-the-stack-env) -- See comment preceding pushAtom for precise meaning of env contents -lookupBCEnv :: BCEnv -> Id -> Int -lookupBCEnv env nm - = case lookupFM env nm of - Nothing -> pprPanic "lookupBCEnv" - (ppr nm $$ char ' ' $$ vcat (map ppr (fmToList env))) - Just xx -> xx +--lookupBCEnv :: BCEnv -> Id -> Int +--lookupBCEnv env nm +-- = case lookupFM env nm of +-- Nothing -> pprPanic "lookupBCEnv" +-- (ppr nm $$ char ' ' $$ vcat (map ppr (fmToList env))) +-- Just xx -> xx lookupBCEnv_maybe :: BCEnv -> Id -> Maybe Int lookupBCEnv_maybe = lookupFM --- When I push one of these on the stack, how much does Sp move by? -taggedSizeW :: PrimRep -> Int -taggedSizeW pr - | isFollowableRep pr = 1 - | otherwise = 1{-the tag-} + getPrimRepSize pr - - --- The plain size of something, without tag. -untaggedSizeW :: PrimRep -> Int -untaggedSizeW pr - | isFollowableRep pr = 1 - | otherwise = getPrimRepSize pr - - taggedIdSizeW, untaggedIdSizeW :: Id -> Int taggedIdSizeW = taggedSizeW . typePrimRep . idType untaggedIdSizeW = untaggedSizeW . typePrimRep . idType +unboxedTupleException :: a +unboxedTupleException + = throwDyn + (Panic + ("Bytecode generator can't handle unboxed tuples. Possibly due\n" ++ + "\tto foreign import/export decls in source. Workaround:\n" ++ + "\tcompile this module to a .o file, then restart session.")) + + +mkSLIDE n d = if d == 0 then nilOL else unitOL (SLIDE n d) +bind x f = f x + \end{code} %************************************************************************ @@ -607,26 +1281,34 @@ untaggedIdSizeW = untaggedSizeW . typePrimRep . idType \begin{code} data BcM_State = BcM_State { bcos :: [ProtoBCO Name], -- accumulates completed BCOs - nextlabel :: Int } -- for generating local labels - -type BcM result = BcM_State -> (result, BcM_State) + nextlabel :: Int, -- for generating local labels + malloced :: [Addr] } -- ptrs malloced for current BCO + -- Should be free()d when it is GCd +type BcM r = BcM_State -> IO (BcM_State, r) -mkBcM_State :: [ProtoBCO Name] -> Int -> BcM_State -mkBcM_State = BcM_State +ioToBc :: IO a -> BcM a +ioToBc io st = do x <- io + return (st, x) -runBc :: BcM_State -> BcM () -> BcM_State -runBc init_st m = case m init_st of { (r,st) -> st } +runBc :: BcM_State -> BcM r -> IO (BcM_State, r) +runBc st0 m = do (st1, res) <- m st0 + return (st1, res) thenBc :: BcM a -> (a -> BcM b) -> BcM b -thenBc expr cont st - = case expr st of { (result, st') -> cont result st' } +thenBc expr cont st0 + = do (st1, q) <- expr st0 + (st2, r) <- cont q st1 + return (st2, r) thenBc_ :: BcM a -> BcM b -> BcM b -thenBc_ expr cont st - = case expr st of { (result, st') -> cont st' } +thenBc_ expr cont st0 + = do (st1, q) <- expr st0 + (st2, r) <- cont st1 + return (st2, r) returnBc :: a -> BcM a -returnBc result st = (result, st) +returnBc result st = return (st, result) + mapBc :: (a -> BcM b) -> [a] -> BcM [b] mapBc f [] = returnBc [] @@ -635,284 +1317,28 @@ mapBc f (x:xs) mapBc f xs `thenBc` \ rs -> returnBc (r:rs) -emitBc :: ProtoBCO Name -> BcM () +emitBc :: ([Addr] -> 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} - -%************************************************************************ -%* * -\subsection{The bytecode assembler} -%* * -%************************************************************************ + = return (st{bcos = bco (malloced st) : bcos st, malloced=[]}, ()) -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. +newbcoBc :: BcM () +newbcoBc st + | not (null (malloced st)) + = panic "ByteCodeGen.newbcoBc: missed prior emitBc?" + | otherwise + = return (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] - ) +recordMallocBc :: Addr -> BcM () +recordMallocBc a st + = return (st{malloced = a : malloced st}, ()) -mkDLit d - = runST (do - arr <- newDoubleArray ((0::Int),0) - writeDoubleArray arr 0 d - w0 <- readWord32Array arr 0 - w1 <- readWord32Array arr 1 - return [w0,w1] - ) +getLabelBc :: BcM Int +getLabelBc st + = return (st{nextlabel = 1 + nextlabel st}, nextlabel st) -mkILit i - | wORD_SIZE == 4 - = runST (do - arr <- newIntArray ((0::Int),0) - writeIntArray arr 0 i - 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_PUSH_AS = (bci_PUSH_AS :: Int) -i_PUSHT_I = (bci_PUSHT_I :: Int) -i_PUSHT_F = (bci_PUSHT_F :: Int) -i_PUSHT_D = (bci_PUSHT_D :: Int) -i_PUSHU_I = (bci_PUSHU_I :: Int) -i_PUSHU_F = (bci_PUSHU_F :: Int) -i_PUSHU_D = (bci_PUSHU_D :: Int) -i_SLIDE = (bci_SLIDE :: Int) -i_ALLOC = (bci_ALLOC :: Int) -i_MKAP = (bci_MKAP :: Int) -i_UNPACK = (bci_UNPACK :: Int) -i_PACK = (bci_PACK :: Int) -i_LABEL = (bci_LABEL :: Int) -i_TESTLT_I = (bci_TESTLT_I :: Int) -i_TESTEQ_I = (bci_TESTEQ_I :: Int) -i_TESTLT_F = (bci_TESTLT_F :: Int) -i_TESTEQ_F = (bci_TESTEQ_F :: Int) -i_TESTLT_D = (bci_TESTLT_D :: Int) -i_TESTEQ_D = (bci_TESTEQ_D :: Int) -i_TESTLT_P = (bci_TESTLT_P :: Int) -i_TESTEQ_P = (bci_TESTEQ_P :: Int) -i_CASEFAIL = (bci_CASEFAIL :: Int) -i_ENTER = (bci_ENTER :: Int) +getLabelsBc :: Int -> BcM [Int] +getLabelsBc n st + = let ctr = nextlabel st + in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1]) \end{code}