X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FByteCodeGen.lhs;h=350148c241bd476a1bc5a94bfc7939ee2f8df1dc;hb=e940d0ad629747fd30d1dc318a4c1ab893ac7222;hp=40a20cc91ef5fc1a0bfd31868053d6829b2c1b55;hpb=9f004e06842e227c5d86779c2cb1cf1bfdcb8c70;p=ghc-hetmet.git diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs index 40a20cc..350148c 100644 --- a/compiler/ghci/ByteCodeGen.lhs +++ b/compiler/ghci/ByteCodeGen.lhs @@ -1,7 +1,8 @@ % -% (c) The University of Glasgow 2002 +% (c) The University of Glasgow 2002-2006 % -\section[ByteCodeGen]{Generate bytecode from Core} + +ByteCodeGen: Generate bytecode from Core \begin{code} module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where @@ -9,52 +10,46 @@ 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 ByteCodeItbls +import ByteCodeFFI +import ByteCodeAsm +import ByteCodeLink import Outputable -import Name ( Name, getName, mkSystemVarName ) +import Name import Id import FiniteMap -import ForeignCall ( ForeignCall(..), CCallTarget(..), CCallSpec(..) ) -import HscTypes ( TypeEnv, typeEnvTyCons, typeEnvClasses ) -import CoreUtils ( exprType ) +import ForeignCall +import HscTypes +import CoreUtils import CoreSyn -import PprCore ( pprCoreExpr ) -import Literal ( Literal(..), literalType ) -import PrimOp ( PrimOp(..) ) -import CoreFVs ( freeVars ) -import Type ( isUnLiftedType, splitTyConApp_maybe ) -import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon, - isUnboxedTupleCon, isNullaryRepDataCon, dataConWorkId, - dataConRepArity ) -import TyCon ( TyCon, tyConFamilySize, isDataTyCon, - tyConDataCons, isUnboxedTupleTyCon ) -import Class ( Class, classTyCon ) -import Type ( Type, repType, splitFunTys, dropForAlls, pprType ) +import PprCore +import Literal +import PrimOp +import CoreFVs +import Type +import DataCon +import TyCon +import Class +import Type import Util -import DataCon ( dataConRepArity ) -import Var ( isTyVar ) -import VarSet ( VarSet, varSetElems ) -import TysPrim ( arrayPrimTyCon, mutableArrayPrimTyCon, - byteArrayPrimTyCon, mutableByteArrayPrimTyCon - ) -import DynFlags ( 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 DataCon +import Var +import VarSet +import TysPrim +import DynFlags +import ErrUtils +import Unique +import FastString +import Panic +import SMRep +import Bitmap import OrdList -import Constants ( wORD_SIZE ) +import Constants import Data.List ( intersperse, sortBy, zip4, zip6, partition ) import Foreign ( Ptr, castPtr, mallocBytes, pokeByteOff, Word8, - withForeignPtr ) + withForeignPtr, castFunPtrToPtr ) import Foreign.C ( CInt ) import Control.Exception ( throwDyn ) @@ -101,7 +96,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 = mkSystemVarName (mkPseudoUniqueE 0) FSLIT("ExprTopLevel") - invented_id = mkLocalId invented_name (panic "invented_id's type") + invented_id = Id.mkLocalId invented_name (panic "invented_id's type") (BcM_State final_ctr mallocd, proto_bco) <- runBc (schemeTopBind (invented_id, freeVars expr)) @@ -144,7 +139,7 @@ mkProtoBCO -> Int -> [StgWord] -> Bool -- True <=> is a return point, rather than a function - -> [Ptr ()] + -> [BcPtr] -> ProtoBCO name mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_blocks @@ -170,14 +165,12 @@ mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap -- 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 + -- We assume that this sum doesn't wrap stack_overest = sum (map bciStackUse peep_d) -- Merge local pushes @@ -732,7 +725,16 @@ 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 = intsToReverseBitmap d{-size-} (sortLe (<=) rel_slots) + -- + -- NOTE [7/12/2006] bug #1013, testcase ghci/should_run/ghci002. + -- The bitmap must cover the portion of the stack up to the sequel only. + -- Previously we were building a bitmap for the whole depth (d), but we + -- really want a bitmap up to depth (d-s). This affects compilation of + -- case-of-case expressions, which is the only time we can be compiling a + -- case expression with s /= 0. + bitmap_size = d-s + bitmap = intsToReverseBitmap bitmap_size{-size-} + (sortLe (<=) (filter (< bitmap_size) rel_slots)) where binds = fmToList p rel_slots = concat (map spread binds) @@ -747,7 +749,7 @@ doCase d s p (_,scrut) let alt_bco_name = getName bndr alt_bco = mkProtoBCO alt_bco_name alt_final (Left alts) - 0{-no arity-} d{-bitmap size-} bitmap True{-is alts-} + 0{-no arity-} 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 @@ -923,7 +925,7 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l ioToBc (mkMarshalCode cconv (r_offW, r_rep) addr_offW (zip args_offW a_reps)) `thenBc` \ addr_of_marshaller -> - recordMallocBc addr_of_marshaller `thenBc_` + recordItblMallocBc (ItblPtr (castFunPtrToPtr 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 @@ -932,7 +934,7 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l stk_offset = d_after_r - s -- do the call - do_call = unitOL (CCALL stk_offset (castPtr addr_of_marshaller)) + do_call = unitOL (CCALL stk_offset (castFunPtrToPtr addr_of_marshaller)) -- slide and return wrapup = mkSLIDE r_sizeW (d_after_r - r_sizeW - s) `snocOL` RETURN_UBX r_rep @@ -952,6 +954,7 @@ mkDummyLiteral pr NonPtrArg -> MachWord 0 DoubleArg -> MachDouble 0 FloatArg -> MachFloat 0 + LongArg -> MachWord64 0 _ -> moan64 "mkDummyLiteral" (ppr pr) @@ -1099,7 +1102,7 @@ pushAtom d p (AnnLit lit) -- 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_` + recordMallocBc ptr `thenBc_` ioToBc ( withForeignPtr fp $ \p -> do memcpy ptr p (fromIntegral n) @@ -1311,10 +1314,12 @@ mkStackOffsets original_depth szsw -- ----------------------------------------------------------------------------- -- The bytecode generator's monad +type BcPtr = Either ItblPtr (Ptr ()) + data BcM_State = BcM_State { nextlabel :: Int, -- for generating local labels - malloced :: [Ptr ()] } -- ptrs malloced for current BCO + malloced :: [BcPtr] } -- thunks malloced for current BCO -- Should be free()d when it is GCd newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) @@ -1348,13 +1353,17 @@ instance Monad BcM where (>>) = thenBc_ return = returnBc -emitBc :: ([Ptr ()] -> ProtoBCO Name) -> BcM (ProtoBCO Name) +emitBc :: ([BcPtr] -> ProtoBCO Name) -> BcM (ProtoBCO Name) emitBc bco = BcM $ \st -> return (st{malloced=[]}, bco (malloced st)) recordMallocBc :: Ptr a -> BcM () recordMallocBc a - = BcM $ \st -> return (st{malloced = castPtr a : malloced st}, ()) + = BcM $ \st -> return (st{malloced = Right (castPtr a) : malloced st}, ()) + +recordItblMallocBc :: ItblPtr -> BcM () +recordItblMallocBc a + = BcM $ \st -> return (st{malloced = Left a : malloced st}, ()) getLabelBc :: BcM Int getLabelBc