diff options
39 files changed, 708 insertions, 715 deletions
diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs index 6a3d0eb9b2..2b8a0e4fec 100644 --- a/ghc/compiler/absCSyn/AbsCSyn.lhs +++ b/ghc/compiler/absCSyn/AbsCSyn.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: AbsCSyn.lhs,v 1.51 2002/12/11 15:36:21 simonmar Exp $ +% $Id: AbsCSyn.lhs,v 1.52 2003/05/14 09:13:52 simonmar Exp $ % \section[AbstractC]{Abstract C: the last stop before machine code} @@ -51,7 +51,8 @@ import MachOp ( MachOp(..) ) import Unique ( Unique ) import StgSyn ( StgOp ) import TyCon ( TyCon ) -import BitSet -- for liveness masks +import Bitmap ( Bitmap, mAX_SMALL_BITMAP_SIZE ) +import SMRep ( StgWord, StgHalfWord ) import FastTypes import FastString \end{code} @@ -199,8 +200,15 @@ stored in a mixed type location.) | CSRT CLabel [CLabel] -- SRT declarations: basically an array of -- pointers to static closures. - | CBitmap Liveness -- A bitmap to be emitted if and only if - -- it is larger than a target machine word. + | CBitmap Liveness -- A "large" bitmap to be emitted + + | CSRTDesc -- A "large" SRT descriptor (one that doesn't + -- fit into the half-word bitmap in the itbl). + !CLabel -- Label for this SRT descriptor + !CLabel -- Pointer to the SRT + !Int -- Offset within the SRT + !Int -- Length + !Bitmap -- Bitmap | CClosureInfoAndCode ClosureInfo -- Explains placement and layout of closure @@ -236,7 +244,7 @@ stored in a mixed type location.) -- we add a label for the table, and expect only the 'offset/length' form data C_SRT = NoC_SRT - | C_SRT CLabel !Int{-offset-} !Int{-length-} + | C_SRT !CLabel !Int{-offset-} !StgHalfWord{-bitmap or escape-} needsSRT :: C_SRT -> Bool needsSRT NoC_SRT = False @@ -365,10 +373,6 @@ data CAddrMode !PrimRep -- the kind of the result CExprMacro -- the macro to generate a value [CAddrMode] -- and its arguments - - | CBytesPerWord -- Word size, in bytes, on this platform - -- required for: half-word loads (used in fishing tags - -- out of info tables), and sizeofByteArray#. \end{code} Various C macros for values which are dependent on the back-end layout. @@ -392,6 +396,9 @@ Convenience functions: mkIntCLit :: Int -> CAddrMode mkIntCLit i = CLit (mkMachInt (toInteger i)) +mkWordCLit :: StgWord -> CAddrMode +mkWordCLit wd = CLit (MachWord (fromIntegral wd)) + mkCString :: FastString -> CAddrMode mkCString s = CLit (MachStr s) @@ -449,16 +456,15 @@ vectors to indicate the state of the stack for the garbage collector. In the compiled program, liveness bitmaps that fit inside a single word (StgWord) are stored as a single word, while larger bitmaps are -stored as a pointer to an array of words. When we compile via C -(especially when we bootstrap via HC files), we generate identical C -code regardless of whether words are 32- or 64-bit on the target -machine, by postponing the decision of how to store each liveness -bitmap to C compilation time (or rather, C preprocessing time). +stored as a pointer to an array of words. \begin{code} -type LivenessMask = [BitSet] +data Liveness = Liveness CLabel !Int Bitmap -data Liveness = Liveness CLabel !Int LivenessMask +maybeLargeBitmap :: Liveness -> AbstractC +maybeLargeBitmap liveness@(Liveness _ size _) + | size <= mAX_SMALL_BITMAP_SIZE = AbsCNop + | otherwise = CBitmap liveness \end{code} %************************************************************************ diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs index 36e74efc8d..ac75ca1643 100644 --- a/ghc/compiler/absCSyn/AbsCUtils.lhs +++ b/ghc/compiler/absCSyn/AbsCUtils.lhs @@ -38,6 +38,7 @@ import SMRep ( arrPtrsHdrSize, arrWordsHdrSize, fixedHdrSize ) import Outputable import Panic ( panic ) import FastTypes +import Constants ( wORD_SIZE, wORD_SIZE_IN_BITS ) import Maybe ( isJust ) @@ -419,6 +420,7 @@ flatAbsC (CSequential abcs) flatAbsC stmt@(CStaticClosure _ _ _ _) = returnFlt (AbsCNop, stmt) flatAbsC stmt@(CClosureTbl _) = returnFlt (AbsCNop, stmt) flatAbsC stmt@(CSRT _ _) = returnFlt (AbsCNop, stmt) +flatAbsC stmt@(CSRTDesc _ _ _ _ _) = returnFlt (AbsCNop, stmt) flatAbsC stmt@(CBitmap _) = returnFlt (AbsCNop, stmt) flatAbsC stmt@(CCostCentreDecl _ _) = returnFlt (AbsCNop, stmt) flatAbsC stmt@(CCostCentreStackDecl _) = returnFlt (AbsCNop, stmt) @@ -605,27 +607,24 @@ rrConflictsWithRR s1b s2b rr1 rr2 = rr rr1 rr2 -- why it needs to take into account endianness. -- mkHalfWord_HIADDR res arg - = mkTemp IntRep `thenFlt` \ t_hw_shift -> - mkTemp WordRep `thenFlt` \ t_hw_mask1 -> + = mkTemp WordRep `thenFlt` \ t_hw_mask1 -> mkTemp WordRep `thenFlt` \ t_hw_mask2 -> - let a_hw_shift - = CMachOpStmt t_hw_shift - MO_Nat_Shl [CBytesPerWord, CLit (mkMachInt 2)] Nothing + let + hw_shift = mkIntCLit (wORD_SIZE_IN_BITS `quot` 2) + a_hw_mask1 = CMachOpStmt t_hw_mask1 - MO_Nat_Shl [CLit (mkMachWord 1), t_hw_shift] Nothing + MO_Nat_Shl [CLit (mkMachWord 1), hw_shift] Nothing a_hw_mask2 = CMachOpStmt t_hw_mask2 MO_Nat_Sub [t_hw_mask1, CLit (mkMachWord 1)] Nothing final # if WORDS_BIGENDIAN - = CSequential [ a_hw_shift, a_hw_mask1, a_hw_mask2, + = CSequential [ a_hw_mask1, a_hw_mask2, CMachOpStmt res MO_Nat_And [arg, t_hw_mask2] Nothing ] # else - = CSequential [ a_hw_shift, - CMachOpStmt res MO_Nat_Shr [arg, t_hw_shift] Nothing - ] + = CMachOpStmt res MO_Nat_Shr [arg, hw_shift] Nothing # endif in returnFlt final @@ -726,19 +725,6 @@ translateOp_dyadic_cast1 mop res cast_arg1_to arg1 arg2 vols (if isDefinitelyInlineMachOp mop then Nothing else Just vols) ] -getBitsPerWordMinus1 :: FlatM (AbstractC, CAddrMode) -getBitsPerWordMinus1 - = mkTemps [IntRep, IntRep] `thenFlt` \ [t1,t2] -> - returnFlt ( - CSequential [ - CMachOpStmt t1 MO_Nat_Shl - [CBytesPerWord, CLit (mkMachInt 3)] Nothing, - CMachOpStmt t2 MO_Nat_Sub - [t1, CLit (mkMachInt 1)] Nothing - ], - t2 - ) - -- IA64 mangler doesn't place tables next to code tablesNextToCode :: Bool #ifdef ia64_TARGET_ARCH @@ -790,15 +776,14 @@ dscCOpStmt [res_r,res_c] IntAddCOp [aa,bb] vols c = t4 >>unsigned BITS_IN(I_)-1 -} = mkTemps [IntRep,IntRep,IntRep,IntRep] `thenFlt` \ [t1,t2,t3,t4] -> - getBitsPerWordMinus1 `thenFlt` \ (bpw1_code,bpw1_t) -> + let bpw1 = mkIntCLit (wORD_SIZE_IN_BITS - 1) in (returnFlt . CSequential) [ CMachOpStmt res_r MO_Nat_Add [aa,bb] Nothing, CMachOpStmt t1 MO_Nat_Xor [aa,bb] Nothing, CMachOpStmt t2 MO_Nat_Not [t1] Nothing, CMachOpStmt t3 MO_Nat_Xor [aa,res_r] Nothing, CMachOpStmt t4 MO_Nat_And [t2,t3] Nothing, - bpw1_code, - CMachOpStmt res_c MO_Nat_Shr [t4, bpw1_t] Nothing + CMachOpStmt res_c MO_Nat_Shr [t4, bpw1] Nothing ] @@ -818,14 +803,13 @@ dscCOpStmt [res_r,res_c] IntSubCOp [aa,bb] vols c = t3 >>unsigned BITS_IN(I_)-1 -} = mkTemps [IntRep,IntRep,IntRep] `thenFlt` \ [t1,t2,t3] -> - getBitsPerWordMinus1 `thenFlt` \ (bpw1_code,bpw1_t) -> + let bpw1 = mkIntCLit (wORD_SIZE_IN_BITS - 1) in (returnFlt . CSequential) [ CMachOpStmt res_r MO_Nat_Sub [aa,bb] Nothing, CMachOpStmt t1 MO_Nat_Xor [aa,bb] Nothing, CMachOpStmt t2 MO_Nat_Xor [aa,res_r] Nothing, CMachOpStmt t3 MO_Nat_And [t1,t2] Nothing, - bpw1_code, - CMachOpStmt res_c MO_Nat_Shr [t3, bpw1_t] Nothing + CMachOpStmt res_c MO_Nat_Shr [t3, bpw1] Nothing ] @@ -864,7 +848,7 @@ dscCOpStmt [res] SizeofByteArrayOp [arg] vols = mkTemp WordRep `thenFlt` \ w -> (returnFlt . CSequential) [ CAssign w (mkDerefOff WordRep arg fixedHdrSize), - CMachOpStmt w MO_NatU_Mul [w, CBytesPerWord] (Just vols), + CMachOpStmt w MO_NatU_Mul [w, mkIntCLit wORD_SIZE] (Just vols), CAssign res w ] diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs index 437e5dff79..75e67e8285 100644 --- a/ghc/compiler/absCSyn/CLabel.lhs +++ b/ghc/compiler/absCSyn/CLabel.lhs @@ -9,6 +9,7 @@ module CLabel ( mkClosureLabel, mkSRTLabel, + mkSRTDescLabel, mkInfoTableLabel, mkEntryLabel, mkSlowEntryLabel, @@ -151,6 +152,7 @@ data CLabel data IdLabelInfo = Closure -- Label for (static???) closure | SRT -- Static reference table + | SRTDesc -- Static reference table descriptor | InfoTbl -- Info tables for closures; always read-only | Entry -- entry point | Slow -- slow entry point @@ -223,6 +225,7 @@ data CLabelType \begin{code} mkClosureLabel id = IdLabel id Closure mkSRTLabel id = IdLabel id SRT +mkSRTDescLabel id = IdLabel id SRTDesc mkInfoTableLabel id = IdLabel id InfoTbl mkEntryLabel id = IdLabel id Entry mkSlowEntryLabel id = IdLabel id Slow @@ -320,6 +323,7 @@ let-no-escapes, which can be recursive. -- don't bother declaring SRT & Bitmap labels, we always make sure -- they are defined before use. needsCDecl (IdLabel _ SRT) = False +needsCDecl (IdLabel _ SRTDesc) = False needsCDecl (IdLabel _ Bitmap) = False needsCDecl (IdLabel _ _) = True needsCDecl (CaseLabel _ CaseReturnPt) = True @@ -446,6 +450,7 @@ internal names. <type> is one of the following: info Info table srt Static reference table + srtd Static reference table descriptor entry Entry code slow Slow entry code (if any) ret Direct return address @@ -572,6 +577,7 @@ ppIdFlavor x = pp_cSEP <> (case x of Closure -> ptext SLIT("closure") SRT -> ptext SLIT("srt") + SRTDesc -> ptext SLIT("srtd") InfoTbl -> ptext SLIT("info") Entry -> ptext SLIT("entry") Slow -> ptext SLIT("slow") diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index 7094fbb697..0d700a895e 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -53,11 +53,9 @@ import UniqSet ( emptyUniqSet, elementOfUniqSet, addOneToUniqSet, UniqSet ) import StgSyn ( StgOp(..) ) -import BitSet ( BitSet, intBS ) import Outputable import FastString import Util ( lengthExceeds ) -import Constants ( wORD_SIZE ) #if __GLASGOW_HASKELL__ >= 504 import Data.Array.ST @@ -299,11 +297,14 @@ pprAbsC stmt@(CSRT lbl closures) c } pprAbsC stmt@(CBitmap liveness@(Liveness lbl size mask)) c - = pp_liveness_switch liveness semi $ - hcat [ ptext SLIT("BITMAP"), lparen, - pprCLabel lbl, comma, - int size, comma, - pp_bitmap mask, rparen ] + = pprWordArray lbl (mkWordCLit (fromIntegral size) : bitmapAddrModes mask) + +pprAbsC stmt@(CSRTDesc desc_lbl srt_lbl off len bitmap) c + = pprWordArray desc_lbl ( + CAddr (CIndex (CLbl srt_lbl DataPtrRep) (mkIntCLit off) WordRep) : + mkWordCLit (fromIntegral len) : + bitmapAddrModes bitmap + ) pprAbsC (CSimultaneous abs_c) c = hcat [ptext SLIT("{{"), pprAbsC abs_c c, ptext SLIT("}}")] @@ -460,7 +461,7 @@ pprAbsC stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _ rep = getAmodeRep item pprAbsC stmt@(CClosureInfoAndCode cl_info entry) _ - = pprInfoTable info_lbl (mkInfoTable cl_info) + = pprWordArray info_lbl (mkInfoTable cl_info) $$ let stuff = CCodeBlock entry_lbl entry in pprAbsC stuff (costs stuff) where @@ -477,7 +478,7 @@ pprAbsC stmt@(CClosureTbl tycon) _ ) $$ ptext SLIT("};") pprAbsC stmt@(CRetDirect uniq code srt liveness) _ - = pprInfoTable info_lbl (mkRetInfoTable entry_lbl srt liveness) + = pprWordArray info_lbl (mkRetInfoTable entry_lbl srt liveness) $$ let stuff = CCodeBlock entry_lbl code in pprAbsC stuff (costs stuff) where @@ -485,7 +486,7 @@ pprAbsC stmt@(CRetDirect uniq code srt liveness) _ entry_lbl = mkReturnPtLabel uniq pprAbsC stmt@(CRetVector lbl amodes srt liveness) _ - = pprInfoTable lbl (mkVecInfoTable amodes srt liveness) + = pprWordArray lbl (mkVecInfoTable amodes srt liveness) pprAbsC stmt@(CModuleInitBlock plain_lbl lbl code) _ = vcat [ @@ -504,12 +505,12 @@ Info tables... just arrays of words (the translation is done in ClosureInfo). \begin{code} -pprInfoTable info_lbl amodes +pprWordArray lbl amodes = (case snd (initTE (ppr_decls_Amodes amodes)) of Just pp -> pp Nothing -> empty) - $$ hcat [ ppLocalness info_lbl, ptext SLIT("StgWord "), - pprCLabel info_lbl, ptext SLIT("[] = {") ] + $$ hcat [ ppLocalness lbl, ptext SLIT("StgWord "), + pprCLabel lbl, ptext SLIT("[] = {") ] $$ hcat (punctuate comma (map (castToWord.pprAmode) amodes)) $$ ptext SLIT("};") @@ -1128,9 +1129,6 @@ That is, the indexing is done in units of kind1, but the resulting amode has kind2. \begin{code} -ppr_amode CBytesPerWord - = text "(sizeof(void*))" - ppr_amode (CVal reg_rel@(CIndex _ _ _) kind) = case (pprRegRelative False{-no sign wanted-} reg_rel) of (pp_reg, Nothing) -> panic "ppr_amode: CIndex" @@ -1213,9 +1211,6 @@ cCheckMacroText HP_CHK_L1 = SLIT("HP_CHK_L1") cCheckMacroText HP_CHK_UNBX_TUPLE = SLIT("HP_CHK_UNBX_TUPLE") \end{code} -\begin{code} -\end{code} - %************************************************************************ %* * \subsection[ppr-liveness-masks]{Liveness Masks} @@ -1223,34 +1218,8 @@ cCheckMacroText HP_CHK_UNBX_TUPLE = SLIT("HP_CHK_UNBX_TUPLE") %************************************************************************ \begin{code} -pp_bitmap_switch :: Int -> SDoc -> SDoc -> SDoc -pp_bitmap_switch size small large - | size <= mAX_SMALL_BITMAP_SIZE = small - | otherwise = large - --- magic numbers, must agree with BITMAP_BITS_SHIFT in InfoTables.h -mAX_SMALL_BITMAP_SIZE | wORD_SIZE == 4 = 27 - | otherwise = 58 - -pp_liveness_switch :: Liveness -> SDoc -> SDoc -> SDoc -pp_liveness_switch (Liveness _ size _) = pp_bitmap_switch size - -pp_bitset :: BitSet -> SDoc -pp_bitset s - | i < -1 = int (i + 1) <> text "-1" - | otherwise = int i - where i = intBS s - -pp_bitmap :: [BitSet] -> SDoc -pp_bitmap [] = int 0 -pp_bitmap ss = hcat (punctuate (ptext SLIT(" COMMA ")) (bundle ss)) where - bundle [] = [] - bundle [s] = [hcat bitmap32] - where bitmap32 = [ptext SLIT("BITMAP32"), lparen, - pp_bitset s, rparen] - bundle (s1:s2:ss) = hcat bitmap64 : bundle ss - where bitmap64 = [ptext SLIT("BITMAP64"), lparen, - pp_bitset s1, comma, pp_bitset s2, rparen] +bitmapAddrModes [] = [mkWordCLit 0] +bitmapAddrModes xs = map mkWordCLit xs \end{code} %************************************************************************ diff --git a/ghc/compiler/codeGen/Bitmap.hs b/ghc/compiler/codeGen/Bitmap.hs new file mode 100644 index 0000000000..ce0aa54ee1 --- /dev/null +++ b/ghc/compiler/codeGen/Bitmap.hs @@ -0,0 +1,79 @@ +-- +-- (c) The University of Glasgow 2003 +-- + +-- Functions for constructing bitmaps, which are used in various +-- places in generated code (stack frame liveness masks, function +-- argument liveness masks, SRT bitmaps). + +module Bitmap ( + Bitmap, mkBitmap, + intsToBitmap, intsToReverseBitmap, + mAX_SMALL_BITMAP_SIZE + ) where + +#include "HsVersions.h" +#include "../includes/MachDeps.h" + +import SMRep +import Constants +import DATA_BITS + +{-| +A bitmap represented by a sequence of 'StgWord's on the /target/ +architecture. These are used for bitmaps in info tables and other +generated code which need to be emitted as sequences of StgWords. +-} +type Bitmap = [StgWord] + +-- | Make a bitmap from a sequence of bits +mkBitmap :: [Bool] -> Bitmap +mkBitmap [] = [] +mkBitmap stuff = chunkToBitmap chunk : mkBitmap rest + where (chunk, rest) = splitAt wORD_SIZE_IN_BITS stuff + +chunkToBitmap :: [Bool] -> StgWord +chunkToBitmap chunk = + foldr (.|.) 0 [ 1 `shiftL` n | (True,n) <- zip chunk [0..] ] + +-- | Make a bitmap where the slots specified are the /ones/ in the bitmap. +-- eg. @[1,2,4], size 4 ==> 0xb@. +-- +-- The list of @Int@s /must/ be already sorted. +intsToBitmap :: Int -> [Int] -> Bitmap +intsToBitmap size slots{- must be sorted -} + | size <= 0 = [] + | otherwise = + (foldr (.|.) 0 (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) slots + +-- | 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). +-- +-- The list of @Int@s /must/ be already sorted. +intsToReverseBitmap :: Int -> [Int] -> Bitmap +intsToReverseBitmap 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) slots + init + | size >= wORD_SIZE_IN_BITS = complement 0 + | otherwise = (1 `shiftL` size) - 1 + +{-| +Magic number, must agree with @BITMAP_BITS_SHIFT@ in InfoTables.h. +Some kinds of bitmap pack a size/bitmap into a single word if +possible, or fall back to an external pointer when the bitmap is too +large. This value represents the largest size of bitmap that can be +packed into a single word. +-} +mAX_SMALL_BITMAP_SIZE :: Int +mAX_SMALL_BITMAP_SIZE | wORD_SIZE == 4 = 27 + | otherwise = 58 + diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs index edfe45e6aa..c91bbeedb5 100644 --- a/ghc/compiler/codeGen/CgBindery.lhs +++ b/ghc/compiler/codeGen/CgBindery.lhs @@ -36,7 +36,7 @@ import CgStackery ( freeStackSlots, getStackFrame ) import CLabel ( mkClosureLabel, mkBitmapLabel, pprCLabel ) import ClosureInfo ( mkLFImported, mkLFArgument, LambdaFormInfo ) -import BitSet +import Bitmap import PrimRep ( isFollowableRep, getPrimRepSize ) import Id ( Id, idPrimRep, idType ) import Type ( typePrimRep ) @@ -443,7 +443,7 @@ with initially all bits set (up to the size of the stack frame). buildLivenessMask :: VirtualSpOffset -- size of the stack frame -> VirtualSpOffset -- offset from which the bitmap should start - -> FCode LivenessMask -- mask for free/unlifted slots + -> FCode Bitmap -- mask for free/unlifted slots buildLivenessMask size sp = do { -- find all live stack-resident pointers @@ -459,24 +459,9 @@ buildLivenessMask size sp = do { }; ASSERT(all (>=0) rel_slots) - return (listToLivenessMask size rel_slots) + return (intsToReverseBitmap size rel_slots) } --- 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). -listToLivenessMask :: Int -> [Int] -> [BitSet] -listToLivenessMask size slots{- must be sorted -} - | size <= 0 = [] - | otherwise = init `minusBS` mkBS these : - listToLivenessMask (size - 32) (map (\x -> x - 32) rest) - where (these,rest) = span (<32) slots - init - | size >= 32 = all_ones - | otherwise = mkBS [0..size-1] - - all_ones = mkBS [0..31] - -- In a continuation, we want a liveness mask that starts from just after -- the return address, which is on the stack at realSp. @@ -493,7 +478,7 @@ buildContLivenessMask name = do mask <- buildLivenessMask frame_size (realSp-1) let liveness = Liveness (mkBitmapLabel name) frame_size mask - absC (CBitmap liveness) + absC (maybeLargeBitmap liveness) return liveness \end{code} diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs index 10dc2c1e9a..8c67334b28 100644 --- a/ghc/compiler/codeGen/CgCase.lhs +++ b/ghc/compiler/codeGen/CgCase.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgCase.lhs,v 1.61 2002/12/11 15:36:25 simonmar Exp $ +% $Id: CgCase.lhs,v 1.62 2003/05/14 09:13:53 simonmar Exp $ % %******************************************************** %* * @@ -53,7 +53,7 @@ import PrimOp ( primOpOutOfLine, PrimOp(..) ) import PrimRep ( getPrimRepSize, retPrimRepSize, PrimRep(..) ) import TyCon ( isEnumerationTyCon, isUnboxedTupleTyCon, tyConPrimRep ) -import Name ( getName ) +import Name ( Name, getName ) import Unique ( Unique, Uniquable(..), newTagUnique ) import Maybes ( maybeToBool ) import Util ( only ) @@ -389,9 +389,9 @@ cgEvalAlts :: Maybe VirtualSpOffset -- Offset of cost-centre to be restored, if cgEvalAlts cc_slot bndr srt alts = - let uniq = getUnique bndr in + let uniq = getUnique bndr; name = getName bndr in - buildContLivenessMask (getName bndr) `thenFC` \ liveness -> + buildContLivenessMask name `thenFC` \ liveness -> case alts of @@ -427,7 +427,7 @@ cgEvalAlts cc_slot bndr srt alts lbl = mkReturnInfoLabel uniq in cgUnboxedTupleAlt uniq cc_slot True alt `thenFC` \ abs_c -> - getSRTInfo srt `thenFC` \ srt_info -> + getSRTInfo name srt `thenFC` \ srt_info -> absC (CRetDirect uniq abs_c srt_info liveness) `thenC` returnFC (CaseAlts (CLbl lbl RetRep) Nothing False) @@ -450,7 +450,7 @@ cgEvalAlts cc_slot bndr srt alts cgAlgAlts GCMayHappen (not is_alg) uniq cc_slot use_labelled_alts alts deflt True `thenFC` \ (tagged_alt_absCs, deflt_absC) -> - mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness + mkReturnVector name tagged_alt_absCs deflt_absC srt liveness ret_conv `thenFC` \ return_vec -> returnFC (CaseAlts return_vec semi_tagged_stuff False) @@ -465,7 +465,7 @@ cgEvalAlts cc_slot bndr srt alts getAbsC (cgPrimEvalAlts bndr tycon alts deflt) `thenFC` \ abs_c -> -- Generate the labelled block, starting with restore-cost-centre - getSRTInfo srt `thenFC` \srt_info -> + getSRTInfo name srt `thenFC` \srt_info -> absC (CRetDirect uniq (cc_restore `mkAbsCStmts` abs_c) srt_info liveness) `thenC` @@ -810,7 +810,7 @@ Build a return vector, and return a suitable label addressing mode for it. \begin{code} -mkReturnVector :: Unique +mkReturnVector :: Name -> [(ConTag, AbstractC)] -- Branch codes -> AbstractC -- Default case -> SRT -- continuation's SRT @@ -818,8 +818,8 @@ mkReturnVector :: Unique -> CtrlReturnConvention -> FCode CAddrMode -mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv - = getSRTInfo srt `thenFC` \ srt_info -> +mkReturnVector name tagged_alt_absCs deflt_absC srt liveness ret_conv + = getSRTInfo name srt `thenFC` \ srt_info -> let (return_vec_amode, vtbl_body) = case ret_conv of { @@ -858,6 +858,7 @@ mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv returnFC return_vec_amode -- ) where + uniq = getUnique name vtbl_label = mkVecTblLabel uniq ret_label = mkReturnInfoLabel uniq diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index 20166c854b..ee6dfd4409 100644 --- a/ghc/compiler/codeGen/CgClosure.lhs +++ b/ghc/compiler/codeGen/CgClosure.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgClosure.lhs,v 1.59 2002/12/11 15:36:25 simonmar Exp $ +% $Id: CgClosure.lhs,v 1.60 2003/05/14 09:13:53 simonmar Exp $ % \section[CgClosure]{Code generation for closures} @@ -70,8 +70,11 @@ cgTopRhsClosure :: Id cgTopRhsClosure id ccs binder_info srt args body lf_info = + let + name = idName id + in -- LAY OUT THE OBJECT - getSRTInfo srt `thenFC` \ srt_info -> + getSRTInfo name srt `thenFC` \ srt_info -> moduleName `thenFC` \ mod_name -> let name = idName id @@ -177,10 +180,12 @@ cgRhsClosure binder cc binder_info srt fvs args body lf_info reduced_fvs = if binder_is_a_fv then fvs `minusList` [binder] else fvs + + name = idName binder in mapFCs getCAddrModeAndInfo reduced_fvs `thenFC` \ fvs_w_amodes_and_info -> - getSRTInfo srt `thenFC` \ srt_info -> + getSRTInfo name srt `thenFC` \ srt_info -> moduleName `thenFC` \ mod_name -> let descr = closureDescription mod_name (idName binder) @@ -303,7 +308,7 @@ closureCodeBody binder_info closure_info cc all_args body -- (case closureFunInfo closure_info of Just (_, ArgGen slow_lbl liveness) -> - absC (CBitmap liveness) `thenC` + absC (maybeLargeBitmap liveness) `thenC` absC (mkSlowEntryCode name slow_lbl arg_regs arg_reps) `thenC` returnFC (mkRegSaveCode arg_regs arg_reps) diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs index 324c5ccf36..9b654b9335 100644 --- a/ghc/compiler/codeGen/CgCon.lhs +++ b/ghc/compiler/codeGen/CgCon.lhs @@ -66,9 +66,8 @@ import List ( partition ) cgTopRhsCon :: Id -- Name of thing bound to this RHS -> DataCon -- Id -> [StgArg] -- Args - -> SRT -> FCode (Id, CgIdInfo) -cgTopRhsCon id con args srt +cgTopRhsCon id con args = ASSERT( not (isDllConApp con args) ) -- checks for litlit args too ASSERT( args `lengthIs` dataConRepArity con ) @@ -81,6 +80,7 @@ cgTopRhsCon id con args srt closure_label = mkClosureLabel name (closure_info, amodes_w_offsets) = layOutStaticConstr con getAmodeRep amodes + caffy = any stgArgHasCafRefs args in -- BUILD THE OBJECT @@ -89,7 +89,7 @@ cgTopRhsCon id con args srt closure_info dontCareCCS -- because it's static data (map fst amodes_w_offsets) -- Sorted into ptrs first, then nonptrs - (nonEmptySRT srt) -- has CAF refs + caffy -- has CAF refs ) `thenC` -- NOTE: can't use idCafInfo instead of nonEmptySRT above, -- because top-level constructors that were floated by diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs index c5fa38ab4a..14e27580b4 100644 --- a/ghc/compiler/codeGen/CgExpr.lhs +++ b/ghc/compiler/codeGen/CgExpr.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgExpr.lhs,v 1.52 2002/12/11 15:36:26 simonmar Exp $ +% $Id: CgExpr.lhs,v 1.53 2003/05/14 09:13:55 simonmar Exp $ % %******************************************************** %* * @@ -212,14 +212,14 @@ cgExpr (StgCase expr live_vars save_vars bndr srt alts) \subsection[let-and-letrec-codegen]{Converting @StgLet@ and @StgLetrec@} \begin{code} -cgExpr (StgLet (StgNonRec srt name rhs) expr) - = cgRhs srt name rhs `thenFC` \ (name, info) -> +cgExpr (StgLet (StgNonRec name rhs) expr) + = cgRhs name rhs `thenFC` \ (name, info) -> addBindC name info `thenC` cgExpr expr -cgExpr (StgLet (StgRec srt pairs) expr) +cgExpr (StgLet (StgRec pairs) expr) = fixC (\ new_bindings -> addBindsC new_bindings `thenC` - listFCs [ cgRhs srt b e | (b,e) <- pairs ] + listFCs [ cgRhs b e | (b,e) <- pairs ] ) `thenFC` \ new_bindings -> addBindsC new_bindings `thenC` @@ -278,15 +278,15 @@ We rely on the support code in @CgCon@ (to do constructors) and in @CgClosure@ (to do closures). \begin{code} -cgRhs :: SRT -> Id -> StgRhs -> FCode (Id, CgIdInfo) +cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo) -- the Id is passed along so a binding can be set up -cgRhs srt name (StgRhsCon maybe_cc con args) +cgRhs name (StgRhsCon maybe_cc con args) = getArgAmodes args `thenFC` \ amodes -> buildDynCon name maybe_cc con amodes `thenFC` \ idinfo -> returnFC (name, idinfo) -cgRhs srt name (StgRhsClosure cc bi fvs upd_flag args body) +cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body) = mkRhsClosure name cc bi srt fvs upd_flag args body \end{code} @@ -395,18 +395,17 @@ mkRhsClosure bndr cc bi srt fvs upd_flag args body %******************************************************** \begin{code} cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot - (StgNonRec srt binder rhs) + (StgNonRec binder rhs) = cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot - NonRecursive srt binder rhs + NonRecursive binder rhs `thenFC` \ (binder, info) -> addBindC binder info -cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot - (StgRec srt pairs) +cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec pairs) = fixC (\ new_bindings -> addBindsC new_bindings `thenC` listFCs [ cgLetNoEscapeRhs full_live_in_rhss - rhs_eob_info maybe_cc_slot Recursive srt b e + rhs_eob_info maybe_cc_slot Recursive b e | (b,e) <- pairs ] ) `thenFC` \ new_bindings -> @@ -421,13 +420,12 @@ cgLetNoEscapeRhs -> EndOfBlockInfo -> Maybe VirtualSpOffset -> RecFlag - -> SRT -> Id -> StgRhs -> FCode (Id, CgIdInfo) -cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec srt binder - (StgRhsClosure cc bi _ upd_flag args body) +cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder + (StgRhsClosure cc bi _ upd_flag srt args body) = -- We could check the update flag, but currently we don't switch it off -- for let-no-escaped things, so we omit the check too! -- case upd_flag of @@ -439,9 +437,9 @@ cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec srt binder -- For a constructor RHS we want to generate a single chunk of code which -- can be jumped to from many places, which will return the constructor. -- It's easy; just behave as if it was an StgRhsClosure with a ConApp inside! -cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec srt binder +cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder (StgRhsCon cc con args) - = cgLetNoEscapeClosure binder cc noBinderInfo{-safe-} srt + = cgLetNoEscapeClosure binder cc noBinderInfo{-safe-} NoSRT full_live_in_rhss rhs_eob_info maybe_cc_slot rec [] --No args; the binder is data structure, not a function (StgConApp con args) diff --git a/ghc/compiler/codeGen/CgLetNoEscape.lhs b/ghc/compiler/codeGen/CgLetNoEscape.lhs index 66c46e9f5d..a7521a3839 100644 --- a/ghc/compiler/codeGen/CgLetNoEscape.lhs +++ b/ghc/compiler/codeGen/CgLetNoEscape.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 % -% $Id: CgLetNoEscape.lhs,v 1.19 2002/12/11 15:36:26 simonmar Exp $ +% $Id: CgLetNoEscape.lhs,v 1.20 2003/05/14 09:13:56 simonmar Exp $ % %******************************************************** %* * @@ -33,7 +33,7 @@ import CLabel ( mkReturnInfoLabel ) import ClosureInfo ( mkLFLetNoEscape ) import CostCentre ( CostCentreStack ) import Name ( getName ) -import Id ( idPrimRep, Id ) +import Id ( Id, idPrimRep, idName ) import Var ( idUnique ) import PrimRep ( PrimRep(..), retPrimRepSize, isFollowableRep ) import BasicTypes ( RecFlag(..) ) @@ -178,7 +178,7 @@ cgLetNoEscapeClosure buildContLivenessMask (getName binder) `thenFC` \ liveness -> forkAbsC (cgLetNoEscapeBody binder cc args body uniq) `thenFC` \ code -> - getSRTInfo srt `thenFC` \ srt_info -> + getSRTInfo (idName binder) srt `thenFC` \ srt_info -> absC (CRetDirect uniq code srt_info liveness) `thenC` returnFC ()) `thenFC` \ (vSp, _) -> diff --git a/ghc/compiler/codeGen/CgMonad.lhs b/ghc/compiler/codeGen/CgMonad.lhs index a14b77a562..99c776e34e 100644 --- a/ghc/compiler/codeGen/CgMonad.lhs +++ b/ghc/compiler/codeGen/CgMonad.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgMonad.lhs,v 1.37 2003/01/07 14:31:20 simonmar Exp $ +% $Id: CgMonad.lhs,v 1.38 2003/05/14 09:13:56 simonmar Exp $ % \section[CgMonad]{The code generation monad} @@ -60,8 +60,10 @@ import CmdLineOpts ( opt_SccProfilingOn, opt_DoTickyProfiling ) import Module ( Module ) import DataCon ( ConTag ) import Id ( Id ) +import Name ( Name ) import VarEnv import PrimRep ( PrimRep(..) ) +import SMRep ( StgHalfWord, hALF_WORD ) import FastString import Outputable @@ -605,16 +607,25 @@ bindings use sub-sections of this SRT. The label is passed down to the nested bindings via the monad. \begin{code} -getSRTInfo :: SRT -> FCode C_SRT -getSRTInfo NoSRT = return NoC_SRT -getSRTInfo (SRT off len) = do srt_lbl <- getSRTLabel - return (C_SRT srt_lbl off len) +getSRTInfo :: Name -> SRT -> FCode C_SRT +getSRTInfo id NoSRT = return NoC_SRT +getSRTInfo id (SRT off len bmp) + | len > hALF_WORD || bmp == [fromIntegral srt_escape] = do + srt_lbl <- getSRTLabel + let srt_desc_lbl = mkSRTDescLabel id + absC (CSRTDesc srt_desc_lbl srt_lbl off len bmp) + return (C_SRT srt_desc_lbl 0 srt_escape) + | otherwise = do + srt_lbl <- getSRTLabel + return (C_SRT srt_lbl off (fromIntegral (head bmp))) + +srt_escape = (-1) :: StgHalfWord getSRTLabel :: FCode CLabel -- Used only by cgPanic getSRTLabel = do MkCgInfoDown _ _ srt_lbl _ _ <- getInfoDown return srt_lbl -setSRTLabel :: CLabel -> Code -> Code +setSRTLabel :: CLabel -> FCode a -> FCode a setSRTLabel srt_lbl code = do MkCgInfoDown c_info statics _ ticky eob_info <- getInfoDown withInfoDown code (MkCgInfoDown c_info statics srt_lbl ticky eob_info) diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs index 02bdd47f84..9965895f8b 100644 --- a/ghc/compiler/codeGen/CgTailCall.lhs +++ b/ghc/compiler/codeGen/CgTailCall.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgTailCall.lhs,v 1.36 2002/12/11 15:36:27 simonmar Exp $ +% $Id: CgTailCall.lhs,v 1.37 2003/05/14 09:13:56 simonmar Exp $ % %******************************************************** %* * @@ -346,12 +346,6 @@ mkStaticAlgReturnCode con sequel -- Generate the right jump or return (case sequel of - UpdateCode -> -- Ha! We can go direct to the update code, - -- (making sure to jump to the *correct* update - -- code.) - absC (CReturn (CLbl mkUpdInfoLabel CodePtrRep) - return_info) - CaseAlts _ (Just (alts, _)) False -> -- Ho! We know the constructor so -- we can go right to the alternative @@ -363,7 +357,8 @@ mkStaticAlgReturnCode con sequel -- it's the subject of a wad of special-case -- code in cgReturnCon - other -> -- OnStack, or (CaseAlts ret_amode Nothing) + other -> -- OnStack, or (CaseAlts ret_amode Nothing), + -- or UpdateCode. sequelToAmode sequel `thenFC` \ ret_amode -> absC (CReturn ret_amode return_info) ) diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index 2ce87b7454..651c007ae7 100644 --- a/ghc/compiler/codeGen/ClosureInfo.lhs +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: ClosureInfo.lhs,v 1.56 2002/12/12 11:53:11 simonmar Exp $ +% $Id: ClosureInfo.lhs,v 1.57 2003/05/14 09:13:56 simonmar Exp $ % \section[ClosureInfo]{Data structures which describe closures} @@ -85,10 +85,9 @@ import FastString import Outputable import Literal import Constants -import BitSet +import Bitmap import Maybe ( isJust ) -import DATA_WORD import DATA_BITS \end{code} @@ -1106,19 +1105,12 @@ argDescr nm [PtrRep,PtrRep,PtrRep,PtrRep,PtrRep,PtrRep] = ArgSpec ARG_PPPPPP argDescr name reps = ArgGen (mkSlowEntryLabel name) liveness where bitmap = argBits reps lbl = mkBitmapLabel name - liveness = Liveness lbl (length bitmap) - (map chunkToLiveness (mkChunks bitmap)) + liveness = Liveness lbl (length bitmap) (mkBitmap bitmap) argBits [] = [] argBits (rep : args) | isFollowableRep rep = False : argBits args | otherwise = take (getPrimRepSize rep) (repeat True) ++ argBits args - -mkChunks [] = [] -mkChunks stuff = chunk : mkChunks rest - where (chunk, rest) = splitAt 32 stuff - -chunkToLiveness chunk = mkBS [ n | (True,n) <- zip chunk [0..] ] \end{code} @@ -1133,14 +1125,6 @@ Here we make a concrete info table, represented as a list of CAddrMode represented by a label+offset expression). \begin{code} -#if SIZEOF_HSWORD == 4 -type StgWord = Word32 -#define HALF_WORD 16 -#elif SIZEOF_HSWORD == 8 -type StgWord = Word64 -#define HALF_WORD 32 -#endif - mkInfoTable :: ClosureInfo -> [CAddrMode] mkInfoTable cl_info | opt_Unregisterised = std_info ++ extra_bits @@ -1168,13 +1152,13 @@ mkInfoTable cl_info is_con = isJust semi_tag (srt_label,srt_len) - | Just tag <- semi_tag = (mkIntCLit 0, tag) -- constructor + | Just tag <- semi_tag = (mkIntCLit 0, fromIntegral tag) -- constructor | otherwise = case srt of NoC_SRT -> (mkIntCLit 0, 0) - C_SRT lbl off len -> + C_SRT lbl off bitmap -> (CAddr (CIndex (CLbl lbl DataPtrRep) (mkIntCLit off) WordRep), - len) + bitmap) ptrs = closurePtrsSize cl_info nptrs = size - ptrs @@ -1182,9 +1166,9 @@ mkInfoTable cl_info layout_info :: StgWord #ifdef WORDS_BIGENDIAN - layout_info = (fromIntegral ptrs `shiftL` HALF_WORD) .|. fromIntegral nptrs + layout_info = (fromIntegral ptrs `shiftL` hALF_WORD) .|. fromIntegral nptrs #else - layout_info = (fromIntegral ptrs) .|. (fromIntegral nptrs `shiftL` HALF_WORD) + layout_info = (fromIntegral ptrs) .|. (fromIntegral nptrs `shiftL` hALF_WORD) #endif layout_amode = mkWordCLit layout_info @@ -1215,10 +1199,10 @@ mkInfoTable cl_info | otherwise = [fun_amode] #ifdef WORDS_BIGENDIAN - fun_desc = (fromIntegral fun_type `shiftL` HALF_WORD) .|. fromIntegral arity + fun_desc = (fromIntegral fun_type `shiftL` hALF_WORD) .|. fromIntegral arity #else - fun_desc = (fromIntegral fun_type) .|. (fromIntegral arity `shiftL` HALF_WORD) -#endif + fun_desc = (fromIntegral fun_type) .|. (fromIntegral arity `shiftL` hALF_WORD) +#endif fun_amode = mkWordCLit fun_desc @@ -1252,13 +1236,13 @@ mkBitmapInfoTable entry_amode srt liveness vector cl_type srt_len liveness_amode liveness_amode = livenessToAddrMode liveness - + (srt_label,srt_len) = case srt of NoC_SRT -> (mkIntCLit 0, 0) - C_SRT lbl off len -> - (CAddr (CIndex (CLbl lbl DataPtrRep) (mkIntCLit off) WordRep), - len) + C_SRT lbl off bitmap -> + (CAddr (CIndex (CLbl lbl DataPtrRep) (mkIntCLit off) WordRep), + bitmap) cl_type = case (null vector, isBigLiveness liveness) of (True, True) -> rET_BIG @@ -1280,7 +1264,7 @@ mkStdInfoTable -> CAddrMode -- closure type descr (profiling) -> CAddrMode -- closure descr (profiling) -> Int -- closure type - -> Int -- SRT length + -> StgHalfWord -- SRT length -> CAddrMode -- layout field -> [CAddrMode] mkStdInfoTable entry_lbl type_descr closure_descr cl_type srt_len layout_amode @@ -1307,11 +1291,11 @@ mkStdInfoTable entry_lbl type_descr closure_descr cl_type srt_len layout_amode -- ToDo: do this using .byte and .word directives. type_info :: StgWord #ifdef WORDS_BIGENDIAN - type_info = (fromIntegral cl_type `shiftL` HALF_WORD) .|. + type_info = (fromIntegral cl_type `shiftL` hALF_WORD) .|. (fromIntegral srt_len) #else type_info = (fromIntegral cl_type) .|. - (fromIntegral srt_len `shiftL` HALF_WORD) + (fromIntegral srt_len `shiftL` hALF_WORD) #endif isBigLiveness (Liveness _ size _) = size > mAX_SMALL_BITMAP_SIZE @@ -1324,13 +1308,8 @@ livenessToAddrMode (Liveness lbl size bits) small = mkWordCLit (fromIntegral size .|. (small_bits `shiftL` bITMAP_BITS_SHIFT)) small_bits = case bits of [] -> 0 - [b] -> fromIntegral (intBS b) + [b] -> fromIntegral b _ -> panic "livenessToAddrMode" -mAX_SMALL_BITMAP_SIZE = (wORD_SIZE * 8) - bITMAP_BITS_SHIFT - -mkWordCLit :: StgWord -> CAddrMode -mkWordCLit wd = CLit (MachWord (fromIntegral wd)) - zero_amode = mkIntCLit 0 \end{code} diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index 5bcfc69317..724352cf16 100644 --- a/ghc/compiler/codeGen/CodeGen.lhs +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -29,7 +29,7 @@ import StgSyn import CgMonad import AbsCSyn import PrelNames ( gHC_PRIM ) -import CLabel ( CLabel, mkSRTLabel, mkClosureLabel, +import CLabel ( mkSRTLabel, mkClosureLabel, mkPlainModuleInitLabel, mkModuleInitLabel ) import PprAbsC ( dumpRealC ) import AbsCUtils ( mkAbstractCs, flattenAbsC ) @@ -40,8 +40,7 @@ import CgConTbls ( genStaticConBits ) import ClosureInfo ( mkClosureLFInfo ) import CmdLineOpts ( DynFlags, DynFlag(..), opt_SccProfilingOn, opt_EnsureSplittableC ) -import HscTypes ( ModGuts(..), ModGuts, ForeignStubs(..), TypeEnv, - typeEnvTyCons ) +import HscTypes ( ForeignStubs(..), TypeEnv, typeEnvTyCons ) import CostCentre ( CollectedCCs ) import Id ( Id, idName, setIdName ) import Name ( nameSrcLoc, nameOccName, nameUnique, isInternalName, mkExternalName ) @@ -68,7 +67,7 @@ codeGen :: DynFlags -> ForeignStubs -> [Module] -- directly-imported modules -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. - -> [(StgBinding,[Id])] -- Bindings to convert, with SRTs + -> [(StgBinding,[(Id,[Id])])] -- Bindings to convert, with SRTs -> IO AbstractC -- Output codeGen dflags this_mod type_env foreign_stubs imported_mods @@ -202,43 +201,39 @@ style, with the increasing static environment being plumbed as a state variable. \begin{code} -cgTopBinding :: (StgBinding,[Id]) -> Code -cgTopBinding (StgNonRec srt_info id rhs, srt) +cgTopBinding :: (StgBinding,[(Id,[Id])]) -> Code +cgTopBinding (StgNonRec id rhs, srts) = absC maybeSplitCode `thenC` - maybeExternaliseId id `thenFC` \ id' -> - let - srt_label = mkSRTLabel (idName id') - in - mkSRT srt_label srt [] `thenC` - setSRTLabel srt_label ( - cgTopRhs id' rhs srt_info `thenFC` \ (id, info) -> - addBindC id info -- Add the un-externalised Id to the envt, so we - -- find it when we look up occurrences - ) - -cgTopBinding (StgRec srt_info pairs, srt) + maybeExternaliseId id `thenFC` \ id' -> + mapM_ (mkSRT [id']) srts `thenC` + cgTopRhs id' rhs `thenFC` \ (id, info) -> + addBindC id info `thenC` + -- Add the un-externalised Id to the envt, so we + -- find it when we look up occurrences + nopC + +cgTopBinding (StgRec pairs, srts) = absC maybeSplitCode `thenC` let (bndrs, rhss) = unzip pairs in - mapFCs maybeExternaliseId bndrs `thenFC` \ bndrs'@(id:_) -> + mapFCs maybeExternaliseId bndrs `thenFC` \ bndrs' -> let - srt_label = mkSRTLabel (idName id) - pairs' = zip bndrs' rhss + pairs' = zip bndrs' rhss in - mkSRT srt_label srt bndrs' `thenC` - setSRTLabel srt_label ( - fixC (\ new_binds -> + mapM_ (mkSRT bndrs') srts `thenC` + fixC (\ new_binds -> addBindsC new_binds `thenC` - mapFCs ( \ (b,e) -> cgTopRhs b e srt_info ) pairs' - ) `thenFC` \ new_binds -> nopC - ) + mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' + ) `thenFC` \ new_binds -> + nopC -mkSRT :: CLabel -> [Id] -> [Id] -> Code -mkSRT lbl [] these = nopC -mkSRT lbl ids these +mkSRT :: [Id] -> (Id,[Id]) -> Code +mkSRT these (id,[]) = nopC +mkSRT these (id,ids) = mapFCs remap ids `thenFC` \ ids -> - absC (CSRT lbl (map (mkClosureLabel . idName) ids)) + remap id `thenFC` \ id -> + absC (CSRT (mkSRTLabel (idName id)) (map (mkClosureLabel . idName) ids)) where -- sigh, better map all the ids against the environment in case they've -- been externalised (see maybeExternaliseId below). @@ -251,19 +246,21 @@ mkSRT lbl ids these -- to enclose the listFCs in cgTopBinding, but that tickled the -- statics "error" call in initC. I DON'T UNDERSTAND WHY! -cgTopRhs :: Id -> StgRhs -> SRT -> FCode (Id, CgIdInfo) +cgTopRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo) -- The Id is passed along for setting up a binding... -- It's already been externalised if necessary -cgTopRhs bndr (StgRhsCon cc con args) srt - = forkStatics (cgTopRhsCon bndr con args srt) +cgTopRhs bndr (StgRhsCon cc con args) + = forkStatics (cgTopRhsCon bndr con args) -cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag args body) srt +cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag srt args body) = ASSERT(null fvs) -- There should be no free variables let + srt_label = mkSRTLabel (idName bndr) lf_info = mkClosureLFInfo bndr TopLevel [{-no fvs-}] upd_flag args in - forkStatics (cgTopRhsClosure bndr cc bi srt args body lf_info) + setSRTLabel srt_label $ + forkStatics (cgTopRhsClosure bndr cc bi srt args body lf_info) \end{code} diff --git a/ghc/compiler/codeGen/SMRep.lhs b/ghc/compiler/codeGen/SMRep.lhs index 6838287413..4f53f4bfee 100644 --- a/ghc/compiler/codeGen/SMRep.lhs +++ b/ghc/compiler/codeGen/SMRep.lhs @@ -12,20 +12,21 @@ module SMRep ( isStaticRep, fixedHdrSize, arrWordsHdrSize, arrPtrsHdrSize, stdItblSize, retItblSize, - getSMRepClosureTypeInt + getSMRepClosureTypeInt, - , rET_SMALL - , rET_VEC_SMALL - , rET_BIG - , rET_VEC_BIG + rET_SMALL, rET_VEC_SMALL, rET_BIG, rET_VEC_BIG, + StgWord, StgHalfWord, hALF_WORD, ) where #include "HsVersions.h" +#include "../includes/MachDeps.h" import CmdLineOpts import Constants import Outputable + +import DATA_WORD \end{code} %************************************************************************ @@ -148,3 +149,19 @@ rET_VEC_SMALL = (RET_VEC_SMALL :: Int) rET_BIG = (RET_BIG :: Int) rET_VEC_BIG = (RET_VEC_BIG :: Int) \end{code} + +A type representing an StgWord on the target platform. + +\begin{code} +#if SIZEOF_HSWORD == 4 +type StgWord = Word32 +type StgHalfWord = Word16 +hALF_WORD = 16 :: Int +#elif SIZEOF_HSWORD == 8 +type StgWord = Word64 +type StgHalfWord = Word32 +hALF_WORD = 32 :: Int +#else +#error unknown SIZEOF_HSWORD +#endif +\end{code} diff --git a/ghc/compiler/ghci/ByteCodeAsm.lhs b/ghc/compiler/ghci/ByteCodeAsm.lhs index 599eb1c188..d1a737abc8 100644 --- a/ghc/compiler/ghci/ByteCodeAsm.lhs +++ b/ghc/compiler/ghci/ByteCodeAsm.lhs @@ -29,6 +29,7 @@ import PrimOp ( PrimOp ) import PrimRep ( PrimRep(..), isFollowableRep, is64BitRep ) import Constants ( wORD_SIZE ) import FastString ( FastString(..), unpackFS ) +import SMRep ( StgWord ) import FiniteMap import Outputable diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index d5dca0e36d..3a704a7f25 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -52,7 +52,8 @@ 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 ) @@ -206,32 +207,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) slots - init - | size >= wORD_SIZE_IN_BITS = complement 0 - | otherwise = (1 `shiftL` size) - 1 - -wORD_SIZE_IN_BITS = wORD_SIZE * 8 :: Int - -- ----------------------------------------------------------------------------- -- schemeTopBind @@ -759,7 +734,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) diff --git a/ghc/compiler/ghci/ByteCodeInstr.lhs b/ghc/compiler/ghci/ByteCodeInstr.lhs index 0d812e40c9..05c4fe4734 100644 --- a/ghc/compiler/ghci/ByteCodeInstr.lhs +++ b/ghc/compiler/ghci/ByteCodeInstr.lhs @@ -5,11 +5,11 @@ \begin{code} module ByteCodeInstr ( - BCInstr(..), ProtoBCO(..), StgWord, bciStackUse + BCInstr(..), ProtoBCO(..), bciStackUse ) where #include "HsVersions.h" -#include "MachDeps.h" +#include "../includes/MachDeps.h" import Outputable import Name ( Name ) @@ -21,20 +21,12 @@ import PrimRep ( PrimRep ) import DataCon ( DataCon ) import VarSet ( VarSet ) import PrimOp ( PrimOp ) +import SMRep ( StgWord ) import GHC.Ptr -import Data.Word - -- ---------------------------------------------------------------------------- -- Bytecode instructions --- The appropriate StgWord type for this platform (needed for bitmaps) -#if SIZEOF_HSWORD == 4 -type StgWord = Word32 -#else -type StgWord = Word64 -#endif - data ProtoBCO a = ProtoBCO { protoBCOName :: a, -- name, in some sense diff --git a/ghc/compiler/main/Constants.lhs b/ghc/compiler/main/Constants.lhs index 9c32fa1a36..5c35e58e6a 100644 --- a/ghc/compiler/main/Constants.lhs +++ b/ghc/compiler/main/Constants.lhs @@ -61,6 +61,7 @@ module Constants ( wORD64_SIZE, wORD_SIZE, + wORD_SIZE_IN_BITS, bLOCK_SIZE, bLOCK_SIZE_W, @@ -220,6 +221,7 @@ Size of a word, in bytes \begin{code} wORD_SIZE = (SIZEOF_HSWORD :: Int) +wORD_SIZE_IN_BITS = wORD_SIZE * 8 :: Int \end{code} Size of a storage manager block (in bytes). diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs index 05e0a5de90..08fb706550 100644 --- a/ghc/compiler/nativeGen/AbsCStixGen.lhs +++ b/ghc/compiler/nativeGen/AbsCStixGen.lhs @@ -38,7 +38,6 @@ import Constants ( wORD_SIZE, bITMAP_BITS_SHIFT ) import Name ( NamedThing(..) ) import CmdLineOpts ( opt_Static, opt_EnsureSplittableC ) import Outputable ( assertPanic ) -import BitSet ( BitSet, intBS ) -- DEBUGGING ONLY --import TRACE ( trace ) @@ -83,14 +82,9 @@ Here we handle top-level things, like @CCodeBlock@s and gentopcode stmt@(CStaticClosure lbl closure_info _ _) = genCodeStaticClosure stmt `thenUs` \ code -> - returnUs ( - if opt_Static - then StSegment DataSegment - : StLabel lbl : code [] - else StSegment DataSegment - : StData PtrRep [StInt 0] -- DLLised world, need extra zero word - : StLabel lbl : code [] - ) + returnUs ( StSegment DataSegment + : StLabel lbl : code [] + ) gentopcode stmt@(CRetVector lbl amodes srt liveness) = returnUs ( StSegment TextSegment @@ -139,18 +133,21 @@ Here we handle top-level things, like @CCodeBlock@s and = StCLbl label gentopcode stmt@(CBitmap l@(Liveness lbl size mask)) - | isBigLiveness l = returnUs [ StSegment TextSegment , StLabel lbl - , StData WordRep (map StInt (toInteger size : bitmapToIntegers mask)) + , StData WordRep (map StInt (toInteger size : map toInteger mask)) + ] + + gentopcode stmt@(CSRTDesc lbl srt_lbl off len bitmap) + = returnUs + [ StSegment TextSegment + , StLabel lbl + , StData WordRep ( + StIndex PtrRep (StCLbl srt_lbl) (StInt (toInteger off)) : + map StInt (toInteger len : map toInteger bitmap) + ) ] - | otherwise - = returnUs [] - where - -- ToDo: translate out bitmaps earlier, like info tables - isBigLiveness (Liveness _ size _) = size > mAX_SMALL_BITMAP_SIZE - mAX_SMALL_BITMAP_SIZE = (wORD_SIZE * 8) - bITMAP_BITS_SHIFT gentopcode stmt@(CClosureTbl tycon) = returnUs [ StSegment TextSegment @@ -658,25 +655,6 @@ mkJoin code lbl %--------------------------------------------------------------------------- -\begin{code} -bitmapToIntegers :: [BitSet] -> [Integer] -bitmapToIntegers = bundle . map (toInteger . intBS) - where -#if BYTES_PER_WORD == 4 - bundle = id -#else - bundle [] = [] - bundle is = case splitAt (BYTES_PER_WORD/4) is of - (these, those) -> - ( foldr1 (\x y -> x + 4294967296 * y) - [x `mod` 4294967296 | x <- these] - : bundle those - ) -#endif -\end{code} - -%--------------------------------------------------------------------------- - This answers the question: Can the code fall through to the next line(s) of code? This errs towards saying True if it can't choose, because it is used for eliminating needless jumps. In other words, if diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index 40a2ad49ec..1721e73344 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -142,9 +142,6 @@ amodeToStix am@(CVal rr CharRep) amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr)) -amodeToStix CBytesPerWord - = StInt (toInteger wORD_SIZE) - amodeToStix (CAddr (SpRel off)) = StIndex PtrRep (StReg stgSp) (StInt (toInteger (iBox off))) diff --git a/ghc/compiler/simplStg/SRT.lhs b/ghc/compiler/simplStg/SRT.lhs index 86fb305c7a..89ef8e43ef 100644 --- a/ghc/compiler/simplStg/SRT.lhs +++ b/ghc/compiler/simplStg/SRT.lhs @@ -14,233 +14,170 @@ module SRT( computeSRTs ) where import StgSyn import Id ( Id ) import VarSet -import BasicTypes ( TopLevelFlag(..), isTopLevel ) -import Util ( mapAccumL ) +import VarEnv +import Util ( sortLt ) +import Maybes ( orElse ) +import Maybes ( expectJust ) +import Bitmap ( intsToBitmap ) #ifdef DEBUG -import Util ( lengthIs ) import Outputable #endif -\end{code} -\begin{code} -computeSRTs :: [StgBinding] -> [(StgBinding,[Id])] - -- The incoming bindingd are filled with SRTEntries in their SRT slots - -- the outgoing ones have NoSRT/SRT values instead +import List -computeSRTs binds = map srtTopBind binds +import Util +import Outputable \end{code} ------------------------------------------------------------------------------ -Algorithm for figuring out SRT layout. - -Our functions have type - -srtExpr :: SrtOffset -- Next free offset within the SRT - -> StgExpr -- Expression to analyse - -> (StgExpr, -- (e) newly annotated expression - SrtIds, -- (s) SRT required for this expression (reversed) - SrtOffset) -- (o) new offset - -We build a single SRT for a recursive binding group, which is why the -SRT building is done at the binding level rather than the -StgRhsClosure level. - -The SRT is built up in reverse order, to avoid too many expensive -appends. We therefore reverse the SRT before returning it, so that -the offsets will be from the beginning of the SRT. - ------------------------------------------------------------------------------ -Top-level Bindings - -A function whose CafInfo is NoCafRefs will have an empty SRT, and its -closure will not appear in the SRT of any other function (unless we're -compiling without optimisation and the CafInfos haven't been emitted -in the interface files). - -Top-Level recursive groups - -This gets a bit complicated, but the general idea is that we want a -single SRT for the whole group, and we'd rather not have recursive -references in it if at all possible. - -We collect all the global references for the group, and filter out -those that are binders in the group and not CAFs themselves. Why is -it done this way? - - - if all the bindings in the group just refer to each other, - and none of them are CAFs, we'd like to get an empty SRT. - - - if any of the bindings in the group refer to a CAF, this will - appear in the SRT. - -Hmm, that probably makes no sense. - \begin{code} -type SrtOffset = Int -type SrtIds = [Id] -- An *reverse-ordered* list of the Ids needed in the SRT - -srtTopBind :: StgBinding -> (StgBinding, SrtIds) - -srtTopBind bind - = srtBind TopLevel 0 bind =: \ (bind', srt, off) -> - if isConBind bind' - then (bind', []) -- Don't need an SRT for a static constructor - else (bind', reverse srt) -- The 'reverse' is because the SRT is - -- built up reversed, for efficiency's sake +computeSRTs :: [StgBinding] -> [(StgBinding,[(Id,[Id])])] + -- The incoming bindingd are filled with SRTEntries in their SRT slots + -- the outgoing ones have NoSRT/SRT values instead -isConBind (StgNonRec _ _ r) = isConRhs r -isConBind (StgRec _ bs) = all isConRhs (map snd bs) +computeSRTs binds = srtTopBinds emptyVarEnv binds -isConRhs (StgRhsCon _ _ _) = True -isConRhs _ = False +-- -------------------------------------------------------------------------- +-- Top-level Bindings -srtBind :: TopLevelFlag -> SrtOffset -> StgBinding - -> (StgBinding, SrtIds, SrtOffset) +srtTopBinds :: IdEnv Id -> [StgBinding] -> [(StgBinding, [(Id,[Id])])] -srtBind top off (StgNonRec (SRTEntries rhs_cafs) binder rhs) - = (StgNonRec srt_info binder new_rhs, this_srt, body_off) +srtTopBinds env [] = [] +srtTopBinds env (StgNonRec b rhs : binds) = + (StgNonRec b rhs', [(b,srt')]) : srtTopBinds env' binds where - (new_rhs, rhs_srt, rhs_off) = srtRhs off rhs - (srt_info, this_srt, body_off) = constructSRT rhs_cafs rhs_srt off rhs_off - - -srtBind top off (StgRec (SRTEntries rhss_cafs) pairs) - = (StgRec srt_info new_pairs, this_srt, body_off) + (rhs', srt) = srtTopRhs b rhs + env' = maybeExtendEnv env b rhs + srt' = applyEnvList env srt +srtTopBinds env (StgRec bs : binds) = + (StgRec (zip bndrs rhss), zip bndrs srts') : srtTopBinds env binds + where + (rhss, srts) = unzip [ srtTopRhs b r | (b,r) <- bs ] + bndrs = map fst bs + srts' = map (applyEnvList env) srts + +-- Shorting out indirections in SRTs: if a binding has an SRT with a single +-- element in it, we just inline it with that element everywhere it occurs +-- in other SRTs. +-- +-- This is in a way a generalisation of the CafInfo. CafInfo says +-- whether a top-level binding has *zero* CAF references, allowing us +-- to omit it from SRTs. Here, we pick up bindings with *one* CAF +-- reference, and inline its SRT everywhere it occurs. We could pass +-- this information across module boundaries too, but we currently +-- don't. + +maybeExtendEnv env bndr (StgRhsClosure _ _ _ ReEntrant (SRTEntries cafs) _ _) + | [one] <- varSetElems cafs + = extendVarEnv env bndr (applyEnv env one) +maybeExtendEnv env bndr _ = env + +applyEnvList :: IdEnv Id -> [Id] -> [Id] +applyEnvList env = map (applyEnv env) + +applyEnv env id = lookupVarEnv env id `orElse` id + +-- ---- Top-level right hand sides: + +srtTopRhs :: Id -> StgRhs -> (StgRhs, [Id]) + +srtTopRhs binder rhs@(StgRhsCon _ _ _) = (rhs, []) +srtTopRhs binder rhs@(StgRhsClosure _ _ _ _ (SRTEntries cafs) _ _) + = (srtRhs table rhs, elems) where - ((rhss_off, rhss_srt), new_pairs) = mapAccumL do_bind (off, []) pairs + elems = varSetElems cafs + table = mkVarEnv (zip elems [0..]) - do_bind (off,srt) (bndr,rhs) - = srtRhs off rhs =: \(rhs', srt', off') -> - ((off', srt'++srt), (bndr, rhs')) +-- ---- Binds: - non_caf_binders = [ b | (b, rhs) <- pairs, not (caf_rhs rhs) ] +srtBind :: IdEnv Int -> StgBinding -> StgBinding - filtered_rhss_cafs - | isTopLevel top = filterVarSet (`notElem` non_caf_binders) rhss_cafs - | otherwise = rhss_cafs +srtBind table (StgNonRec binder rhs) = StgNonRec binder (srtRhs table rhs) +srtBind table (StgRec pairs) = StgRec [ (b, srtRhs table r) | (b,r) <- pairs ] - (srt_info, this_srt, body_off) - = constructSRT filtered_rhss_cafs rhss_srt off rhss_off +-- ---- Right Hand Sides: -caf_rhs (StgRhsClosure _ _ free_vars _ [] body) = True -caf_rhs _ = False -\end{code} +srtRhs :: IdEnv Int -> StgRhs -> StgRhs ------------------------------------------------------------------------------ -Right Hand Sides +srtRhs table e@(StgRhsCon cc con args) = e +srtRhs table (StgRhsClosure cc bi free_vars u (SRTEntries cafs) args body) + = StgRhsClosure cc bi free_vars u (constructSRT table cafs) args + $! (srtExpr table body) -\begin{code} -srtRhs :: SrtOffset -> StgRhs -> (StgRhs, SrtIds, SrtOffset) +-- --------------------------------------------------------------------------- +-- Expressions -srtRhs off (StgRhsClosure cc bi free_vars u args body) - = srtExpr off body =: \(body, srt, off) -> - (StgRhsClosure cc bi free_vars u args body, srt, off) +srtExpr :: IdEnv Int -> StgExpr -> StgExpr -srtRhs off e@(StgRhsCon cc con args) = (e, [], off) -\end{code} +srtExpr table e@(StgApp f args) = e +srtExpr table e@(StgLit l) = e +srtExpr table e@(StgConApp con args) = e +srtExpr table e@(StgOpApp op args ty) = e ------------------------------------------------------------------------------ -Expressions +srtExpr table (StgSCC cc expr) = StgSCC cc $! srtExpr table expr -\begin{code} -srtExpr :: SrtOffset -> StgExpr -> (StgExpr, SrtIds, SrtOffset) - -srtExpr off e@(StgApp f args) = (e, [], off) -srtExpr off e@(StgLit l) = (e, [], off) -srtExpr off e@(StgConApp con args) = (e, [], off) -srtExpr off e@(StgOpApp op args ty) = (e, [], off) - -srtExpr off (StgSCC cc expr) = - srtExpr off expr =: \(expr, srt, off) -> - (StgSCC cc expr, srt, off) - -srtExpr off (StgCase scrut live1 live2 uniq (SRTEntries cafs_in_alts) alts) - = srtCaseAlts off alts =: \(alts, alts_srt, alts_off) -> - let - (srt_info, this_srt, scrut_off) - = constructSRT cafs_in_alts alts_srt off alts_off +srtExpr table (StgCase scrut live1 live2 uniq (SRTEntries cafs_in_alts) alts) + = let + expr' = srtExpr table scrut + srt_info = constructSRT table cafs_in_alts + alts' = srtCaseAlts table alts in - srtExpr scrut_off scrut =: \(scrut, scrut_srt, case_off) -> + StgCase expr' live1 live2 uniq srt_info alts' - (StgCase scrut live1 live2 uniq srt_info alts, - scrut_srt ++ this_srt, - case_off) - -srtExpr off (StgLet bind body) - = srtBind NotTopLevel off bind =: \ (bind', bind_srt, body_off) -> - srtExpr body_off body =: \ (body', expr_srt, let_off) -> - (StgLet bind' body', expr_srt ++ bind_srt, let_off) +srtExpr table (StgLet bind body) + = srtBind table bind =: \ bind' -> + srtExpr table body =: \ body' -> + StgLet bind' body' -srtExpr off (StgLetNoEscape live1 live2 bind body) - = srtBind NotTopLevel off bind =: \ (bind', bind_srt, body_off) -> - srtExpr body_off body =: \ (body', expr_srt, let_off) -> - (StgLetNoEscape live1 live2 bind' body', expr_srt ++ bind_srt, let_off) +srtExpr table (StgLetNoEscape live1 live2 bind body) + = srtBind table bind =: \ bind' -> + srtExpr table body =: \ body' -> + StgLetNoEscape live1 live2 bind' body' #ifdef DEBUG -srtExpr off expr = pprPanic "srtExpr" (ppr expr) +srtExpr table expr = pprPanic "srtExpr" (ppr expr) #endif -\end{code} ------------------------------------------------------------------------------ -Construct an SRT. -Construct the SRT at this point from its sub-SRTs and any new global -references which aren't already contained in one of the sub-SRTs (and -which are "live"). +-- Case Alternatives -\begin{code} -constructSRT caf_refs sub_srt initial_offset current_offset - = let - extra_refs = filter (`notElem` sub_srt) (varSetElems caf_refs) - this_srt = extra_refs ++ sub_srt +srtCaseAlts :: IdEnv Int -> StgCaseAlts -> StgCaseAlts - -- Add the length of the new entries to the - -- current offset to get the next free offset in the global SRT. - new_offset = current_offset + length extra_refs - srt_length = new_offset - initial_offset +srtCaseAlts table (StgAlgAlts t alts dflt) + = (StgAlgAlts t $! map (srtAlgAlt table) alts) $! srtDefault table dflt - srt_info | srt_length == 0 = NoSRT - | otherwise = SRT initial_offset srt_length +srtCaseAlts table (StgPrimAlts t alts dflt) + = (StgPrimAlts t $! map (srtPrimAlt table) alts) $! srtDefault table dflt - in ASSERT( this_srt `lengthIs` srt_length ) - (srt_info, this_srt, new_offset) -\end{code} +srtAlgAlt table (con,args,used,rhs) + = (,,,) con args used $! srtExpr table rhs ------------------------------------------------------------------------------ -Case Alternatives +srtPrimAlt table (lit,rhs) + = (,) lit $! srtExpr table rhs -\begin{code} -srtCaseAlts :: SrtOffset -> StgCaseAlts -> (StgCaseAlts, SrtIds, SrtOffset) - -srtCaseAlts off (StgAlgAlts t alts dflt) - = srtDefault off dflt =: \ ((dflt_off, dflt_srt), dflt') -> - mapAccumL srtAlgAlt (dflt_off, dflt_srt) alts =: \ ((alts_off, alts_srt), alts') -> - (StgAlgAlts t alts' dflt', alts_srt, alts_off) - -srtCaseAlts off (StgPrimAlts t alts dflt) - = srtDefault off dflt =: \ ((dflt_off, dflt_srt), dflt') -> - mapAccumL srtPrimAlt (dflt_off, dflt_srt) alts =: \ ((alts_off, alts_srt), alts') -> - (StgPrimAlts t alts' dflt', alts_srt, alts_off) - -srtAlgAlt (off,srt) (con,args,used,rhs) - = srtExpr off rhs =: \(rhs', rhs_srt, rhs_off) -> - ((rhs_off, rhs_srt ++ srt), (con,args,used,rhs')) - -srtPrimAlt (off,srt) (lit,rhs) - = srtExpr off rhs =: \(rhs', rhs_srt, rhs_off) -> - ((rhs_off, rhs_srt ++ srt), (lit, rhs')) - -srtDefault off StgNoDefault - = ((off,[]), StgNoDefault) -srtDefault off (StgBindDefault rhs) - = srtExpr off rhs =: \(rhs', srt, off) -> - ((off,srt), StgBindDefault rhs') -\end{code} +srtDefault table StgNoDefault = StgNoDefault +srtDefault table (StgBindDefault rhs) + = StgBindDefault $! srtExpr table rhs ----------------------------------------------------------------------------- -Misc stuff +-- Construct an SRT bitmap. + +constructSRT :: IdEnv Int -> IdSet -> SRT +constructSRT table entries + | isEmptyVarSet entries = NoSRT + | otherwise = SRT offset len bitmap + where + ints = map (expectJust "constructSRT" . lookupVarEnv table) + (varSetElems entries) + sorted_ints = sortLt (<) ints + offset = head sorted_ints + bitmap_entries = map (subtract offset) sorted_ints + len = last bitmap_entries + 1 + bitmap = intsToBitmap len bitmap_entries + +-- --------------------------------------------------------------------------- +-- Misc stuff -\begin{code} a =: k = k a + \end{code} diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs index cc918b7a6f..dc945f52be 100644 --- a/ghc/compiler/simplStg/SimplStg.lhs +++ b/ghc/compiler/simplStg/SimplStg.lhs @@ -30,7 +30,7 @@ import Outputable stg2stg :: DynFlags -- includes spec of what stg-to-stg passes to do -> Module -- module name (profiling only) -> [StgBinding] -- input... - -> IO ( [(StgBinding,[Id])] -- output program... + -> IO ( [(StgBinding,[(Id,[Id])])] -- output program... , CollectedCCs) -- cost centre information (declared and used) stg2stg dflags module_name binds diff --git a/ghc/compiler/simplStg/StgStats.lhs b/ghc/compiler/simplStg/StgStats.lhs index 824c112a1c..0e5a75b320 100644 --- a/ghc/compiler/simplStg/StgStats.lhs +++ b/ghc/compiler/simplStg/StgStats.lhs @@ -117,10 +117,10 @@ statBinding :: Bool -- True <=> top-level; False <=> nested -> StgBinding -> StatEnv -statBinding top (StgNonRec _srt b rhs) +statBinding top (StgNonRec b rhs) = statRhs top (b, rhs) -statBinding top (StgRec _srt pairs) +statBinding top (StgRec pairs) = combineSEs (map (statRhs top) pairs) statRhs :: Bool -> (Id, StgRhs) -> StatEnv @@ -128,7 +128,7 @@ statRhs :: Bool -> (Id, StgRhs) -> StatEnv statRhs top (b, StgRhsCon cc con args) = countOne (ConstructorBinds top) -statRhs top (b, StgRhsClosure cc bi fv u args body) +statRhs top (b, StgRhsClosure cc bi fv u _srt args body) = statExpr body `combineSE` countN FreeVariables (length fv) `combineSE` countOne ( diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index ab4d0e0650..c23eb9dda2 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -174,14 +174,13 @@ coreTopBindToStg env body_fvs (NonRec id rhs) env' = extendVarEnv env id how_bound how_bound = LetBound TopLet (manifestArity rhs) - (stg_rhs, fvs', lv_info) = + (stg_rhs, fvs') = initLne env ( coreToTopStgRhs body_fvs (id,rhs) `thenLne` \ (stg_rhs, fvs') -> - freeVarsToLiveVars fvs' `thenLne` \ lv_info -> - returnLne (stg_rhs, fvs', lv_info) + returnLne (stg_rhs, fvs') ) - bind = StgNonRec (mkSRT lv_info) id stg_rhs + bind = StgNonRec id stg_rhs in ASSERT2(manifestArity rhs == stgRhsArity stg_rhs, ppr id) ASSERT2(consistentCafInfo id bind, ppr id) @@ -196,16 +195,15 @@ coreTopBindToStg env body_fvs (Rec pairs) | (b, rhs) <- pairs ] env' = extendVarEnvList env extra_env' - (stg_rhss, fvs', lv_info) + (stg_rhss, fvs') = initLne env' ( mapAndUnzipLne (coreToTopStgRhs body_fvs) pairs `thenLne` \ (stg_rhss, fvss') -> let fvs' = unionFVInfos fvss' in - freeVarsToLiveVars fvs' `thenLne` \ lv_info -> - returnLne (stg_rhss, fvs', lv_info) + returnLne (stg_rhss, fvs') ) - bind = StgRec (mkSRT lv_info) (zip binders stg_rhss) + bind = StgRec (zip binders stg_rhss) in ASSERT2(and [manifestArity rhs == stgRhsArity stg_rhs | (rhs,stg_rhs) <- rhss `zip` stg_rhss], ppr binders) ASSERT2(consistentCafInfo (head binders) bind, ppr binders) @@ -237,29 +235,33 @@ coreToTopStgRhs coreToTopStgRhs scope_fv_info (bndr, rhs) = coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, _) -> - returnLne (mkTopStgRhs upd rhs_fvs bndr_info new_rhs, rhs_fvs) + freeVarsToLiveVars rhs_fvs `thenLne` \ lv_info -> + returnLne (mkTopStgRhs upd rhs_fvs (mkSRT lv_info) bndr_info new_rhs, rhs_fvs) where bndr_info = lookupFVInfo scope_fv_info bndr upd | rhsIsNonUpd rhs = SingleEntry | otherwise = Updatable -mkTopStgRhs :: UpdateFlag -> FreeVarsInfo -> StgBinderInfo -> StgExpr -> StgRhs +mkTopStgRhs :: UpdateFlag -> FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr + -> StgRhs -mkTopStgRhs upd rhs_fvs binder_info (StgLam _ bndrs body) +mkTopStgRhs upd rhs_fvs srt binder_info (StgLam _ bndrs body) = StgRhsClosure noCCS binder_info (getFVs rhs_fvs) ReEntrant + srt bndrs body -mkTopStgRhs upd rhs_fvs binder_info (StgConApp con args) +mkTopStgRhs upd rhs_fvs srt binder_info (StgConApp con args) | not (isUpdatable upd) -- StgConApps can be updatable (see isCrossDllConApp) = StgRhsCon noCCS con args -mkTopStgRhs upd rhs_fvs binder_info rhs +mkTopStgRhs upd rhs_fvs srt binder_info rhs = StgRhsClosure noCCS binder_info (getFVs rhs_fvs) upd + srt [] rhs \end{code} @@ -647,14 +649,12 @@ coreToStgLet let_no_escape bind body vars_bind body_fvs (NonRec binder rhs) - = coreToStgRhs body_fvs (binder,rhs) - `thenLne` \ (rhs2, bind_fvs, escs) -> - - freeVarsToLiveVars bind_fvs `thenLne` \ bind_lv_info -> + = coreToStgRhs body_fvs [] (binder,rhs) + `thenLne` \ (rhs2, bind_fvs, bind_lv_info, escs) -> let env_ext_item = mk_binding bind_lv_info binder rhs in - returnLne (StgNonRec (mkSRT bind_lv_info) binder rhs2, + returnLne (StgNonRec binder rhs2, bind_fvs, escs, bind_lv_info, [env_ext_item]) @@ -667,16 +667,14 @@ coreToStgLet let_no_escape bind body | (b,rhs) <- pairs ] in extendVarEnvLne env_ext ( - mapAndUnzip3Lne (coreToStgRhs rec_scope_fvs) pairs - `thenLne` \ (rhss2, fvss, escss) -> + mapAndUnzip4Lne (coreToStgRhs rec_scope_fvs binders) pairs + `thenLne` \ (rhss2, fvss, lv_infos, escss) -> let bind_fvs = unionFVInfos fvss + bind_lv_info = foldr unionLiveInfo emptyLiveInfo lv_infos escs = unionVarSets escss in - freeVarsToLiveVars (binders `minusFVBinders` bind_fvs) - `thenLne` \ bind_lv_info -> - - returnLne (StgRec (mkSRT bind_lv_info) (binders `zip` rhss2), + returnLne (StgRec (binders `zip` rhss2), bind_fvs, escs, bind_lv_info, env_ext) ) ) @@ -689,32 +687,34 @@ is_join_var j = occNameUserString (getOccName j) == "$j" \begin{code} coreToStgRhs :: FreeVarsInfo -- Free var info for the scope of the binding + -> [Id] -> (Id,CoreExpr) - -> LneM (StgRhs, FreeVarsInfo, EscVarsSet) + -> LneM (StgRhs, FreeVarsInfo, LiveInfo, EscVarsSet) -coreToStgRhs scope_fv_info (bndr, rhs) +coreToStgRhs scope_fv_info binders (bndr, rhs) = coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, rhs_escs) -> getEnvLne `thenLne` \ env -> - returnLne (mkStgRhs env rhs_fvs bndr_info new_rhs, - rhs_fvs, rhs_escs) + freeVarsToLiveVars (binders `minusFVBinders` rhs_fvs) `thenLne` \ lv_info -> + returnLne (mkStgRhs rhs_fvs (mkSRT lv_info) bndr_info new_rhs, + rhs_fvs, lv_info, rhs_escs) where bndr_info = lookupFVInfo scope_fv_info bndr -mkStgRhs :: IdEnv HowBound -> FreeVarsInfo -> StgBinderInfo -> StgExpr -> StgRhs +mkStgRhs :: FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr -> StgRhs -mkStgRhs env rhs_fvs binder_info (StgConApp con args) +mkStgRhs rhs_fvs srt binder_info (StgConApp con args) = StgRhsCon noCCS con args -mkStgRhs env rhs_fvs binder_info (StgLam _ bndrs body) +mkStgRhs rhs_fvs srt binder_info (StgLam _ bndrs body) = StgRhsClosure noCCS binder_info (getFVs rhs_fvs) ReEntrant - bndrs body + srt bndrs body -mkStgRhs env rhs_fvs binder_info rhs +mkStgRhs rhs_fvs srt binder_info rhs = StgRhsClosure noCCS binder_info (getFVs rhs_fvs) - upd_flag [] rhs + upd_flag srt [] rhs where upd_flag = Updatable {- @@ -896,6 +896,14 @@ mapAndUnzip3Lne f (x:xs) mapAndUnzip3Lne f xs `thenLne` \ (rs1, rs2, rs3) -> returnLne (r1:rs1, r2:rs2, r3:rs3) +mapAndUnzip4Lne :: (a -> LneM (b,c,d,e)) -> [a] -> LneM ([b],[c],[d],[e]) + +mapAndUnzip4Lne f [] = returnLne ([],[],[],[]) +mapAndUnzip4Lne f (x:xs) + = f x `thenLne` \ (r1, r2, r3, r4) -> + mapAndUnzip4Lne f xs `thenLne` \ (rs1, rs2, rs3, rs4) -> + returnLne (r1:rs1, r2:rs2, r3:rs3, r4:rs4) + fixLne :: (a -> LneM a) -> LneM a fixLne expr env lvs_cont = result diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs index 22ef75012e..28b02a9a4c 100644 --- a/ghc/compiler/stgSyn/StgLint.lhs +++ b/ghc/compiler/stgSyn/StgLint.lhs @@ -89,11 +89,11 @@ lintStgVar v = checkInScope v `thenL_` \begin{code} lintStgBinds :: StgBinding -> LintM [Id] -- Returns the binders -lintStgBinds (StgNonRec _srt binder rhs) +lintStgBinds (StgNonRec binder rhs) = lint_binds_help (binder,rhs) `thenL_` returnL [binder] -lintStgBinds (StgRec _srt pairs) +lintStgBinds (StgRec pairs) = addInScopeVars binders ( mapL lint_binds_help pairs `thenL_` returnL binders @@ -127,10 +127,10 @@ lint_binds_help (binder, rhs) \begin{code} lintStgRhs :: StgRhs -> LintM (Maybe Type) -lintStgRhs (StgRhsClosure _ _ _ _ [] expr) +lintStgRhs (StgRhsClosure _ _ _ _ _ [] expr) = lintStgExpr expr -lintStgRhs (StgRhsClosure _ _ _ _ binders expr) +lintStgRhs (StgRhsClosure _ _ _ _ _ binders expr) = addLoc (LambdaBodyOf binders) ( addInScopeVars binders ( lintStgExpr expr `thenMaybeL` \ body_ty -> diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs index 293aa9499a..31e2057f56 100644 --- a/ghc/compiler/stgSyn/StgSyn.lhs +++ b/ghc/compiler/stgSyn/StgSyn.lhs @@ -34,7 +34,7 @@ module StgSyn ( SRT(..), noSRT, nonEmptySRT, -- utils - stgBindHasCafRefs, stgRhsArity, getArgPrimRep, + stgBindHasCafRefs, stgArgHasCafRefs, stgRhsArity, getArgPrimRep, isLitLitArg, isDllConApp, isStgTypeArg, stgArgType, stgBinders, @@ -50,7 +50,8 @@ module StgSyn ( import CostCentre ( CostCentreStack, CostCentre ) import VarSet ( IdSet, isEmptyVarSet ) import Var ( isId ) -import Id ( Id, idName, idPrimRep, idType ) +import Id ( Id, idName, idPrimRep, idType, idCafInfo ) +import IdInfo ( mayHaveCafRefs ) import Name ( isDllName ) import Literal ( Literal, literalType, isLitLitLit, literalPrimRep ) import ForeignCall ( ForeignCall ) @@ -62,6 +63,7 @@ import Type ( Type ) import TyCon ( TyCon ) import UniqSet ( isEmptyUniqSet, uniqSetToList, UniqSet ) import Unique ( Unique ) +import Bitmap import CmdLineOpts ( opt_SccProfilingOn ) \end{code} @@ -80,12 +82,12 @@ There is one SRT for each group of bindings. \begin{code} data GenStgBinding bndr occ - = StgNonRec SRT bndr (GenStgRhs bndr occ) - | StgRec SRT [(bndr, GenStgRhs bndr occ)] + = StgNonRec bndr (GenStgRhs bndr occ) + | StgRec [(bndr, GenStgRhs bndr occ)] stgBinders :: GenStgBinding bndr occ -> [bndr] -stgBinders (StgNonRec _ b _) = [b] -stgBinders (StgRec _ bs) = map fst bs +stgBinders (StgNonRec b _) = [b] +stgBinders (StgRec bs) = map fst bs \end{code} %************************************************************************ @@ -370,6 +372,7 @@ data GenStgRhs bndr occ [occ] -- non-global free vars; a list, rather than -- a set, because order is important !UpdateFlag -- ReEntrant | Updatable | SingleEntry + SRT -- The SRT reference [bndr] -- arguments; if empty, then not a function; -- as above, order is important. (GenStgExpr bndr occ) -- body @@ -400,7 +403,7 @@ The second flavour of right-hand-side is for constructors (simple but important) \begin{code} stgRhsArity :: StgRhs -> Int -stgRhsArity (StgRhsClosure _ _ _ _ bndrs _) = count isId bndrs +stgRhsArity (StgRhsClosure _ _ _ _ _ bndrs _) = count isId bndrs -- The arity never includes type parameters, so -- when keeping type arguments and binders in the Stg syntax -- (opt_RuntimeTypes) we have to fliter out the type binders. @@ -408,14 +411,17 @@ stgRhsArity (StgRhsCon _ _ _) = 0 \end{code} \begin{code} -stgBindHasCafRefs :: GenStgBinding bndr occ -> Bool -stgBindHasCafRefs (StgNonRec srt _ rhs) - = nonEmptySRT srt || rhsIsUpdatable rhs -stgBindHasCafRefs (StgRec srt binds) - = nonEmptySRT srt || any rhsIsUpdatable (map snd binds) - -rhsIsUpdatable (StgRhsClosure _ _ _ upd _ _) = isUpdatable upd -rhsIsUpdatable _ = False +stgBindHasCafRefs :: GenStgBinding bndr Id -> Bool +stgBindHasCafRefs (StgNonRec _ rhs) = rhsHasCafRefs rhs +stgBindHasCafRefs (StgRec binds) = any rhsHasCafRefs (map snd binds) + +rhsHasCafRefs (StgRhsClosure _ _ _ upd srt _ _) + = isUpdatable upd || nonEmptySRT srt +rhsHasCafRefs (StgRhsCon _ _ args) + = any stgArgHasCafRefs args + +stgArgHasCafRefs (StgVarArg id) = mayHaveCafRefs (idCafInfo id) +stgArgHasCafRefs _ = False \end{code} Here's the @StgBinderInfo@ type, and its combining op: @@ -578,8 +584,10 @@ converted into the length and offset form by the SRT pass. \begin{code} data SRT = NoSRT - | SRTEntries IdSet -- generated by CoreToStg - | SRT !Int{-offset-} !Int{-length-} -- generated by computeSRTs + | SRTEntries IdSet + -- generated by CoreToStg + | SRT !Int{-offset-} !Int{-length-} !Bitmap{-bitmap-} + -- generated by computeSRTs noSRT :: SRT noSRT = NoSRT @@ -590,7 +598,7 @@ nonEmptySRT _ = True pprSRT (NoSRT) = ptext SLIT("_no_srt_") pprSRT (SRTEntries ids) = text "SRT:" <> ppr ids -pprSRT (SRT off len) = parens (ppr off <> comma <> ppr len) +pprSRT (SRT off length bitmap) = parens (ppr off <> comma <> text "*bitmap*") \end{code} %************************************************************************ @@ -606,13 +614,12 @@ hoping he likes terminators instead... Ditto for case alternatives. pprGenStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee) => GenStgBinding bndr bdee -> SDoc -pprGenStgBinding (StgNonRec srt bndr rhs) - = pprMaybeSRT srt $$ hang (hsep [ppr bndr, equals]) - 4 ((<>) (ppr rhs) semi) +pprGenStgBinding (StgNonRec bndr rhs) + = hang (hsep [ppr bndr, equals]) + 4 ((<>) (ppr rhs) semi) -pprGenStgBinding (StgRec srt pairs) +pprGenStgBinding (StgRec pairs) = vcat ((ifPprDebug (ptext SLIT("{- StgRec (begin) -}"))) : - pprMaybeSRT srt : (map (ppr_bind) pairs) ++ [(ifPprDebug (ptext SLIT("{- StgRec (end) -}")))]) where ppr_bind (bndr, expr) @@ -627,13 +634,14 @@ pprStgBindings binds = vcat (map pprGenStgBinding binds) pprGenStgBindingWithSRT :: (Outputable bndr, Outputable bdee, Ord bdee) - => (GenStgBinding bndr bdee,[Id]) -> SDoc + => (GenStgBinding bndr bdee,[(Id,[Id])]) -> SDoc -pprGenStgBindingWithSRT (bind,srt) - = vcat [ pprGenStgBinding bind, - ptext SLIT("SRT: ") <> ppr srt ] +pprGenStgBindingWithSRT (bind,srts) + = vcat (pprGenStgBinding bind : map pprSRT srts) + where pprSRT (id,srt) = + ptext SLIT("SRT") <> parens (ppr id) <> ptext SLIT(": ") <> ppr srt -pprStgBindingsWithSRTs :: [(StgBinding,[Id])] -> SDoc +pprStgBindingsWithSRTs :: [(StgBinding,[(Id,[Id])])] -> SDoc pprStgBindingsWithSRTs binds = vcat (map pprGenStgBindingWithSRT binds) \end{code} @@ -797,18 +805,18 @@ pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee) => GenStgRhs bndr bdee -> SDoc -- special case -pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func [])) +pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag srt [{-no args-}] (StgApp func [])) = hcat [ ppr cc, pp_binder_info bi, brackets (ifPprDebug (ppr free_var)), - ptext SLIT(" \\"), ppr upd_flag, ptext SLIT(" [] "), ppr func ] + ptext SLIT(" \\"), ppr upd_flag, pprMaybeSRT srt, ptext SLIT(" [] "), ppr func ] -- general case -pprStgRhs (StgRhsClosure cc bi free_vars upd_flag args body) +pprStgRhs (StgRhsClosure cc bi free_vars upd_flag srt args body) = hang (hsep [if opt_SccProfilingOn then ppr cc else empty, pp_binder_info bi, ifPprDebug (brackets (interppSP free_vars)), - char '\\' <> ppr upd_flag, brackets (interppSP args)]) + char '\\' <> ppr upd_flag, pprMaybeSRT srt, brackets (interppSP args)]) 4 (ppr body) pprStgRhs (StgRhsCon cc con args) @@ -816,5 +824,5 @@ pprStgRhs (StgRhsCon cc con args) space, ppr con, ptext SLIT("! "), brackets (interppSP args)] pprMaybeSRT (NoSRT) = empty -pprMaybeSRT srt = ptext SLIT("srt: ") <> pprSRT srt +pprMaybeSRT srt = ptext SLIT("srt:") <> pprSRT srt \end{code} diff --git a/ghc/driver/mangler/ghc-asm.lprl b/ghc/driver/mangler/ghc-asm.lprl index b1a97b6177..43c22f0a39 100644 --- a/ghc/driver/mangler/ghc-asm.lprl +++ b/ghc/driver/mangler/ghc-asm.lprl @@ -598,6 +598,7 @@ sub mangle_asm { || /^${T_US}.*_slow${T_POST_LBL}$/o # slow entry || /^${T_US}__stginit.*${T_POST_LBL}$/o # __stginit<module> || /^${T_US}.*_btm${T_POST_LBL}$/o # large bitmaps + || /^${T_US}.*_srtd${T_POST_LBL}$/o # large bitmaps || /^${T_US}.*_fast${T_POST_LBL}$/o # primops || /^${T_US}.*_closure_tbl${T_POST_LBL}$/o # closure tables || /^_uname:/o; # x86/Solaris2 diff --git a/ghc/includes/ClosureMacros.h b/ghc/includes/ClosureMacros.h index 7b3a6d50ba..35140fce7d 100644 --- a/ghc/includes/ClosureMacros.h +++ b/ghc/includes/ClosureMacros.h @@ -1,5 +1,5 @@ /* ---------------------------------------------------------------------------- - * $Id: ClosureMacros.h,v 1.35 2002/12/11 15:36:37 simonmar Exp $ + * $Id: ClosureMacros.h,v 1.36 2003/05/14 09:14:01 simonmar Exp $ * * (c) The GHC Team, 1998-1999 * @@ -234,6 +234,6 @@ extern StgWord flip; -------------------------------------------------------------------------- */ /* constructors don't have SRTs */ -#define GET_TAG(info) (INFO_PTR_TO_STRUCT(info)->srt_len) +#define GET_TAG(info) (INFO_PTR_TO_STRUCT(info)->srt_bitmap) #endif /* CLOSUREMACROS_H */ diff --git a/ghc/includes/InfoMacros.h b/ghc/includes/InfoMacros.h index 0964da7690..5aa4835eaf 100644 --- a/ghc/includes/InfoMacros.h +++ b/ghc/includes/InfoMacros.h @@ -1,5 +1,5 @@ /* ---------------------------------------------------------------------------- - * $Id: InfoMacros.h,v 1.21 2002/12/11 15:36:37 simonmar Exp $ + * $Id: InfoMacros.h,v 1.22 2003/05/14 09:14:01 simonmar Exp $ * * (c) The GHC Team, 1998-2002 * @@ -10,8 +10,8 @@ #ifndef INFOMACROS_H #define INFOMACROS_H -#define STD_INFO(srt_len_, type_) \ - srt_len : srt_len_, \ +#define STD_INFO(srt_bitmap_, type_) \ + srt_bitmap : srt_bitmap_, \ type : type_ #define THUNK_INFO(srt_, srt_off_) \ @@ -65,7 +65,7 @@ INFO_TABLE_THUNK(info, /* info-table label */ \ entry, /* entry code label */ \ ptrs, nptrs, /* closure layout info */\ - srt_, srt_off_, srt_len_, /* SRT info */ \ + srt_, srt_off_, srt_bitmap_, /* SRT info */ \ type, /* closure type */ \ info_class, entry_class, /* C storage classes */ \ prof_descr, prof_type) /* profiling info */ \ @@ -75,7 +75,7 @@ INFO_TABLE_THUNK(info, /* info-table label */ \ info_class const StgInfoTable stg_RBH_##info = { \ layout : { payload : {ptrs,nptrs} }, \ PROF_INFO(prof_type, prof_descr) \ - SRT_INFO(RBH,srt_,srt_off_,srt_len_), \ + SRT_INFO(RBH,srt_,srt_off_,srt_bitmap_), \ INCLUDE_RBH_INFO(info), \ INIT_ENTRY(stg_RBH_##entry) \ } ; \ @@ -87,7 +87,7 @@ INFO_TABLE_THUNK(info, /* info-table label */ \ info_class const StgInfoTable info = { \ layout : { payload : {ptrs,nptrs} }, \ PROF_INFO(prof_type, prof_descr) \ - SRT_INFO(type,srt_,srt_off_,srt_len_), \ + SRT_INFO(type,srt_,srt_off_,srt_bitmap_), \ INCLUDE_RBH_INFO(stg_RBH_##info), \ INIT_ENTRY(entry) \ } @@ -98,7 +98,7 @@ INFO_TABLE_THUNK(info, /* info-table label */ \ INFO_TABLE_THUNK(info, /* info-table label */ \ entry, /* entry code label */ \ ptrs, nptrs, /* closure layout info */\ - srt_, srt_off_, srt_len_, /* SRT info */ \ + srt_, srt_off_, srt_bitmap_, /* SRT info */ \ type_, /* closure type */ \ info_class, entry_class, /* C storage classes */ \ prof_descr, prof_type) /* profiling info */ \ @@ -107,7 +107,7 @@ INFO_TABLE_THUNK(info, /* info-table label */ \ i : { \ layout : { payload : {ptrs,nptrs} }, \ PROF_INFO(prof_type, prof_descr) \ - STD_INFO(srt_len_, type_), \ + STD_INFO(srt_bitmap_, type_), \ INIT_ENTRY(entry) \ }, \ THUNK_INFO(srt_,srt_off_), \ @@ -120,7 +120,7 @@ INFO_TABLE_THUNK(info, /* info-table label */ \ #if defined(GRAN) || defined(PAR) #define \ -INFO_TABLE_RET(info, entry, bitmap_, srt_, srt_off_, srt_len_, \ +INFO_TABLE_RET(info, entry, bitmap_, srt_, srt_off_, srt_bitmap_, \ type, info_class, entry_class, \ prof_descr, prof_type) \ entry_class(stg_RBH_##entry); \ @@ -129,7 +129,7 @@ INFO_TABLE_RET(info, entry, bitmap_, srt_, srt_off_, srt_len_, \ info_class const StgInfoTable stg_RBH_##info = { \ layout : { bitmap : (StgWord)bitmap_ }, \ PROF_INFO(prof_type, prof_descr) \ - SRT_INFO(RBH,srt_,srt_off_,srt_len_), \ + SRT_INFO(RBH,srt_,srt_off_,srt_bitmap_), \ INCLUDE_RBH_INFO(info), \ INIT_ENTRY(stg_RBH_##entry) \ }; \ @@ -141,7 +141,7 @@ INFO_TABLE_RET(info, entry, bitmap_, srt_, srt_off_, srt_len_, \ info_class const StgInfoTable info = { \ layout : { bitmap : (StgWord)bitmap_ }, \ PROF_INFO(prof_type, prof_descr) \ - SRT_INFO(type,srt_,srt_off_,srt_len_), \ + SRT_INFO(type,srt_,srt_off_,srt_bitmap_), \ INCLUDE_RBH_INFO(stg_RBH_##info), \ INIT_ENTRY(entry) \ } @@ -149,7 +149,7 @@ INFO_TABLE_RET(info, entry, bitmap_, srt_, srt_off_, srt_len_, \ #else #define \ -INFO_TABLE_RET(info, entry, bitmap_, srt_, srt_off_, srt_len_, \ +INFO_TABLE_RET(info, entry, bitmap_, srt_, srt_off_, srt_bitmap_, \ type_, info_class, entry_class, \ prof_descr, prof_type) \ entry_class(entry); \ @@ -157,7 +157,7 @@ INFO_TABLE_RET(info, entry, bitmap_, srt_, srt_off_, srt_len_, \ i : { \ layout : { bitmap : (StgWord)bitmap_ }, \ PROF_INFO(prof_type, prof_descr) \ - STD_INFO(srt_len_,type_), \ + STD_INFO(srt_bitmap_,type_), \ INIT_ENTRY(entry) \ }, \ RET_INFO(srt_,srt_off_) \ @@ -267,7 +267,7 @@ INFO_TABLE_CONSTR(info, entry, ptrs, nptrs, tag_,type_,info_class, \ INIT_ENTRY(entry) \ } -#define constrTag(con) (get_itbl(con)->srt_len) +#define constrTag(con) (get_itbl(con)->srt_bitmap) /* function info table -----------------------------------------------------*/ @@ -275,7 +275,7 @@ INFO_TABLE_CONSTR(info, entry, ptrs, nptrs, tag_,type_,info_class, \ INFO_TABLE_FUN_GEN(info, /* info-table label */ \ entry, /* entry code label */ \ ptrs, nptrs, /* closure layout info */\ - srt_, srt_off_, srt_len_, /* SRT info */ \ + srt_, srt_off_, srt_bitmap_, /* SRT info */ \ fun_type_, arity_, bitmap_, slow_apply_, \ /* Function info */ \ type_, /* closure type */ \ @@ -286,7 +286,7 @@ INFO_TABLE_FUN_GEN(info, /* info-table label */ \ i : { \ layout : { payload : {ptrs,nptrs} }, \ PROF_INFO(prof_type, prof_descr) \ - STD_INFO(srt_len_,type_), \ + STD_INFO(srt_bitmap_,type_), \ INIT_ENTRY(entry) \ }, \ srt : (StgSRT *)((StgClosure **)srt_+srt_off_), \ @@ -342,7 +342,7 @@ typedef struct { StgRetInfoTable i; } vec_info_8; -#define VEC_INFO_2(info,bitmap_,srt_,srt_off_,srt_len_, \ +#define VEC_INFO_2(info,bitmap_,srt_,srt_off_,srt_bitmap_, \ type_, info_class, \ alt_1, alt_2) \ info_class const vec_info_2 info = { \ @@ -350,13 +350,13 @@ typedef struct { i : { \ i : { \ layout : { bitmap : (StgWord)bitmap_ }, \ - STD_INFO(srt_len_,type_) \ + STD_INFO(srt_bitmap_,type_) \ }, \ RET_INFO(srt_,srt_off_) \ } \ } -#define VEC_INFO_3(info,bitmap_,srt_,srt_off_,srt_len_, \ +#define VEC_INFO_3(info,bitmap_,srt_,srt_off_,srt_bitmap_, \ type_, info_class, \ alt_1, alt_2, alt_3 \ ) \ @@ -365,13 +365,13 @@ typedef struct { i : { \ i : { \ layout : { bitmap : (StgWord)bitmap_ }, \ - STD_INFO(srt_len_,type_) \ + STD_INFO(srt_bitmap_,type_) \ }, \ RET_INFO(srt_,srt_off_) \ } \ } -#define VEC_INFO_4(info,bitmap_,srt_,srt_off_,srt_len_, \ +#define VEC_INFO_4(info,bitmap_,srt_,srt_off_,srt_bitmap_, \ type_, info_class, \ alt_1, alt_2, alt_3, alt_4 \ ) \ @@ -380,13 +380,13 @@ typedef struct { i : { \ i : { \ layout : { bitmap : (StgWord)bitmap_ }, \ - STD_INFO(srt_len_,type_) \ + STD_INFO(srt_bitmap_,type_) \ }, \ RET_INFO(srt_,srt_off_) \ } \ } -#define VEC_INFO_5(info,bitmap_,srt_,srt_off_,srt_len_, \ +#define VEC_INFO_5(info,bitmap_,srt_,srt_off_,srt_bitmap_, \ type_, info_class, \ alt_1, alt_2, alt_3, alt_4, \ alt_5 \ @@ -397,13 +397,13 @@ typedef struct { i : { \ i : { \ layout : { bitmap : (StgWord)bitmap_ }, \ - STD_INFO(srt_len_,type_) \ + STD_INFO(srt_bitmap_,type_) \ }, \ RET_INFO(srt_,srt_off_) \ } \ } -#define VEC_INFO_6(info,bitmap_,srt_,srt_off_,srt_len_, \ +#define VEC_INFO_6(info,bitmap_,srt_,srt_off_,srt_bitmap_, \ type_, info_class, \ alt_1, alt_2, alt_3, alt_4, \ alt_5, alt_6 \ @@ -414,13 +414,13 @@ typedef struct { i : { \ i : { \ layout : { bitmap : (StgWord)bitmap_ }, \ - STD_INFO(srt_len_,type_) \ + STD_INFO(srt_bitmap_,type_) \ }, \ RET_INFO(srt_,srt_off_) \ } \ } -#define VEC_INFO_7(info,bitmap_,srt_,srt_off_,srt_len_, \ +#define VEC_INFO_7(info,bitmap_,srt_,srt_off_,srt_bitmap_, \ type_, info_class, \ alt_1, alt_2, alt_3, alt_4, \ alt_5, alt_6, alt_7 \ @@ -431,13 +431,13 @@ typedef struct { i : { \ i : { \ layout : { bitmap : (StgWord)bitmap_ }, \ - STD_INFO(srt_len_,type_) \ + STD_INFO(srt_bitmap_,type_) \ }, \ RET_INFO(srt_,srt_off_) \ } \ } -#define VEC_INFO_8(info,bitmap_,srt_,srt_off_,srt_len_, \ +#define VEC_INFO_8(info,bitmap_,srt_,srt_off_,srt_bitmap_, \ type_, info_class, \ alt_1, alt_2, alt_3, alt_4, \ alt_5, alt_6, alt_7, alt_8 \ @@ -448,7 +448,7 @@ typedef struct { i : { \ i : { \ layout : { bitmap : (StgWord)bitmap_ }, \ - STD_INFO(srt_len_,type_) \ + STD_INFO(srt_bitmap_,type_) \ }, \ RET_INFO(srt_,srt_off_) \ } \ @@ -498,20 +498,20 @@ typedef struct { StgFunPtr vec[8]; } vec_info_8; -#define VEC_INFO_2(info,bitmap_,srt_,srt_off_,srt_len_, \ +#define VEC_INFO_2(info,bitmap_,srt_,srt_off_,srt_bitmap_, \ type_, info_class, \ alt_1, alt_2) \ info_class const vec_info_2 info = { \ i : { \ i : { \ layout : { bitmap : (StgWord)bitmap_ }, \ - STD_INFO(srt_len_,type_) \ + STD_INFO(srt_bitmap_,type_) \ }, \ RET_INFO(srt_,srt_off_) \ } \ } -#define VEC_INFO_3(info,bitmap_,srt_,srt_off_,srt_len_, \ +#define VEC_INFO_3(info,bitmap_,srt_,srt_off_,srt_bitmap_, \ type_, info_class, \ alt_1, alt_2, alt_3 \ ) \ @@ -519,14 +519,14 @@ typedef struct { i : { \ i : { \ layout : { bitmap : (StgWord)bitmap_ }, \ - STD_INFO(srt_len_,type_) \ + STD_INFO(srt_bitmap_,type_) \ }, \ RET_INFO(srt_,srt_off_) \ }, \ vec : { alt_1, alt_2, alt_3 } \ } -#define VEC_INFO_4(info,bitmap_,srt_,srt_off_,srt_len_, \ +#define VEC_INFO_4(info,bitmap_,srt_,srt_off_,srt_bitmap_, \ type_, info_class, \ alt_1, alt_2, alt_3, alt_4 \ ) \ @@ -534,14 +534,14 @@ typedef struct { i : { \ i : { \ layout : { bitmap : (StgWord)bitmap_ }, \ - STD_INFO(srt_len_,type_) \ + STD_INFO(srt_bitmap_,type_) \ }, \ RET_INFO(srt_,srt_off_) \ }, \ vec : { alt_1, alt_2, alt_3, alt_4 } \ } -#define VEC_INFO_5(info,bitmap_,srt_,srt_off_,srt_len_, \ +#define VEC_INFO_5(info,bitmap_,srt_,srt_off_,srt_bitmap_, \ type_, info_class, \ alt_1, alt_2, alt_3, alt_4, \ alt_5 \ @@ -550,7 +550,7 @@ typedef struct { i : { \ i : { \ layout : { bitmap : (StgWord)bitmap_ }, \ - STD_INFO(srt_len_,type_) \ + STD_INFO(srt_bitmap_,type_) \ }, \ RET_INFO(srt_,srt_off_) \ }, \ @@ -558,7 +558,7 @@ typedef struct { alt_5 } \ } -#define VEC_INFO_6(info,bitmap_,srt_,srt_off_,srt_len_, \ +#define VEC_INFO_6(info,bitmap_,srt_,srt_off_,srt_bitmap_, \ type_, info_class, \ alt_1, alt_2, alt_3, alt_4, \ alt_5, alt_6 \ @@ -567,7 +567,7 @@ typedef struct { i : { \ i : { \ layout : { bitmap : (StgWord)bitmap_ }, \ - STD_INFO(srt_len_,type_) \ + STD_INFO(srt_bitmap_,type_) \ }, \ RET_INFO(srt_,srt_off_) \ }, \ @@ -575,7 +575,7 @@ typedef struct { alt_5, alt_6 } \ } -#define VEC_INFO_7(info,bitmap_,srt_,srt_off_,srt_len_, \ +#define VEC_INFO_7(info,bitmap_,srt_,srt_off_,srt_bitmap_, \ type_, info_class, \ alt_1, alt_2, alt_3, alt_4, \ alt_5, alt_6, alt_7 \ @@ -584,7 +584,7 @@ typedef struct { i : { \ i : { \ layout : { bitmap : (StgWord)bitmap_ }, \ - STD_INFO(srt_len_,type_) \ + STD_INFO(srt_bitmap_,type_) \ }, \ RET_INFO(srt_,srt_off_) \ }, \ @@ -592,7 +592,7 @@ typedef struct { alt_5, alt_6, alt_7 } \ } -#define VEC_INFO_8(info,bitmap_,srt_,srt_off_,srt_len_, \ +#define VEC_INFO_8(info,bitmap_,srt_,srt_off_,srt_bitmap_, \ type_, info_class, \ alt_1, alt_2, alt_3, alt_4, \ alt_5, alt_6, alt_7, alt_8 \ @@ -601,7 +601,7 @@ typedef struct { i : { \ i : { \ layout : { bitmap : (StgWord)bitmap_ }, \ - STD_INFO(srt_len_,type_) \ + STD_INFO(srt_bitmap_,type_) \ }, \ RET_INFO(srt_,srt_off_) \ }, \ @@ -620,7 +620,7 @@ typedef vec_info_8 StgPolyInfoTable; #ifndef TABLES_NEXT_TO_CODE #define VEC_POLY_INFO_TABLE(nm, bitmap_, \ - srt_, srt_off_, srt_len_, \ + srt_, srt_off_, srt_bitmap_, \ type_, info_class, entry_class \ ) \ info_class const vec_info_8 nm##_info = { \ @@ -628,7 +628,7 @@ typedef vec_info_8 StgPolyInfoTable; i : { \ layout : { \ bitmap : (StgWord)bitmap_ }, \ - STD_INFO(srt_len_, type_), \ + STD_INFO(srt_bitmap_, type_), \ INIT_ENTRY(nm##_ret) \ }, \ RET_INFO(srt_,srt_off_) \ @@ -647,7 +647,7 @@ typedef vec_info_8 StgPolyInfoTable; #else #define VEC_POLY_INFO_TABLE(nm, bitmap_, \ - srt_, srt_off_, srt_len_, \ + srt_, srt_off_, srt_bitmap_, \ type_, info_class, entry_class \ ) \ info_class const vec_info_8 nm##_info = { \ @@ -665,7 +665,7 @@ typedef vec_info_8 StgPolyInfoTable; i : { \ layout : { \ bitmap : (StgWord)bitmap_ }, \ - STD_INFO(srt_len_, type_), \ + STD_INFO(srt_bitmap_, type_), \ INIT_ENTRY(nm##_ret) \ }, \ RET_INFO(srt_,srt_off_) \ @@ -677,18 +677,6 @@ typedef vec_info_8 StgPolyInfoTable; #define SRT(lbl) \ static const StgSRT lbl = { -#define BITMAP(lbl,size,contents) \ - static const StgLargeBitmap lbl = { size, { contents } }; - -#if SIZEOF_VOID_P == 8 -#define BITMAP64(first, second) \ - (((StgWord32)(first)) | ((StgWord)(StgWord32)(second) << 32)) -#else -#define BITMAP64(first, second) first, second -#endif -#define BITMAP32(x) ((StgWord32)(x)) -#define COMMA , - /* DLL_SRT_ENTRY is used on the Win32 side when filling initialising an entry in an SRT table with a reference to a closure that's living in a DLL. See elsewhere for reasons as to why we need diff --git a/ghc/includes/InfoTables.h b/ghc/includes/InfoTables.h index 97c3bec70b..79b3de1492 100644 --- a/ghc/includes/InfoTables.h +++ b/ghc/includes/InfoTables.h @@ -1,5 +1,5 @@ /* ---------------------------------------------------------------------------- - * $Id: InfoTables.h,v 1.28 2002/12/11 15:36:37 simonmar Exp $ + * $Id: InfoTables.h,v 1.29 2003/05/14 09:14:02 simonmar Exp $ * * (c) The GHC Team, 1998-2002 * @@ -185,6 +185,29 @@ typedef struct { StgWord bitmap[FLEXIBLE_ARRAY]; } StgLargeBitmap; +/* ----------------------------------------------------------------------------- + SRTs (Static Reference Tables) + + These tables are used to keep track of the static objects referred + to by the code for a closure or stack frame, so that we can follow + static data references from code and thus accurately + garbage-collect CAFs. + -------------------------------------------------------------------------- */ + +// An SRT is just an array of closure pointers: +typedef StgClosure* StgSRT[]; + +// Each info table refers to some subset of the closure pointers in an +// SRT. It does this using a pair of an StgSRT pointer and a +// half-word bitmap. If the half-word bitmap isn't large enough, then +// we fall back to a large SRT, including an unbounded bitmap. If the +// half-word bitmap is set to all ones (0xffff), then the StgSRT +// pointer instead points to an StgLargeSRT: +typedef struct StgLargeSRT_ { + StgSRT *srt; + StgLargeBitmap l; +} StgLargeSRT; + /* ---------------------------------------------------------------------------- Info Tables ------------------------------------------------------------------------- */ @@ -211,11 +234,6 @@ typedef union { // -// An SRT. -// -typedef StgClosure* StgSRT[]; - -// // The "standard" part of an info table. Every info table has this bit. // typedef struct _StgInfoTable { @@ -240,7 +258,7 @@ typedef struct _StgInfoTable { StgClosureInfo layout; // closure layout info (one word) StgHalfWord type; // closure type - StgHalfWord srt_len; // number of entries in SRT (or constructor tag) + StgHalfWord srt_bitmap; // number of entries in SRT (or constructor tag) #ifdef TABLES_NEXT_TO_CODE StgCode code[FLEXIBLE_ARRAY]; @@ -258,7 +276,7 @@ typedef struct _StgInfoTable { and bitmap fields may be left out (they are at the end, so omitting them doesn't affect the layout). - - If srt_len (in the std info table part) is zero, then the srt + - If srt_bitmap (in the std info table part) is zero, then the srt field may be omitted. This only applies if the slow_apply and bitmap fields have also been omitted. -------------------------------------------------------------------------- */ @@ -286,7 +304,7 @@ typedef struct _StgFunInfoTable { -------------------------------------------------------------------------- */ // When info tables are laid out backwards, we can omit the SRT -// pointer iff srt_len is zero. +// pointer iff srt_bitmap is zero. typedef struct _StgRetInfoTable { #if !defined(TABLES_NEXT_TO_CODE) @@ -306,7 +324,7 @@ typedef struct _StgRetInfoTable { -------------------------------------------------------------------------- */ // When info tables are laid out backwards, we can omit the SRT -// pointer iff srt_len is zero. +// pointer iff srt_bitmap is zero. typedef struct _StgThunkInfoTable { #if !defined(TABLES_NEXT_TO_CODE) diff --git a/ghc/rts/Exception.hc b/ghc/rts/Exception.hc index fea85dd88e..a62f62e006 100644 --- a/ghc/rts/Exception.hc +++ b/ghc/rts/Exception.hc @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: Exception.hc,v 1.26 2002/12/11 15:36:42 simonmar Exp $ + * $Id: Exception.hc,v 1.27 2003/05/14 09:13:59 simonmar Exp $ * * (c) The GHC Team, 1998-2000 * @@ -280,7 +280,7 @@ CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_7_ret,RET_VEC(Sp[SP_OFF],7)); VEC_POLY_INFO_TABLE(stg_catch_frame, \ MK_SMALL_BITMAP(CATCH_FRAME_WORDS, CATCH_FRAME_BITMAP), \ - NULL/*srt*/, 0/*srt_off*/, 0/*srt_len*/, CATCH_FRAME,, EF_); + NULL/*srt*/, 0/*srt_off*/, 0/*srt_bitmap*/, CATCH_FRAME,, EF_); /* ----------------------------------------------------------------------------- * The catch infotable diff --git a/ghc/rts/GC.c b/ghc/rts/GC.c index 1c1193807f..3ab057a1d1 100644 --- a/ghc/rts/GC.c +++ b/ghc/rts/GC.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: GC.c,v 1.154 2003/04/22 16:25:09 simonmar Exp $ + * $Id: GC.c,v 1.155 2003/05/14 09:13:59 simonmar Exp $ * * (c) The GHC Team 1998-2003 * @@ -1637,6 +1637,23 @@ mkMutCons(StgClosure *ptr, generation *gen) if M < evac_gen set failed_to_evac flag to indicate that we didn't manage to evacuate this object into evac_gen. + + OPTIMISATION NOTES: + + evacuate() is the single most important function performance-wise + in the GC. Various things have been tried to speed it up, but as + far as I can tell the code generated by gcc 3.2 with -O2 is about + as good as it's going to get. We pass the argument to evacuate() + in a register using the 'regparm' attribute (see the prototype for + evacuate() near the top of this file). + + Changing evacuate() to take an (StgClosure **) rather than + returning the new pointer seems attractive, because we can avoid + writing back the pointer when it hasn't changed (eg. for a static + object, or an object in a generation > N). However, I tried it and + it doesn't help. One reason is that the (StgClosure **) pointer + gets spilled to the stack inside evacuate(), resulting in far more + extra reads/writes than we save. -------------------------------------------------------------------------- */ static StgClosure * @@ -1810,7 +1827,7 @@ loop: goto loop; case THUNK_STATIC: - if (info->srt_len > 0 && major_gc && + if (info->srt_bitmap != 0 && major_gc && THUNK_STATIC_LINK((StgClosure *)q) == NULL) { THUNK_STATIC_LINK((StgClosure *)q) = static_objects; static_objects = (StgClosure *)q; @@ -1818,7 +1835,7 @@ loop: return q; case FUN_STATIC: - if (info->srt_len > 0 && major_gc && + if (info->srt_bitmap != 0 && major_gc && FUN_STATIC_LINK((StgClosure *)q) == NULL) { FUN_STATIC_LINK((StgClosure *)q) = static_objects; static_objects = (StgClosure *)q; @@ -2153,36 +2170,75 @@ move_TSO (StgTSO *src, StgTSO *dest) dest->sp = (StgPtr)dest->sp + diff; } -/* evacuate the SRT. If srt_len is zero, then there isn't an +/* Similar to scavenge_large_bitmap(), but we don't write back the + * pointers we get back from evacuate(). + */ +static void +scavenge_large_srt_bitmap( StgLargeSRT *large_srt ) +{ + nat i, b, size; + StgWord bitmap; + StgClosure **p; + + b = 0; + bitmap = large_srt->l.bitmap[b]; + size = (nat)large_srt->l.size; + p = large_srt->srt; + for (i = 0; i < size; ) { + if ((bitmap & 1) != 0) { + evacuate(*p); + } + i++; + p++; + if (i % BITS_IN(W_) == 0) { + b++; + bitmap = large_srt->l.bitmap[b]; + } else { + bitmap = bitmap >> 1; + } + } +} + +/* evacuate the SRT. If srt_bitmap is zero, then there isn't an * srt field in the info table. That's ok, because we'll * never dereference it. */ static inline void -scavenge_srt (StgClosure **srt, nat srt_len) +scavenge_srt (StgClosure **srt, nat srt_bitmap) { - StgClosure **srt_end; + nat bitmap; + StgClosure **p; - srt_end = srt + srt_len; + bitmap = srt_bitmap; + p = srt; - for (; srt < srt_end; srt++) { - /* Special-case to handle references to closures hiding out in DLLs, since - double indirections required to get at those. The code generator knows - which is which when generating the SRT, so it stores the (indirect) - reference to the DLL closure in the table by first adding one to it. - We check for this here, and undo the addition before evacuating it. + if (bitmap == (StgHalfWord)(-1)) { + scavenge_large_srt_bitmap( (StgLargeSRT *)srt ); + return; + } - If the SRT entry hasn't got bit 0 set, the SRT entry points to a - closure that's fixed at link-time, and no extra magic is required. - */ + while (bitmap != 0) { + if ((bitmap & 1) != 0) { #ifdef ENABLE_WIN32_DLL_SUPPORT - if ( (unsigned long)(*srt) & 0x1 ) { - evacuate(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1))); - } else { - evacuate(*srt); - } + // Special-case to handle references to closures hiding out in DLLs, since + // double indirections required to get at those. The code generator knows + // which is which when generating the SRT, so it stores the (indirect) + // reference to the DLL closure in the table by first adding one to it. + // We check for this here, and undo the addition before evacuating it. + // + // If the SRT entry hasn't got bit 0 set, the SRT entry points to a + // closure that's fixed at link-time, and no extra magic is required. + if ( (unsigned long)(*srt) & 0x1 ) { + evacuate(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1))); + } else { + evacuate(*p); + } #else - evacuate(*srt); + evacuate(*p); #endif + } + p++; + bitmap = bitmap >> 1; } } @@ -2193,7 +2249,7 @@ scavenge_thunk_srt(const StgInfoTable *info) StgThunkInfoTable *thunk_info; thunk_info = itbl_to_thunk_itbl(info); - scavenge_srt((StgClosure **)thunk_info->srt, thunk_info->i.srt_len); + scavenge_srt((StgClosure **)thunk_info->srt, thunk_info->i.srt_bitmap); } static inline void @@ -2202,7 +2258,7 @@ scavenge_fun_srt(const StgInfoTable *info) StgFunInfoTable *fun_info; fun_info = itbl_to_fun_itbl(info); - scavenge_srt((StgClosure **)fun_info->srt, fun_info->i.srt_len); + scavenge_srt((StgClosure **)fun_info->srt, fun_info->i.srt_bitmap); } static inline void @@ -2211,7 +2267,7 @@ scavenge_ret_srt(const StgInfoTable *info) StgRetInfoTable *ret_info; ret_info = itbl_to_ret_itbl(info); - scavenge_srt((StgClosure **)ret_info->srt, ret_info->i.srt_len); + scavenge_srt((StgClosure **)ret_info->srt, ret_info->i.srt_bitmap); } /* ----------------------------------------------------------------------------- @@ -2371,7 +2427,7 @@ scavenge(step *stp) q = p; switch (info->type) { - + case MVAR: /* treat MVars specially, because we don't want to evacuate the * mut_link field in the middle of the closure. @@ -3646,7 +3702,7 @@ scavenge_stack(StgPtr p, StgPtr stack_end) p = scavenge_small_bitmap(p, size, bitmap); follow_srt: - scavenge_srt((StgClosure **)info->srt, info->i.srt_len); + scavenge_srt((StgClosure **)info->srt, info->i.srt_bitmap); continue; case RET_BCO: { diff --git a/ghc/rts/HeapStackCheck.hc b/ghc/rts/HeapStackCheck.hc index a3aa5bfbd7..2254b5cd33 100644 --- a/ghc/rts/HeapStackCheck.hc +++ b/ghc/rts/HeapStackCheck.hc @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: HeapStackCheck.hc,v 1.30 2003/04/22 16:25:10 simonmar Exp $ + * $Id: HeapStackCheck.hc,v 1.31 2003/05/14 09:13:59 simonmar Exp $ * * (c) The GHC Team, 1998-2002 * @@ -112,7 +112,7 @@ INFO_TABLE_RET( stg_enter_info, stg_enter_ret, MK_SMALL_BITMAP(1/*framesize*/, 0/*bitmap*/), - 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/, + 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/, RET_SMALL,, EF_, 0, 0); EXTFUN(stg_enter_ret) { @@ -496,7 +496,7 @@ EXTFUN(stg_gc_noregs) INFO_TABLE_RET( stg_gc_void_info, stg_gc_void_ret, MK_SMALL_BITMAP(0/*framesize*/, 0/*bitmap*/), - 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/, + 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/, RET_SMALL,, EF_, 0, 0); EXTFUN(stg_gc_void_ret) @@ -511,7 +511,7 @@ EXTFUN(stg_gc_void_ret) INFO_TABLE_RET( stg_gc_unpt_r1_info, stg_gc_unpt_r1_ret, MK_SMALL_BITMAP(1/*framesize*/, 0/*bitmap*/), - 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/, + 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/, RET_SMALL,, EF_, 0, 0); EXTFUN(stg_gc_unpt_r1_ret) @@ -537,7 +537,7 @@ EXTFUN(stg_gc_unpt_r1) INFO_TABLE_RET( stg_gc_unbx_r1_info, stg_gc_unbx_r1_ret, MK_SMALL_BITMAP(1/*framesize*/, 1/*bitmap*/), - 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/, + 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/, RET_SMALL,, EF_, 0, 0); /* the 1 is a bitmap - i.e. 1 non-pointer word on the stack. */ @@ -565,7 +565,7 @@ EXTFUN(stg_gc_unbx_r1) INFO_TABLE_RET( stg_gc_f1_info, stg_gc_f1_ret, MK_SMALL_BITMAP(1/*framesize*/, 1/*bitmap*/), - 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/, + 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/, RET_SMALL,, EF_, 0, 0); EXTFUN(stg_gc_f1_ret) @@ -601,7 +601,7 @@ EXTFUN(stg_gc_f1) INFO_TABLE_RET( stg_gc_d1_info, stg_gc_d1_ret, MK_SMALL_BITMAP(DBL_WORDS/*framesize*/, DBL_BITMAP/*bitmap*/), - 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/, + 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/, RET_SMALL,, EF_, 0, 0); EXTFUN(stg_gc_d1_ret) @@ -638,7 +638,7 @@ EXTFUN(stg_gc_d1) INFO_TABLE_RET( stg_gc_l1_info, stg_gc_l1_ret, MK_SMALL_BITMAP(LLI_WORDS/*framesize*/, LLI_BITMAP/*bitmap*/), - 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/, + 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/, RET_SMALL,, EF_, 0, 0); EXTFUN(stg_gc_l1_ret) @@ -664,7 +664,7 @@ EXTFUN(stg_gc_l1) INFO_TABLE_RET( stg_ut_1_0_unreg_info, stg_ut_1_0_unreg_ret, MK_SMALL_BITMAP(1/*size*/, 0/*BITMAP*/), - 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/, + 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/, RET_SMALL,, EF_, 0, 0); EXTFUN(stg_ut_1_0_unreg_ret) @@ -758,7 +758,7 @@ EXTFUN(__stg_gc_fun) INFO_TABLE_RET( stg_gc_fun_info,stg_gc_fun_ret, MK_SMALL_BITMAP(0/*framesize*/, 0/*bitmap*/), - 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/, + 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/, RET_FUN,, EF_, 0, 0); EXTFUN(stg_gc_fun_ret) @@ -852,7 +852,7 @@ EXTFUN(stg_gc_fun_ret) INFO_TABLE_RET( stg_gc_gen_info, stg_gc_gen_ret, 0/*bitmap*/, - 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/, + 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/, RET_DYN,, EF_, 0, 0); /* bitmap in the above info table is unused, the real one is on the stack. @@ -980,7 +980,7 @@ FN_(stg_block_1) INFO_TABLE_RET( stg_block_takemvar_info, stg_block_takemvar_ret, MK_SMALL_BITMAP(1/*framesize*/, 0/*bitmap*/), - 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/, + 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/, RET_SMALL,, IF_, 0, 0); IF_(stg_block_takemvar_ret) @@ -1004,7 +1004,7 @@ FN_(stg_block_takemvar) INFO_TABLE_RET( stg_block_putmvar_info, stg_block_putmvar_ret, MK_SMALL_BITMAP(2/*framesize*/, 0/*bitmap*/), - 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/, + 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/, RET_SMALL,, IF_, 0, 0); IF_(stg_block_putmvar_ret) @@ -1031,7 +1031,7 @@ FN_(stg_block_putmvar) #ifdef mingw32_TARGET_OS INFO_TABLE_RET( stg_block_async_info, stg_block_async_ret, MK_SMALL_BITMAP(0/*framesize*/, 0/*bitmap*/), - 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/, + 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/, RET_SMALL,, IF_, 0, 0); IF_(stg_block_async_ret) diff --git a/ghc/rts/Printer.c b/ghc/rts/Printer.c index 38ade81051..b73b79ec86 100644 --- a/ghc/rts/Printer.c +++ b/ghc/rts/Printer.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: Printer.c,v 1.59 2003/04/22 16:25:12 simonmar Exp $ + * $Id: Printer.c,v 1.60 2003/05/14 09:13:59 simonmar Exp $ * * (c) The GHC Team, 1994-2000. * @@ -134,7 +134,7 @@ printClosure( StgClosure *obj ) #else fprintf(stderr,"CONSTR("); printPtr((StgPtr)obj->header.info); - fprintf(stderr,"(tag=%d)",info->srt_len); + fprintf(stderr,"(tag=%d)",info->srt_bitmap); #endif for (i = 0; i < info->layout.payload.ptrs; ++i) { fprintf(stderr,", "); diff --git a/ghc/rts/StgMiscClosures.hc b/ghc/rts/StgMiscClosures.hc index 5f4c6ce154..8bf5dbbfa6 100644 --- a/ghc/rts/StgMiscClosures.hc +++ b/ghc/rts/StgMiscClosures.hc @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: StgMiscClosures.hc,v 1.84 2003/03/27 13:54:32 simonmar Exp $ + * $Id: StgMiscClosures.hc,v 1.85 2003/05/14 09:14:00 simonmar Exp $ * * (c) The GHC Team, 1998-2002 * @@ -127,13 +127,13 @@ STG_CtoI_RET_R1p_Template(stg_ctoi_ret_R1p_6_ret); STG_CtoI_RET_R1p_Template(stg_ctoi_ret_R1p_7_ret); VEC_POLY_INFO_TABLE( stg_ctoi_ret_R1p, 0/* special layout */, - 0/*srt*/, 0/*srt_off*/, 0/*srt_len*/, + 0/*srt*/, 0/*srt_off*/, 0/*srt_bitmap*/, RET_BCO,, EF_); // When the returned value is a pointer, but unlifted, in R1 ... INFO_TABLE_RET( stg_ctoi_ret_R1unpt_info, stg_ctoi_ret_R1unpt_entry, 0/* special layout */, - 0/*srt*/, 0/*srt_off*/, 0/*srt_len*/, RET_BCO,, IF_, 0, 0); + 0/*srt*/, 0/*srt_off*/, 0/*srt_bitmap*/, RET_BCO,, IF_, 0, 0); IF_(stg_ctoi_ret_R1unpt_entry) { FB_ @@ -147,7 +147,7 @@ IF_(stg_ctoi_ret_R1unpt_entry) // When the returned value is a non-pointer in R1 ... INFO_TABLE_RET( stg_ctoi_ret_R1n_info, stg_ctoi_ret_R1n_entry, 0/* special layout */, - 0/*srt*/, 0/*srt_off*/, 0/*srt_len*/, RET_BCO,, IF_, 0, 0); + 0/*srt*/, 0/*srt_off*/, 0/*srt_bitmap*/, RET_BCO,, IF_, 0, 0); IF_(stg_ctoi_ret_R1n_entry) { FB_ @@ -162,7 +162,7 @@ IF_(stg_ctoi_ret_R1n_entry) // When the returned value is in F1 ... INFO_TABLE_RET( stg_ctoi_ret_F1_info, stg_ctoi_ret_F1_entry, 0/* special layout */, - 0/*srt*/, 0/*srt_off*/, 0/*srt_len*/, RET_BCO,, IF_, 0, 0); + 0/*srt*/, 0/*srt_off*/, 0/*srt_bitmap*/, RET_BCO,, IF_, 0, 0); IF_(stg_ctoi_ret_F1_entry) { FB_ @@ -176,7 +176,7 @@ IF_(stg_ctoi_ret_F1_entry) // When the returned value is in D1 ... INFO_TABLE_RET( stg_ctoi_ret_D1_info, stg_ctoi_ret_D1_entry, 0/* special layout */, - 0/*srt*/, 0/*srt_off*/, 0/*srt_len*/, RET_BCO,, IF_, 0, 0); + 0/*srt*/, 0/*srt_off*/, 0/*srt_bitmap*/, RET_BCO,, IF_, 0, 0); IF_(stg_ctoi_ret_D1_entry) { FB_ @@ -190,7 +190,7 @@ IF_(stg_ctoi_ret_D1_entry) // When the returned value is in L1 ... INFO_TABLE_RET( stg_ctoi_ret_L1_info, stg_ctoi_ret_L1_entry, 0/* special layout */, - 0/*srt*/, 0/*srt_off*/, 0/*srt_len*/, RET_BCO,, IF_, 0, 0); + 0/*srt*/, 0/*srt_off*/, 0/*srt_bitmap*/, RET_BCO,, IF_, 0, 0); IF_(stg_ctoi_ret_L1_entry) { FB_ @@ -204,7 +204,7 @@ IF_(stg_ctoi_ret_L1_entry) // When the returned value a VoidRep ... INFO_TABLE_RET( stg_ctoi_ret_V_info, stg_ctoi_ret_V_entry, 0/* special layout */, - 0/*srt*/, 0/*srt_off*/, 0/*srt_len*/, RET_BCO,, IF_, 0, 0); + 0/*srt*/, 0/*srt_off*/, 0/*srt_bitmap*/, RET_BCO,, IF_, 0, 0); IF_(stg_ctoi_ret_V_entry) { FB_ @@ -218,7 +218,7 @@ IF_(stg_ctoi_ret_V_entry) // should apply the BCO on the stack to its arguments, also on the stack. INFO_TABLE_RET( stg_apply_interp_info, stg_apply_interp_entry, 0/* special layout */, - 0/*srt*/, 0/*srt_off*/, 0/*srt_len*/, RET_BCO,, IF_, 0, 0); + 0/*srt*/, 0/*srt_off*/, 0/*srt_bitmap*/, RET_BCO,, IF_, 0, 0); IF_(stg_apply_interp_entry) { FB_ diff --git a/ghc/rts/StgStartup.hc b/ghc/rts/StgStartup.hc index c9afaa857e..d3e4c2f0ed 100644 --- a/ghc/rts/StgStartup.hc +++ b/ghc/rts/StgStartup.hc @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: StgStartup.hc,v 1.20 2002/12/11 15:36:54 simonmar Exp $ + * $Id: StgStartup.hc,v 1.21 2003/05/14 09:14:00 simonmar Exp $ * * (c) The GHC Team, 1998-2002 * @@ -135,7 +135,7 @@ STGFUN(stg_returnToStackTop) INFO_TABLE_RET( stg_forceIO_info,stg_forceIO_ret, MK_SMALL_BITMAP(0/*size*/, 0/*BITMAP*/), - 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/, + 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/, RET_SMALL,, EF_, 0, 0); #ifdef REG_R1 @@ -168,7 +168,7 @@ STGFUN(stg_forceIO_ret) INFO_TABLE_RET( stg_noforceIO_info,stg_noforceIO_ret, MK_SMALL_BITMAP(0/*size*/, 0/*BITMAP*/), - 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/, + 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/, RET_SMALL,, EF_, 0, 0); #ifdef REG_R1 diff --git a/ghc/rts/Updates.hc b/ghc/rts/Updates.hc index ac5b9481d4..b47b7c6066 100644 --- a/ghc/rts/Updates.hc +++ b/ghc/rts/Updates.hc @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: Updates.hc,v 1.39 2003/03/27 13:54:32 simonmar Exp $ + * $Id: Updates.hc,v 1.40 2003/05/14 09:14:00 simonmar Exp $ * * (c) The GHC Team, 1998-2002 * @@ -95,7 +95,7 @@ UPD_FRAME_ENTRY_TEMPLATE(stg_upd_frame_7_ret,&stg_IND_7_info,RET_VEC(Sp[0],7)); VEC_POLY_INFO_TABLE( stg_upd_frame, MK_SMALL_BITMAP(UPD_FRAME_WORDS, UPD_FRAME_BITMAP), - 0/*srt*/, 0/*srt_off*/, 0/*srt_len*/, + 0/*srt*/, 0/*srt_off*/, 0/*srt_bitmap*/, UPDATE_FRAME,, EF_); /*----------------------------------------------------------------------------- @@ -128,7 +128,7 @@ IF_(stg_seq_frame_ret); VEC_POLY_INFO_TABLE( stg_seq_frame, MK_SMALL_BITMAP(0, 0), - 0/*srt*/, 0/*srt_off*/, 0/*srt_len*/, + 0/*srt*/, 0/*srt_off*/, 0/*srt_bitmap*/, RET_SMALL,, EF_); IF_(stg_seq_frame_ret) |