X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FByteCodeGen.lhs;h=d7a477bfdc17459cf78ec201b02b4cf223948b46;hb=cd83751814b0c820f6fe4729803d56420963bf4b;hp=d8bb40660e56865b6659adc3af76f5631ace0dbc;hpb=ce25c4afa4c9ddd5b71b67795cc1ffaf3ac1578f;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index d8bb406..d7a477b 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -19,7 +19,7 @@ import Name ( Name, getName, mkSystemName ) import Id import FiniteMap import ForeignCall ( ForeignCall(..), CCallTarget(..), CCallSpec(..) ) -import HscTypes ( ModGuts(..), ModGuts, typeEnvTyCons, typeEnvClasses ) +import HscTypes ( TypeEnv, typeEnvTyCons, typeEnvClasses ) import CoreUtils ( exprType ) import CoreSyn import PprCore ( pprCoreExpr ) @@ -27,21 +27,19 @@ import Literal ( Literal(..), literalPrimRep ) import PrimRep import PrimOp ( PrimOp(..) ) import CoreFVs ( freeVars ) -import Type ( typePrimRep, isUnLiftedType, splitTyConApp_maybe, - isTyVarTy ) +import Type ( typePrimRep, isUnLiftedType, splitTyConApp_maybe ) import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon, isUnboxedTupleCon, isNullaryDataCon, dataConWorkId, dataConRepArity ) import TyCon ( tyConFamilySize, isDataTyCon, tyConDataCons, - isFunTyCon, isUnboxedTupleTyCon ) + isUnboxedTupleTyCon ) import Class ( Class, classTyCon ) -import Type ( Type, repType, splitFunTys, dropForAlls ) +import Type ( Type, repType, splitFunTys, dropForAlls, pprType ) import Util import DataCon ( dataConRepArity ) import Var ( isTyVar ) import VarSet ( VarSet, varSetElems ) -import TysPrim ( foreignObjPrimTyCon, - arrayPrimTyCon, mutableArrayPrimTyCon, +import TysPrim ( arrayPrimTyCon, mutableArrayPrimTyCon, byteArrayPrimTyCon, mutableByteArrayPrimTyCon ) import PrimRep ( isFollowableRep ) @@ -50,11 +48,10 @@ import ErrUtils ( showPass, dumpIfSet_dyn ) import Unique ( mkPseudoUnique3 ) import FastString ( FastString(..), unpackFS ) import Panic ( GhcException(..) ) -import PprType ( pprType ) -import SMRep ( arrWordsHdrSize, arrPtrsHdrSize ) +import SMRep ( arrWordsHdrSize, arrPtrsHdrSize, StgWord ) +import Bitmap ( intsToReverseBitmap, mkBitmap ) import OrdList import Constants ( wORD_SIZE ) -import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel ) import Data.List ( intersperse, sortBy, zip4, zip5, partition ) import Foreign ( Ptr, castPtr, mallocBytes, pokeByteOff, Word8 ) @@ -63,17 +60,17 @@ import Control.Exception ( throwDyn ) import GHC.Exts ( Int(..), ByteArray# ) -import Control.Monad ( when, mapAndUnzipM ) -import Data.Char ( ord ) -import Data.Bits +import Control.Monad ( when ) +import Data.Char ( ord, chr ) -- ----------------------------------------------------------------------------- -- Generating byte code for a complete module byteCodeGen :: DynFlags - -> ModGuts + -> [CoreBind] + -> TypeEnv -> IO CompiledByteCode -byteCodeGen dflags (ModGuts { mg_binds = binds, mg_types = type_env }) +byteCodeGen dflags binds type_env = do showPass dflags "ByteCodeGen" let local_tycons = typeEnvTyCons type_env local_classes = typeEnvClasses type_env @@ -204,32 +201,6 @@ argBits (rep : args) | isFollowableRep rep = False : argBits args | otherwise = take (getPrimRepSize rep) (repeat True) ++ argBits args -mkBitmap :: [Bool] -> [StgWord] -mkBitmap [] = [] -mkBitmap stuff = chunkToLiveness chunk : mkBitmap rest - where (chunk, rest) = splitAt wORD_SIZE_IN_BITS stuff - -chunkToLiveness :: [Bool] -> StgWord -chunkToLiveness chunk = - foldr (.|.) 0 [ 1 `shiftL` n | (True,n) <- zip chunk [0..] ] - --- make a bitmap where the slots specified are the *zeros* in the bitmap. --- eg. [1,2,4], size 4 ==> 0x8 (we leave any bits outside the size as zero, --- just to make the bitmap easier to read). -intsToBitmap :: Int -> [Int] -> [StgWord] -intsToBitmap size slots{- must be sorted -} - | size <= 0 = [] - | otherwise = - (foldr xor init (map (1 `shiftL`) these)) : - intsToBitmap (size - wORD_SIZE_IN_BITS) - (map (\x -> x - wORD_SIZE_IN_BITS) rest) - where (these,rest) = span (= wORD_SIZE_IN_BITS = complement 0 - | otherwise = (1 `shiftL` size) - 1 - -wORD_SIZE_IN_BITS = wORD_SIZE * 8 :: Int - -- ----------------------------------------------------------------------------- -- schemeTopBind @@ -378,8 +349,8 @@ schemeE d s p (AnnLet binds (_,body)) fvss = map (fvsToEnv p' . fst) rhss - -- Sizes of free vars, + 1 for the fn - sizes = map (\rhs_fvs -> 1 + sum (map idSizeW rhs_fvs)) fvss + -- Sizes of free vars + sizes = map (\rhs_fvs -> sum (map idSizeW rhs_fvs)) fvss -- the arity of each rhs arities = map (length . fst . collect []) rhss @@ -395,7 +366,7 @@ schemeE d s p (AnnLet binds (_,body)) -- ToDo: don't build thunks for things with no free variables build_thunk dd [] size bco off = returnBc (PUSH_BCO bco - `consOL` unitOL (MKAP (off+size-1) size)) + `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 @@ -533,11 +504,14 @@ schemeT d s p app -- 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 + | 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 @@ -740,7 +714,7 @@ doCase d s p (_,scrut) = case l of MachInt i -> DiscrI (fromInteger i) MachFloat r -> DiscrF (fromRational r) MachDouble r -> DiscrD (fromRational r) - MachChar i -> DiscrI i + MachChar i -> DiscrI (ord i) _ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l) maybe_ncons @@ -757,7 +731,7 @@ doCase d s p (_,scrut) -- things that are pointers, whereas in CgBindery the code builds the -- bitmap from the free slots and unboxed bindings. -- (ToDo: merge?) - bitmap = intsToBitmap d{-size-} (sortLt (<) rel_slots) + bitmap = intsToReverseBitmap d{-size-} (sortLt (<) rel_slots) where binds = fmToList p rel_slots = concat (map spread binds) @@ -912,8 +886,6 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l StaticTarget target -> ioToBc (lookupStaticPtr target) `thenBc` \res -> returnBc (True, res) - CasmTarget _ - -> pprPanic "ByteCodeGen.generateCCall: casm" (ppr ccall_spec) in get_target_info `thenBc` \ (is_static, static_target_addr) -> let @@ -978,7 +950,7 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l mkDummyLiteral :: PrimRep -> Literal mkDummyLiteral pr = case pr of - CharRep -> MachChar 0 + CharRep -> MachChar (chr 0) IntRep -> MachInt 0 WordRep -> MachWord 0 DoubleRep -> MachDouble 0 @@ -1107,13 +1079,13 @@ pushAtom d p (AnnVar v) pushAtom d p (AnnLit lit) = case lit of - MachLabel fs -> code CodePtrRep - MachWord w -> code WordRep - MachInt i -> code IntRep - MachFloat r -> code FloatRep - MachDouble r -> code DoubleRep - MachChar c -> code CharRep - MachStr s -> pushStr s + MachLabel fs _ -> code CodePtrRep + 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 = getPrimRepSize rep