X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FByteCodeGen.lhs;h=72f4d620435f42c8778a2940534d5083317d1cb8;hb=b7cc3d012a98cc49abb3441e6637d5148f57f1d1;hp=f6cf787493f313f95913187a0dfa6f09bbd3a52b;hpb=2cc5b907318f97e19b28b2ad8ed9ff8c1f401dcc;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index f6cf787..72f4d62 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -4,63 +4,67 @@ \section[ByteCodeGen]{Generate bytecode from Core} \begin{code} -module ByteCodeGen ( UnlinkedBCO, UnlinkedBCOExpr, ItblEnv, ClosureEnv, HValue, - filterNameMap, - byteCodeGen, coreExprToBCOs +module ByteCodeGen ( UnlinkedBCO, UnlinkedBCOExpr, + byteCodeGen, coreExprToBCOs ) where #include "HsVersions.h" +import ByteCodeInstr ( BCInstr(..), ProtoBCO(..), nameOfProtoBCO, bciStackUse ) +import ByteCodeFFI ( taggedSizeW, untaggedSizeW, mkMarshalCode, moan64 ) +import ByteCodeAsm ( CompiledByteCode(..), UnlinkedBCO, UnlinkedBCOExpr, + assembleBCO, assembleBCOs, iNTERP_STACK_CHECK_THRESH ) +import ByteCodeLink ( lookupStaticPtr ) + import Outputable -import Name ( Name, getName ) +import Name ( Name, getName, mkSystemName ) import Id ( Id, idType, isDataConId_maybe, isPrimOpId_maybe, isFCallId, - idPrimRep, mkSysLocal, idName, isFCallId_maybe, isPrimOpId ) + idPrimRep, mkLocalId, isFCallId_maybe, isPrimOpId ) import ForeignCall ( ForeignCall(..), CCallTarget(..), CCallSpec(..) ) import OrdList ( OrdList, consOL, snocOL, appOL, unitOL, nilOL, toOL, concatOL, fromOL ) import FiniteMap ( FiniteMap, addListToFM, listToFM, elemFM, addToFM, lookupFM, fmToList ) +import HscTypes ( ModGuts(..), ModGuts, typeEnvTyCons, typeEnvClasses ) +import CoreUtils ( exprType ) import CoreSyn import PprCore ( pprCoreExpr ) import Literal ( Literal(..), literalPrimRep ) import PrimRep ( PrimRep(..) ) import PrimOp ( PrimOp(..) ) import CoreFVs ( freeVars ) -import Type ( typePrimRep, splitTyConApp_maybe, isTyVarTy ) +import Type ( typePrimRep, isUnLiftedType, splitTyConApp_maybe, isTyVarTy ) import DataCon ( dataConTag, fIRST_TAG, dataConTyCon, dataConWrapId, isUnboxedTupleCon ) -import TyCon ( TyCon(..), tyConFamilySize, isDataTyCon, tyConDataCons, +import TyCon ( tyConFamilySize, isDataTyCon, tyConDataCons, isFunTyCon, isUnboxedTupleTyCon ) import Class ( Class, classTyCon ) -import Type ( Type, repType, splitRepFunTys ) +import Type ( Type, repType, splitFunTys, dropForAlls ) import Util ( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem, - isSingleton, lengthIs ) + isSingleton, lengthIs, notNull ) import DataCon ( dataConRepArity ) import Var ( isTyVar ) import VarSet ( VarSet, varSetElems ) +import TysPrim ( foreignObjPrimTyCon, + arrayPrimTyCon, mutableArrayPrimTyCon, + byteArrayPrimTyCon, mutableByteArrayPrimTyCon + ) import PrimRep ( isFollowableRep ) import CmdLineOpts ( DynFlags, DynFlag(..) ) import ErrUtils ( showPass, dumpIfSet_dyn ) import Unique ( mkPseudoUnique3 ) -import FastString ( FastString(..) ) +import FastString ( FastString(..), unpackFS ) import Panic ( GhcException(..) ) import PprType ( pprType ) import 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, linkFail, - iNTERP_STACK_CHECK_THRESH ) -import ByteCodeFFI ( taggedSizeW, untaggedSizeW, mkMarshalCode, moan64 ) -import Linker ( lookupSymbol ) import List ( intersperse, sortBy, zip4 ) -import Foreign ( Ptr(..), castPtr, mallocBytes, pokeByteOff, Word8 ) -import CTypes ( CInt ) -import Exception ( throwDyn ) +import Foreign ( Ptr, castPtr, mallocBytes, pokeByteOff, Word8 ) +import Foreign.C ( CInt ) +import Control.Exception ( throwDyn ) -import GlaExts ( Int(..), ByteArray# ) +import GHC.Exts ( Int(..), ByteArray# ) import Monad ( when ) import Maybe ( isJust ) @@ -76,13 +80,13 @@ import Char ( ord ) \begin{code} byteCodeGen :: DynFlags - -> [CoreBind] - -> [TyCon] -> [Class] - -> IO ([UnlinkedBCO], ItblEnv) -byteCodeGen dflags binds local_tycons local_classes + -> ModGuts + -> IO CompiledByteCode +byteCodeGen dflags (ModGuts { mg_binds = binds, mg_types = type_env }) = do showPass dflags "ByteCodeGen" - let tycs = local_tycons ++ map classTyCon local_classes - itblenv <- mkITbls tycs + let local_tycons = typeEnvTyCons type_env + local_classes = typeEnvClasses type_env + tycs = local_tycons ++ map classTyCon local_classes let flatBinds = concatMap getBind binds getBind (NonRec bndr rhs) = [(bndr, freeVars rhs)] @@ -94,15 +98,13 @@ byteCodeGen dflags binds local_tycons local_classes -- ^^ -- better be no free vars in these top-level bindings - when (not (null mallocd)) + when (notNull mallocd) (panic "ByteCodeGen.byteCodeGen: missing final emitBc?") dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-bcos" (vcat (intersperse (char ' ') (map ppr proto_bcos))) - bcos <- mapM assembleBCO proto_bcos - - return (bcos, itblenv) + assembleBCOs proto_bcos tycs -- Returns: (the root BCO for this expression, @@ -115,18 +117,16 @@ coreExprToBCOs dflags expr -- create a totally bogus name for the top-level BCO; this -- should be harmless, since it's never used for anything - let invented_id = mkSysLocal SLIT("Expr-Top-Level") (mkPseudoUnique3 0) - (panic "invented_id's type") - let invented_name = idName invented_id - - annexpr = freeVars expr - fvs = filter (not.isTyVar) (varSetElems (fst annexpr)) + let invented_name = mkSystemName (mkPseudoUnique3 0) FSLIT("ExprTopLevel") + invented_id = mkLocalId invented_name (panic "invented_id's type") + annexpr = freeVars expr + fvs = filter (not.isTyVar) (varSetElems (fst annexpr)) (BcM_State all_proto_bcos final_ctr mallocd, ()) <- runBc (BcM_State [] 0 []) (schemeR True fvs (invented_id, annexpr)) - when (not (null mallocd)) + when (notNull mallocd) (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?") dumpIfSet_dyn dflags Opt_D_dump_BCOs @@ -287,18 +287,20 @@ schemeE d s p e@(fvs, AnnApp f a) = schemeT d s p (fvs, AnnApp f a) schemeE d s p e@(fvs, AnnVar v) - | isFollowableRep v_rep - = -- Ptr-ish thing; push it in the normal way + | not (isUnLiftedType v_type) + = -- Lifted-type thing; push it in the normal way schemeT d s p (fvs, AnnVar v) | otherwise - = -- returning an unboxed value. Heave it on the stack, SLIDE, and RETURN. + = -- Returning an unlifted value. + -- Heave it on the stack, SLIDE, and RETURN. pushAtom True d p (AnnVar v) `thenBc` \ (push, szw) -> returnBc (push -- value onto stack `appOL` mkSLIDE szw (d-s) -- clear to sequel `snocOL` RETURN v_rep) -- go where - v_rep = typePrimRep (idType v) + v_type = idType v + v_rep = typePrimRep v_type schemeE d s p (fvs, AnnLit literal) = pushAtom True d p (AnnLit literal) `thenBc` \ (push, szw) -> @@ -483,25 +485,30 @@ schemeE d s p (fvs_case, AnnCase (fvs_scrut, scrut) bndr -{- 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) + -- Convert + -- case .... of x { (# VoidRep'd-thing, a #) -> ... } + -- to + -- case .... of a { DEFAULT -> ... } + -- becuse the return convention for both are identical. + -- + -- Note that it does not matter losing the void-rep thing from the + -- envt (it won't be bound now) because we never look such things up. + = --trace "automagic mashing of case alts (# VoidRep, a #)" ( - schemeE d s p (fvs, AnnCase scrut bind2 [(DEFAULT, [bind2], rhs)]) + schemeE d s p (fvs, AnnCase scrut bind2 [(DEFAULT, [], rhs)]) + -- Note: --) schemeE d s p (fvs, AnnCase scrut bndr [(DataAlt dc, [bind1], rhs)]) | isUnboxedTupleCon dc + -- Similarly, convert + -- case .... of x { (# a #) -> ... } + -- to + -- case .... of a { DEFAULT -> ... } = --trace "automagic mashing of case alts (# a #)" ( - schemeE d s p (fvs, AnnCase scrut bind1 [(DEFAULT, [bind1], rhs)]) + schemeE d s p (fvs, AnnCase scrut bind1 [(DEFAULT, [], rhs)]) --) schemeE d s p (fvs, AnnCase scrut bndr alts) @@ -521,13 +528,13 @@ schemeE d s p (fvs, AnnCase scrut bndr alts) isAlgCase | scrut_primrep == PtrRep = True - | scrut_primrep `elem` - [CharRep, AddrRep, WordRep, IntRep, FloatRep, DoubleRep, - VoidRep, Int8Rep, Int16Rep, Int32Rep, Int64Rep, - Word8Rep, Word16Rep, Word32Rep, Word64Rep] - = False - | otherwise - = pprPanic "ByteCodeGen.schemeE" (ppr scrut_primrep) + | otherwise + = WARN( scrut_primrep `elem` bad_reps, + text "Dire warning: strange rep in primitive case:" <+> ppr bndr ) + -- We don't expect to see any of these + False + where + bad_reps = [CodePtrRep, DataPtrRep, RetRep, CostCentreRep] -- given an alt, return a discr and code for it. codeAlt alt@(discr, binds_f, rhs) @@ -590,7 +597,7 @@ schemeE d s p other -- and enter. Four cases: -- -- 0. (Nasty hack). --- An application "PrelGHC.tagToEnum# unboxed-int". +-- An application "GHC.Prim.tagToEnum# unboxed-int". -- The int will be on the stack. Generate a code sequence -- to convert it to the relevant constructor, SLIDE and ENTER. -- @@ -641,16 +648,17 @@ schemeT d s p app ) -- Case 2 - | let isVoidRepAtom (_, AnnVar v) = VoidRep == typePrimRep (idType v) + | [arg1,arg2] <- args_r_to_l, + let + isVoidRepAtom (_, AnnVar v) = typePrimRep (idType v) == VoidRep isVoidRepAtom (_, AnnNote n e) = isVoidRepAtom e - in is_con_call && isUnboxedTupleCon con - && ( (args_r_to_l `lengthIs` 2 && isVoidRepAtom (last (args_r_to_l))) - || (isSingleton args_r_to_l) - ) + isVoidRepAtom _ = False + in + isVoidRepAtom arg2 = --trace (if isSingleton args_r_to_l -- then "schemeT: unboxed singleton" -- else "schemeT: unboxed pair with Void first component") ( - schemeT d s p (head args_r_to_l) + schemeT d s p arg1 --) -- Case 3 @@ -770,14 +778,16 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l pargs d [] = returnBc [] pargs d ((_,a):az) - = let rep_arg = atomRep a - in case rep_arg of + = 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. - ForeignObjRep + Just (t, _) + | t == foreignObjPrimTyCon -> pushAtom False{-irrelevant-} d p a `thenBc` \ (push_fo, _) -> - let foro_szW = taggedSizeW ForeignObjRep + let foro_szW = taggedSizeW PtrRep d_now = d + addr_tsizeW code = push_fo `appOL` toOL [ UPK_TAG addr_usizeW 0 0, @@ -786,13 +796,13 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l in pargs d_now az `thenBc` \ rest -> returnBc ((code, AddrRep) : rest) - ArrayRep + | t == arrayPrimTyCon || t == mutableArrayPrimTyCon -> pargs (d + addr_tsizeW) az `thenBc` \ rest -> parg_ArrayishRep arrPtrsHdrSize d p a `thenBc` \ code -> returnBc ((code,AddrRep):rest) - ByteArrayRep + | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon -> pargs (d + addr_tsizeW) az `thenBc` \ rest -> parg_ArrayishRep arrWordsHdrSize d p a `thenBc` \ code -> @@ -802,7 +812,7 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l other -> pushAtom True d p a `thenBc` \ (code_a, sz_a) -> pargs (d+sz_a) az `thenBc` \ rest -> - returnBc ((code_a, rep_arg) : 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 @@ -881,12 +891,8 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l DynamicTarget -> returnBc (False, panic "ByteCodeGen.generateCCall(dyn)") StaticTarget target - -> let sym_to_find = _UNPK_ target in - ioToBc (lookupSymbol sym_to_find) `thenBc` \res -> - case res of - Just aa -> returnBc (True, aa) - Nothing -> ioToBc (linkFail "ByteCodeGen.generateCCall" - sym_to_find) + -> ioToBc (lookupStaticPtr target) `thenBc` \res -> + returnBc (True, res) CasmTarget _ -> pprPanic "ByteCodeGen.generateCCall: casm" (ppr ccall_spec) in @@ -962,22 +968,22 @@ mkDummyLiteral pr -- Convert (eg) --- PrelGHC.Char# -> PrelGHC.State# PrelGHC.RealWorld --- -> (# PrelGHC.State# PrelGHC.RealWorld, PrelGHC.Int# #) +-- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld +-- -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #) -- -- to Just IntRep -- and check that an unboxed pair is returned wherein the first arg is VoidRep'd. -- -- Alternatively, for call-targets returning nothing, convert -- --- PrelGHC.Char# -> PrelGHC.State# PrelGHC.RealWorld --- -> (# PrelGHC.State# PrelGHC.RealWorld #) +-- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld +-- -> (# GHC.Prim.State# GHC.Prim.RealWorld #) -- -- to Nothing maybe_getCCallReturnRep :: Type -> Maybe PrimRep maybe_getCCallReturnRep fn_ty - = let (a_tys, r_ty) = splitRepFunTys 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) @@ -1007,13 +1013,12 @@ atomRep (AnnApp f (_, AnnType _)) = atomRep (snd f) atomRep (AnnLam x e) | isTyVar x = atomRep (snd e) atomRep other = pprPanic "atomRep" (ppr (deAnnotate (undefined,other))) - -- Compile code which expects an unboxed Int on the top of stack, -- (call it i), and pushes the i'th closure in the supplied list -- as a consequence. implement_tagToId :: [Name] -> BcM BCInstrList implement_tagToId names - = ASSERT(not (null names)) + = ASSERT( notNull names ) getLabelsBc (length names) `thenBc` \ labels -> getLabelBc `thenBc` \ label_fail -> getLabelBc `thenBc` \ label_exit -> @@ -1092,7 +1097,8 @@ mkUnpackCode vars d p code_np = do_nptrs vreps_env_uszw ptrs_szw (reverse (map snd vreps_np)) do_nptrs off_h off_s [] = nilOL do_nptrs off_h off_s (npr:nprs) - | npr `elem` [IntRep, WordRep, FloatRep, DoubleRep, CharRep, AddrRep] + | npr `elem` [IntRep, WordRep, FloatRep, DoubleRep, + CharRep, AddrRep, StablePtrRep] = approved | otherwise = moan64 "ByteCodeGen.mkUnpackCode" (ppr npr) @@ -1173,6 +1179,7 @@ pushAtom True d p (AnnLit lit) pushAtom False d p (AnnLit lit) = case lit of + MachLabel fs -> code CodePtrRep MachWord w -> code WordRep MachInt i -> code IntRep MachFloat r -> code FloatRep @@ -1188,8 +1195,6 @@ pushAtom False d p (AnnLit lit) pushStr s = let getMallocvilleAddr = case s of - CharStr s i -> returnBc (Ptr 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 @@ -1446,7 +1451,7 @@ emitBc bco st newbcoBc :: BcM () newbcoBc st - | not (null (malloced st)) + | notNull (malloced st) = panic "ByteCodeGen.newbcoBc: missed prior emitBc?" | otherwise = return (st, ())