X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FByteCodeGen.lhs;h=f526ed990789de279838dd866172f648ebb1e9d2;hb=d5171bf249cd17d7a9e2a8c0396f6f0eb404d28e;hp=cad4789cf70d6a6a082ca30d46dd0a7561e9e7b0;hpb=578d1788ceaae231a036d74777356b633c0368f6;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index cad4789..f526ed9 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -15,7 +15,7 @@ import ByteCodeAsm ( CompiledByteCode(..), UnlinkedBCO, import ByteCodeLink ( lookupStaticPtr ) import Outputable -import Name ( Name, getName, mkSystemName ) +import Name ( Name, getName, mkSystemVarName ) import Id import FiniteMap import ForeignCall ( ForeignCall(..), CCallTarget(..), CCallSpec(..) ) @@ -28,10 +28,10 @@ import PrimOp ( PrimOp(..) ) import CoreFVs ( freeVars ) import Type ( isUnLiftedType, splitTyConApp_maybe ) import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon, - isUnboxedTupleCon, isNullaryDataCon, dataConWorkId, + isUnboxedTupleCon, isNullaryRepDataCon, dataConWorkId, dataConRepArity ) -import TyCon ( tyConFamilySize, isDataTyCon, tyConDataCons, - isUnboxedTupleTyCon ) +import TyCon ( TyCon, tyConFamilySize, isDataTyCon, + tyConDataCons, isUnboxedTupleTyCon ) import Class ( Class, classTyCon ) import Type ( Type, repType, splitFunTys, dropForAlls, pprType ) import Util @@ -41,7 +41,7 @@ import VarSet ( VarSet, varSetElems ) import TysPrim ( arrayPrimTyCon, mutableArrayPrimTyCon, byteArrayPrimTyCon, mutableByteArrayPrimTyCon ) -import CmdLineOpts ( DynFlags, DynFlag(..) ) +import DynFlags ( DynFlags, DynFlag(..) ) import ErrUtils ( showPass, dumpIfSet_dyn ) import Unique ( mkPseudoUniqueE ) import FastString ( FastString(..), unpackFS ) @@ -53,7 +53,8 @@ import OrdList import Constants ( wORD_SIZE ) import Data.List ( intersperse, sortBy, zip4, zip5, partition ) -import Foreign ( Ptr, castPtr, mallocBytes, pokeByteOff, Word8 ) +import Foreign ( Ptr, castPtr, mallocBytes, pokeByteOff, Word8, + withForeignPtr ) import Foreign.C ( CInt ) import Control.Exception ( throwDyn ) @@ -67,13 +68,10 @@ import Data.Char ( ord, chr ) byteCodeGen :: DynFlags -> [CoreBind] - -> TypeEnv + -> [TyCon] -> IO CompiledByteCode -byteCodeGen dflags binds type_env +byteCodeGen dflags binds tycs = do showPass dflags "ByteCodeGen" - let local_tycons = typeEnvTyCons type_env - local_classes = typeEnvClasses type_env - tycs = local_tycons ++ map classTyCon local_classes let flatBinds = [ (bndr, freeVars rhs) | (bndr, rhs) <- flattenBinds binds] @@ -102,7 +100,7 @@ coreExprToBCOs dflags expr -- create a totally bogus name for the top-level BCO; this -- should be harmless, since it's never used for anything - let invented_name = mkSystemName (mkPseudoUniqueE 0) FSLIT("ExprTopLevel") + let invented_name = mkSystemVarName (mkPseudoUniqueE 0) FSLIT("ExprTopLevel") invented_id = mkLocalId invented_name (panic "invented_id's type") (BcM_State final_ctr mallocd, proto_bco) @@ -210,7 +208,7 @@ schemeTopBind :: (Id, AnnExpr Id VarSet) -> BcM (ProtoBCO Name) schemeTopBind (id, rhs) | Just data_con <- isDataConWorkId_maybe id, - isNullaryDataCon data_con + isNullaryRepDataCon data_con = -- Special case for the worker of a nullary data con. -- It'll look like this: Nil = /\a -> Nil a -- If we feed it into schemeR, we'll get @@ -391,7 +389,7 @@ schemeE d s p (AnnLet binds (_,body)) -schemeE d s p (AnnCase scrut bndr [(DataAlt dc, [bind1, bind2], rhs)]) +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 #) -> ... } @@ -409,7 +407,7 @@ schemeE d s p (AnnCase scrut bndr [(DataAlt dc, [bind1, bind2], rhs)]) = --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)]) +schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)]) | isUnboxedTupleCon dc -- Similarly, convert -- case .... of x { (# a #) -> ... } @@ -418,7 +416,7 @@ schemeE d s p (AnnCase scrut bndr [(DataAlt dc, [bind1], rhs)]) = --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) +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)) @@ -541,7 +539,7 @@ mkConAppCode :: Int -> Sequel -> BCEnv -> BcM BCInstrList mkConAppCode orig_d s p con [] -- Nullary constructor - = ASSERT( isNullaryDataCon con ) + = ASSERT( isNullaryRepDataCon con ) returnBc (unitOL (PUSH_G (getName (dataConWorkId con)))) -- Instead of doing a PACK, which would allocate a fresh -- copy of this constructor, use the single shared version. @@ -591,9 +589,9 @@ doTailCall init_d s p fn args = do_pushes init_d args (map atomRep args) where do_pushes d [] reps = do - ASSERTM( null reps ) + ASSERT( null reps ) return () (push_fn, sz) <- pushAtom d p (AnnVar fn) - ASSERTM( sz == 1 ) + ASSERT( sz == 1 ) return () returnBc (push_fn `appOL` ( mkSLIDE ((d-init_d) + 1) (init_d - s) `appOL` unitOL ENTER)) @@ -612,8 +610,6 @@ doTailCall init_d s p fn 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) @@ -888,7 +884,7 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l let -- Get the arg reps, zapping the leading Addr# in the dynamic case - a_reps -- | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???" + 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" @@ -1089,18 +1085,18 @@ pushAtom d p (AnnLit lit) 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 -> + FastString _ n _ fp _ -> + -- we could grab the Ptr from the ForeignPtr, + -- but then we have no way to control its lifetime. + -- In reality it'll probably stay alive long enoungh + -- by virtue of the global FastString table, but + -- to be on the safe side we copy the string into + -- a malloc'd area of memory. + ioToBc (mallocBytes (n+1)) `thenBc` \ ptr -> recordMallocBc ptr `thenBc_` ioToBc ( - do memcpy ptr ba (fromIntegral n) + withForeignPtr fp $ \p -> do + memcpy ptr p (fromIntegral n) pokeByteOff ptr n (fromIntegral (ord '\0') :: Word8) return ptr ) @@ -1115,7 +1111,7 @@ pushAtom d p other (pprCoreExpr (deAnnotate (undefined, other))) foreign import ccall unsafe "memcpy" - memcpy :: Ptr a -> ByteArray# -> CInt -> IO () + memcpy :: Ptr a -> Ptr b -> CInt -> IO () -- ----------------------------------------------------------------------------- @@ -1123,7 +1119,7 @@ foreign import ccall unsafe "memcpy" -- of making a multiway branch using a switch tree. -- What a load of hassle! -mkMultiBranch :: Maybe Int -- # datacons in tycon, if alg alt +mkMultiBranch :: Maybe Int -- # datacons in tycon, if alg alt -- a hint; generates better code -- Nothing is always safe -> [(Discr, BCInstrList)]