X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FByteCodeGen.lhs;h=350148c241bd476a1bc5a94bfc7939ee2f8df1dc;hb=e940d0ad629747fd30d1dc318a4c1ab893ac7222;hp=69fc148aed92e3c56887bb3697d5b2a3d91db3a8;hpb=e2b2c4b9920dd7ca74c9e62640647c78848b162c;p=ghc-hetmet.git diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs index 69fc148..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 @@ -253,6 +246,7 @@ schemeR fvs (nm, rhs) = schemeR_wrk fvs nm rhs (collect [] rhs) collect xs (_, AnnNote note e) = collect xs e +collect xs (_, AnnCast 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) @@ -427,13 +421,6 @@ schemeE d s p (AnnNote note (_, body)) schemeE d s p (AnnCast (_, body) _) = schemeE d s p body --- XXX - audreyt - After FC landed, this case of explicit eta-reduction --- seems needed to make "data D = D deriving Typeable" work in GHCi. --- however, how did AnnLam with a var (LocalId) survive until this place? -schemeE d s p (AnnLam var (_, AnnApp (_, body) (_, AnnVar inner))) - | var == inner - = schemeE d s p body - schemeE d s p other = pprPanic "ByteCodeGen.schemeE: unhandled case" (pprCoreExpr (deAnnotate' other)) @@ -738,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) @@ -753,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 @@ -929,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 @@ -938,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 @@ -958,6 +954,7 @@ mkDummyLiteral pr NonPtrArg -> MachWord 0 DoubleArg -> MachDouble 0 FloatArg -> MachFloat 0 + LongArg -> MachWord64 0 _ -> moan64 "mkDummyLiteral" (ppr pr) @@ -1105,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) @@ -1117,6 +1114,9 @@ pushAtom d p (AnnLit lit) -- Get the addr on the stack, untaggedly returnBc (unitOL (PUSH_UBX (Right addr) 1), 1) +pushAtom d p (AnnCast e _) + = pushAtom d p (snd e) + pushAtom d p other = pprPanic "ByteCodeGen.pushAtom" (pprCoreExpr (deAnnotate (undefined, other))) @@ -1278,6 +1278,7 @@ splitApp (AnnApp (_,f) (_,a)) | otherwise = case splitApp f of (f', as) -> (f', a:as) splitApp (AnnNote n (_,e)) = splitApp e +splitApp (AnnCast (_,e) _) = splitApp e splitApp e = (e, []) @@ -1288,6 +1289,7 @@ isTypeAtom _ = False isVoidArgAtom :: AnnExpr' id ann -> Bool isVoidArgAtom (AnnVar v) = typeCgRep (idType v) == VoidArg isVoidArgAtom (AnnNote n (_,e)) = isVoidArgAtom e +isVoidArgAtom (AnnCast (_,e) _) = isVoidArgAtom e isVoidArgAtom _ = False atomRep :: AnnExpr' Id ann -> CgRep @@ -1296,6 +1298,7 @@ atomRep (AnnLit l) = typeCgRep (literalType 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 (AnnCast b _) = atomRep (snd b) atomRep other = pprPanic "atomRep" (ppr (deAnnotate (undefined,other))) isPtrAtom :: AnnExpr' Id ann -> Bool @@ -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