From b3f530814c15886a7a010ed871bb1f054a3918b3 Mon Sep 17 00:00:00 2001 From: simonmar Date: Mon, 24 Mar 2003 14:46:57 +0000 Subject: [PATCH] [project @ 2003-03-24 14:46:53 by simonmar] Fix some bugs in compacting GC. Bug 1: When threading the fields of an AP or PAP, we were grabbing the info table of the function without unthreading it first. Bug 2: eval_thunk_selector() might accidentally find itself in to-space when going through indirections in a compacted generation. We must check for this case and bale out if necessary. Bug 3: This is somewhat more nasty. When we have an AP or PAP that points to a BCO, the layout info for the AP/PAP is in the BCO's instruction array, which is two objects deep from the AP/PAP itself. The trouble is, during compacting GC, we can only safely look one object deep from the current object, because pointers from objects any deeper might have been already updated to point to their final destinations. The solution is to put the arity and bitmap info for a BCO into the BCO object itself. This means BCOs become variable-length, which is a slight annoyance, but it also means that looking up the arity/bitmap is quicker. There is a slight reduction in complexity in the byte code generator due to not having to stuff the bitmap at the front of the instruction stream. --- ghc/compiler/ghci/ByteCodeAsm.lhs | 38 +++++++++++---------------- ghc/compiler/ghci/ByteCodeLink.lhs | 16 +++++++----- ghc/compiler/prelude/primops.txt.pp | 4 +-- ghc/includes/Closures.h | 36 +++++++++++++------------ ghc/mk/version.mk | 2 +- ghc/rts/GC.c | 32 ++++++++++++++++++++--- ghc/rts/GCCompact.c | 49 ++++++++++++++++++++++++----------- ghc/rts/Interpreter.c | 6 ++--- ghc/rts/PrimOps.hc | 28 +++++++++++++++----- ghc/rts/ProfHeap.c | 6 ++++- ghc/rts/Sanity.c | 12 +++++++-- ghc/rts/Storage.h | 5 +++- ghc/utils/genapply/GenApply.hs | 2 +- 13 files changed, 154 insertions(+), 82 deletions(-) diff --git a/ghc/compiler/ghci/ByteCodeAsm.lhs b/ghc/compiler/ghci/ByteCodeAsm.lhs index 5772b40..890b424 100644 --- a/ghc/compiler/ghci/ByteCodeAsm.lhs +++ b/ghc/compiler/ghci/ByteCodeAsm.lhs @@ -37,6 +37,7 @@ import Control.Monad.ST ( ST, runST ) import GHC.Word ( Word(..) ) import Data.Array.MArray +import Data.Array.Unboxed ( listArray ) import Data.Array.Base ( STUArray, UArray(..), unsafeWrite ) import Data.Array.ST ( castSTUArray ) import Foreign ( Word16, free ) @@ -65,6 +66,7 @@ data UnlinkedBCO unlinkedBCOName :: Name, unlinkedBCOArity :: Int, unlinkedBCOInstrs :: ByteArray#, -- insns + unlinkedBCOBitmap :: ByteArray#, -- bitmap unlinkedBCOLits :: (SizedSeq (Either Word FastString)), -- literals -- Either literal words or a pointer to a asciiz -- string, denoting a label whose *address* should @@ -84,7 +86,7 @@ bcoFreeNames :: UnlinkedBCO -> NameSet bcoFreeNames bco = bco_refs bco `minusNameSet` mkNameSet [unlinkedBCOName bco] where - bco_refs (UnlinkedBCO _ _ _ _ ptrs itbls) + bco_refs (UnlinkedBCO _ _ _ _ _ ptrs itbls) = unionManyNameSets ( mkNameSet [ n | BCOPtrName n <- ssElts ptrs ] : mkNameSet (ssElts itbls) : @@ -92,7 +94,7 @@ bcoFreeNames bco ) instance Outputable UnlinkedBCO where - ppr (UnlinkedBCO nm arity insns lits ptrs itbls) + ppr (UnlinkedBCO nm arity insns bitmap lits ptrs itbls) = sep [text "BCO", ppr nm, text "with", int (sizeSS lits), text "lits", int (sizeSS ptrs), text "ptrs", @@ -148,11 +150,13 @@ assembleBCO (ProtoBCO nm instrs bitmap bsize arity origin malloced) insns_arr | n_insns > 65535 = panic "linkBCO: >= 64k insns in BCO" - | otherwise = runST (mkInstrArray arity bitmap - bsize n_insns asm_insns) + | otherwise = mkInstrArray n_insns asm_insns insns_barr = case insns_arr of UArray _lo _hi barr -> barr - let ul_bco = UnlinkedBCO nm arity insns_barr final_lits + bitmap_arr = mkBitmapArray bsize bitmap + bitmap_barr = case bitmap_arr of UArray _lo _hi barr -> barr + + let ul_bco = UnlinkedBCO nm arity insns_barr bitmap_barr final_lits final_ptrs final_itbls -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive @@ -165,25 +169,13 @@ assembleBCO (ProtoBCO nm instrs bitmap bsize arity origin malloced) zonk ptr = do -- putStrLn ("freeing malloc'd block at " ++ show (A# a#)) free ptr +mkBitmapArray :: Int -> [StgWord] -> UArray Int StgWord +mkBitmapArray bsize bitmap + = listArray (0, 1 + length bitmap) (fromIntegral bsize : bitmap) -mkInstrArray :: Int -> [StgWord] -> Int -> Int -> [Word16] - -> ST s (UArray Int Word16) -mkInstrArray arity bitmap bsize n_insns asm_insns = do - (arr :: STUArray s Int Word16) <- newArray_ (0, n_insns + bco_info_w16s) - zipWithM (unsafeWrite arr) [bco_info_w16s ..] - (fromIntegral n_insns : asm_insns) - (arr' :: STUArray s Int StgWord) <- castSTUArray arr - writeArray arr' 0 (fromIntegral arity) - writeArray arr' 1 (fromIntegral bsize) - zipWithM (writeArray arr') [2..] bitmap - arr <- castSTUArray arr' - unsafeFreeze arr - where - -- The BCO info (arity, bitmap) goes at the beginning of - -- the instruction stream. See Closures.h for details. - bco_info_w16s = (1 {- for the arity -} + - 1 {- for the bitmap size -} + - length bitmap) * (wORD_SIZE `quot` 2) +mkInstrArray :: Int -> [Word16] -> UArray Int Word16 +mkInstrArray n_insns asm_insns + = listArray (0, 1 + n_insns) (fromIntegral n_insns : asm_insns) -- instrs nonptrs ptrs itbls type AsmState = (SizedSeq Word16, diff --git a/ghc/compiler/ghci/ByteCodeLink.lhs b/ghc/compiler/ghci/ByteCodeLink.lhs index 4d4030e..ee64b8a 100644 --- a/ghc/compiler/ghci/ByteCodeLink.lhs +++ b/ghc/compiler/ghci/ByteCodeLink.lhs @@ -39,7 +39,7 @@ import Control.Exception ( throwDyn ) import Control.Monad ( zipWithM ) import Control.Monad.ST ( stToIO ) -import GHC.Exts ( BCO#, newBCO#, unsafeCoerce#, +import GHC.Exts ( BCO#, newBCO#, unsafeCoerce#, Int#, ByteArray#, Array#, addrToHValue#, mkApUpd0# ) import GHC.Arr ( Array(..) ) @@ -103,7 +103,7 @@ linkBCO ie ce ul_bco linkBCO' :: ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO BCO -linkBCO' ie ce (UnlinkedBCO nm arity insns_barr literalsSS ptrsSS itblsSS) +linkBCO' ie ce (UnlinkedBCO nm arity insns_barr bitmap literalsSS ptrsSS itblsSS) -- Raises an IO exception on failure = do let literals = ssElts literalsSS ptrs = ssElts ptrsSS @@ -129,7 +129,9 @@ linkBCO' ie ce (UnlinkedBCO nm arity insns_barr literalsSS ptrsSS itblsSS) :: UArray Int Word literals_barr = case literals_arr of UArray lo hi barr -> barr - newBCO insns_barr literals_barr ptrs_parr itbls_barr + (I# arity#) = arity + + newBCO insns_barr literals_barr ptrs_parr itbls_barr arity# bitmap -- we recursively link any sub-BCOs while making the ptrs array @@ -170,9 +172,11 @@ writeArrayBCO (IOArray (STArray _ _ marr#)) (I# i#) bco# = IO $ \s# -> data BCO = BCO BCO# -newBCO :: ByteArray# -> ByteArray# -> Array# a -> ByteArray# -> IO BCO -newBCO a b c d - = IO (\s -> case newBCO# a b c d s of (# s1, bco #) -> (# s1, BCO bco #)) +newBCO :: ByteArray# -> ByteArray# -> Array# a + -> ByteArray# -> Int# -> ByteArray# -> IO BCO +newBCO instrs lits ptrs itbls arity bitmap + = IO $ \s -> case newBCO# instrs lits ptrs itbls arity bitmap s of + (# s1, bco #) -> (# s1, BCO bco #) lookupLiteral :: Either Word FastString -> IO Word diff --git a/ghc/compiler/prelude/primops.txt.pp b/ghc/compiler/prelude/primops.txt.pp index 5b60feb..8cde1b8 100644 --- a/ghc/compiler/prelude/primops.txt.pp +++ b/ghc/compiler/prelude/primops.txt.pp @@ -1,5 +1,5 @@ ----------------------------------------------------------------------- --- $Id: primops.txt.pp,v 1.25 2003/02/21 05:34:14 sof Exp $ +-- $Id: primops.txt.pp,v 1.26 2003/03/24 14:46:53 simonmar Exp $ -- -- Primitive Operations -- @@ -1657,7 +1657,7 @@ primop MkApUpd0_Op "mkApUpd0#" GenPrimOp out_of_line = True primop NewBCOOp "newBCO#" GenPrimOp - ByteArr# -> ByteArr# -> Array# a -> ByteArr# -> State# s -> (# State# s, BCO# #) + ByteArr# -> ByteArr# -> Array# a -> ByteArr# -> Int# -> ByteArr# -> State# s -> (# State# s, BCO# #) with has_side_effects = True out_of_line = True diff --git a/ghc/includes/Closures.h b/ghc/includes/Closures.h index 981b84b..2f4d865 100644 --- a/ghc/includes/Closures.h +++ b/ghc/includes/Closures.h @@ -1,5 +1,5 @@ /* ---------------------------------------------------------------------------- - * $Id: Closures.h,v 1.32 2002/12/11 15:36:37 simonmar Exp $ + * $Id: Closures.h,v 1.33 2003/03/24 14:46:53 simonmar Exp $ * * (c) The GHC Team, 1998-1999 * @@ -204,32 +204,34 @@ typedef struct _StgDeadWeak { /* Weak v */ * A BCO represents either a function or a stack frame. In each case, * it needs a bitmap to describe to the garbage collector the * pointerhood of its arguments/free variables respectively, and in - * the case of a function it also needs an arity. These pieces of - * information are stored at the beginning of the instruction array. + * the case of a function it also needs an arity. These are stored + * directly in the BCO, rather than in the instrs array, for two + * reasons: + * (a) speed: we need to get at the bitmap info quickly when + * the GC is examining APs and PAPs that point to this BCO + * (b) a subtle interaction with the compacting GC. In compacting + * GC, the info that describes the size/layout of a closure + * cannot be in an object more than one level of indirection + * away from the current object, because of the order in + * which pointers are updated to point to their new locations. */ typedef struct { StgHeader header; - StgArrWords *instrs; /* a pointer to an ArrWords */ - StgArrWords *literals; /* a pointer to an ArrWords */ - StgMutArrPtrs *ptrs; /* a pointer to a MutArrPtrs */ - StgArrWords *itbls; /* a pointer to an ArrWords */ + StgArrWords *instrs; // a pointer to an ArrWords + StgArrWords *literals; // a pointer to an ArrWords + StgMutArrPtrs *ptrs; // a pointer to a MutArrPtrs + StgArrWords *itbls; // a pointer to an ArrWords + StgHalfWord arity; // arity of this BCO + StgHalfWord size; // size of this BCO (in words) + StgWord bitmap[FLEXIBLE_ARRAY]; // an StgLargeBitmap } StgBCO; -typedef struct { - StgWord arity; - StgWord bitmap[FLEXIBLE_ARRAY]; // really an StgLargeBitmap -} StgBCOInfo; - -#define BCO_INFO(bco) ((StgBCOInfo *)(((StgBCO *)(bco))->instrs->payload)) -#define BCO_ARITY(bco) (BCO_INFO(bco)->arity) -#define BCO_BITMAP(bco) ((StgLargeBitmap *)BCO_INFO(bco)->bitmap) +#define BCO_BITMAP(bco) ((StgLargeBitmap *)((StgBCO *)(bco))->bitmap) #define BCO_BITMAP_SIZE(bco) (BCO_BITMAP(bco)->size) #define BCO_BITMAP_BITS(bco) (BCO_BITMAP(bco)->bitmap) #define BCO_BITMAP_SIZEW(bco) ((BCO_BITMAP_SIZE(bco) + BITS_IN(StgWord) - 1) \ / BITS_IN(StgWord)) -#define BCO_INSTRS(bco) ((StgWord16 *)(BCO_BITMAP_BITS(bco) + \ - BCO_BITMAP_SIZEW(bco))) /* Dynamic stack frames - these have a liveness mask in the object * itself, rather than in the info table. Useful for generic heap diff --git a/ghc/mk/version.mk b/ghc/mk/version.mk index c2ae772..a58597a 100644 --- a/ghc/mk/version.mk +++ b/ghc/mk/version.mk @@ -36,7 +36,7 @@ ProjectName = The Glorious Glasgow Haskell Compilation System ProjectNameShort = ghc -ProjectVersion = 5.05 +ProjectVersion = 5.05.20030323 ProjectVersionInt = 505 ProjectPatchLevel = 0 diff --git a/ghc/rts/GC.c b/ghc/rts/GC.c index 1805d0b..2b30d67 100644 --- a/ghc/rts/GC.c +++ b/ghc/rts/GC.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: GC.c,v 1.148 2003/03/19 18:41:18 sof Exp $ + * $Id: GC.c,v 1.149 2003/03/24 14:46:53 simonmar Exp $ * * (c) The GHC Team 1998-2003 * @@ -1752,9 +1752,11 @@ loop: case WEAK: case FOREIGN: case STABLE_NAME: - case BCO: return copy(q,sizeW_fromITBL(info),stp); + case BCO: + return copy(q,bco_sizeW((StgBCO *)q),stp); + case CAF_BLACKHOLE: case SE_CAF_BLACKHOLE: case SE_BLACKHOLE: @@ -2000,6 +2002,11 @@ eval_thunk_selector( nat field, StgSelector * p ) selector_loop: + if (Bdescr((StgPtr)selectee)->flags & BF_EVACUATED) { + SET_INFO(p, info_ptr); + return NULL; + } + info = get_itbl(selectee); switch (info->type) { case CONSTR: @@ -2438,7 +2445,6 @@ scavenge(step *stp) case WEAK: case FOREIGN: case STABLE_NAME: - case BCO: { StgPtr end; @@ -2450,6 +2456,16 @@ scavenge(step *stp) break; } + case BCO: { + StgBCO *bco = (StgBCO *)p; + (StgClosure *)bco->instrs = evacuate((StgClosure *)bco->instrs); + (StgClosure *)bco->literals = evacuate((StgClosure *)bco->literals); + (StgClosure *)bco->ptrs = evacuate((StgClosure *)bco->ptrs); + (StgClosure *)bco->itbls = evacuate((StgClosure *)bco->itbls); + p += bco_sizeW(bco); + break; + } + case IND_PERM: if (stp->gen->no != 0) { #ifdef PROFILING @@ -2767,7 +2783,6 @@ linear_scan: case WEAK: case FOREIGN: case STABLE_NAME: - case BCO: { StgPtr end; @@ -2778,6 +2793,15 @@ linear_scan: break; } + case BCO: { + StgBCO *bco = (StgBCO *)p; + (StgClosure *)bco->instrs = evacuate((StgClosure *)bco->instrs); + (StgClosure *)bco->literals = evacuate((StgClosure *)bco->literals); + (StgClosure *)bco->ptrs = evacuate((StgClosure *)bco->ptrs); + (StgClosure *)bco->itbls = evacuate((StgClosure *)bco->itbls); + break; + } + case IND_PERM: // don't need to do anything here: the only possible case // is that we're in a 1-space compacting collector, with diff --git a/ghc/rts/GCCompact.c b/ghc/rts/GCCompact.c index 16b8fb1..eaefcb7 100644 --- a/ghc/rts/GCCompact.c +++ b/ghc/rts/GCCompact.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: GCCompact.c,v 1.13 2002/12/11 15:36:42 simonmar Exp $ + * $Id: GCCompact.c,v 1.14 2003/03/24 14:46:54 simonmar Exp $ * * (c) The GHC Team 2001 * @@ -19,6 +19,13 @@ #include "StablePriv.h" #include "Apply.h" +// Turn off inlining when debugging - it obfuscates things +#ifdef DEBUG +#define INLINE +#else +#define INLINE inline +#endif + /* ----------------------------------------------------------------------------- Threading / unthreading pointers. @@ -41,7 +48,7 @@ except for the info pointer. -------------------------------------------------------------------------- */ -static inline void +static INLINE void thread( StgPtr p ) { StgPtr q = (StgPtr)*p; @@ -64,7 +71,7 @@ thread( StgPtr p ) } } -static inline void +static INLINE void unthread( StgPtr p, StgPtr free ) { StgPtr q = (StgPtr)*p, r; @@ -78,7 +85,7 @@ unthread( StgPtr p, StgPtr free ) *p = (StgWord)q; } -static inline StgInfoTable * +static INLINE StgInfoTable * get_threaded_info( StgPtr p ) { StgPtr q = (P_)GET_INFO((StgClosure *)p); @@ -93,7 +100,7 @@ get_threaded_info( StgPtr p ) // A word-aligned memmove will be faster for small objects than libc's or gcc's. // Remember, the two regions *might* overlap, but: to <= from. -static inline void +static INLINE void move(StgPtr to, StgPtr from, nat size) { for(; size > 0; --size) { @@ -101,7 +108,7 @@ move(StgPtr to, StgPtr from, nat size) } } -static inline nat +static INLINE nat obj_sizeW( StgClosure *p, StgInfoTable *info ) { switch (info->type) { @@ -136,6 +143,8 @@ obj_sizeW( StgClosure *p, StgInfoTable *info ) return mut_arr_ptrs_sizeW((StgMutArrPtrs*)p); case TSO: return tso_sizeW((StgTSO *)p); + case BCO: + return bco_sizeW((StgBCO *)p); default: return sizeW_fromITBL(info); } @@ -175,7 +184,7 @@ thread_static( StgClosure* p ) } } -static inline void +static INLINE void thread_large_bitmap( StgPtr p, StgLargeBitmap *large_bitmap, nat size ) { nat i, b; @@ -198,7 +207,7 @@ thread_large_bitmap( StgPtr p, StgLargeBitmap *large_bitmap, nat size ) } } -static inline StgPtr +static INLINE StgPtr thread_arg_block (StgFunInfoTable *fun_info, StgClosure **args) { StgPtr p; @@ -331,7 +340,8 @@ thread_stack(StgPtr p, StgPtr stack_end) StgRetFun *ret_fun = (StgRetFun *)p; StgFunInfoTable *fun_info; - fun_info = get_fun_itbl(ret_fun->fun); // *before* threading it! + fun_info = itbl_to_fun_itbl(get_threaded_info(ret_fun->fun)); + // *before* threading it! thread((StgPtr)&ret_fun->fun); p = thread_arg_block(fun_info, ret_fun->payload); continue; @@ -344,15 +354,14 @@ thread_stack(StgPtr p, StgPtr stack_end) } } -static inline StgPtr +static INLINE StgPtr thread_PAP (StgPAP *pap) { StgPtr p; StgWord bitmap, size; StgFunInfoTable *fun_info; - thread((StgPtr)&pap->fun); - fun_info = get_fun_itbl(pap->fun); + fun_info = itbl_to_fun_itbl(get_threaded_info(pap->fun)); ASSERT(fun_info->i.type != PAP); p = (StgPtr)pap->payload; @@ -384,10 +393,12 @@ thread_PAP (StgPAP *pap) } break; } + + thread((StgPtr)&pap->fun); return p; } -static inline StgPtr +static INLINE StgPtr thread_AP_STACK (StgAP_STACK *ap) { thread((StgPtr)&ap->fun); @@ -468,7 +479,7 @@ update_fwd_large( bdescr *bd ) } } -static inline StgPtr +static INLINE StgPtr thread_obj (StgInfoTable *info, StgPtr p) { switch (info->type) { @@ -504,12 +515,20 @@ thread_obj (StgInfoTable *info, StgPtr p) thread((StgPtr)&((StgClosure *)p)->payload[1]); return p + sizeofW(StgHeader) + 2; + case BCO: { + StgBCO *bco = (StgBCO *)p; + thread((StgPtr)&bco->instrs); + thread((StgPtr)&bco->literals); + thread((StgPtr)&bco->ptrs); + thread((StgPtr)&bco->itbls); + return p + bco_sizeW(bco); + } + case FUN: case THUNK: case CONSTR: case FOREIGN: case STABLE_NAME: - case BCO: case IND_PERM: case MUT_VAR: case MUT_CONS: diff --git a/ghc/rts/Interpreter.c b/ghc/rts/Interpreter.c index 0df0f99..3fc8388 100644 --- a/ghc/rts/Interpreter.c +++ b/ghc/rts/Interpreter.c @@ -274,7 +274,7 @@ eval_obj: break; case BCO: - ASSERT(BCO_ARITY(obj) > 0); + ASSERT(((StgBCO *)obj)->arity > 0); break; case AP: /* Copied from stg_AP_entry. */ @@ -576,7 +576,7 @@ do_apply: nat arity, i; Sp++; - arity = BCO_ARITY(obj); + arity = ((StgBCO *)obj)->arity; ASSERT(arity > 0); if (arity < n) { // n must be greater than 1, and the only kinds of @@ -718,7 +718,7 @@ run_BCO: { register int bciPtr = 1; /* instruction pointer */ register StgBCO* bco = (StgBCO*)obj; - register StgWord16* instrs = (StgWord16*)(BCO_INSTRS(bco)); + register StgWord16* instrs = (StgWord16*)(bco->instrs->payload); register StgWord* literals = (StgWord*)(&bco->literals->payload[0]); register StgPtr* ptrs = (StgPtr*)(&bco->ptrs->payload[0]); register StgInfoTable** itbls = (StgInfoTable**) diff --git a/ghc/rts/PrimOps.hc b/ghc/rts/PrimOps.hc index e5d286d..f16a63b 100644 --- a/ghc/rts/PrimOps.hc +++ b/ghc/rts/PrimOps.hc @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: PrimOps.hc,v 1.105 2003/02/22 04:51:51 sof Exp $ + * $Id: PrimOps.hc,v 1.106 2003/03/24 14:46:54 simonmar Exp $ * * (c) The GHC Team, 1998-2002 * @@ -1525,20 +1525,36 @@ FN_(newBCOzh_fast) R2.p = literals R3.p = ptrs R4.p = itbls + R5.i = arity + R6.p = bitmap array */ StgBCO *bco; + nat size; + StgArrWords *bitmap_arr; FB_ - HP_CHK_GEN_TICKY(sizeofW(StgBCO),R1_PTR|R2_PTR|R3_PTR|R4_PTR, newBCOzh_fast); - TICK_ALLOC_PRIM(sizeofW(StgHeader), sizeofW(StgBCO)-sizeofW(StgHeader), 0); - CCS_ALLOC(CCCS,sizeofW(StgBCO)); /* ccs prof */ - bco = (StgBCO *) (Hp + 1 - sizeofW(StgBCO)); + bitmap_arr = (StgArrWords *)R6.cl; + size = sizeofW(StgBCO) + bitmap_arr->words; + HP_CHK_GEN_TICKY(size,R1_PTR|R2_PTR|R3_PTR|R4_PTR|R6_PTR, newBCOzh_fast); + TICK_ALLOC_PRIM(size, size-sizeofW(StgHeader), 0); + CCS_ALLOC(CCCS,size); /* ccs prof */ + bco = (StgBCO *) (Hp + 1 - size); SET_HDR(bco, (const StgInfoTable *)&stg_BCO_info, CCCS); bco->instrs = (StgArrWords*)R1.cl; bco->literals = (StgArrWords*)R2.cl; bco->ptrs = (StgMutArrPtrs*)R3.cl; bco->itbls = (StgArrWords*)R4.cl; + bco->arity = R5.w; + bco->size = size; + + // Copy the arity/bitmap info into the BCO + { + int i; + for (i = 0; i < bitmap_arr->words; i++) { + bco->bitmap[i] = bitmap_arr->payload[i]; + } + } TICK_RET_UNBOXED_TUP(1); RET_P(bco); @@ -1555,7 +1571,7 @@ FN_(mkApUpd0zh_fast) // This function is *only* used to wrap zero-arity BCOs in an // updatable wrapper (see ByteCodeLink.lhs). An AP thunk is always // saturated and always points directly to a FUN or BCO. - ASSERT(get_itbl(R1.cl)->type == BCO && BCO_ARITY(R1.p) == 0); + ASSERT(get_itbl(R1.cl)->type == BCO && ((StgBCO *)R1.p)->arity == 0); HP_CHK_GEN_TICKY(PAP_sizeW(0), R1_PTR, mkApUpd0zh_fast); TICK_ALLOC_PRIM(sizeofW(StgHeader), PAP_sizeW(0)-sizeofW(StgHeader), 0); diff --git a/ghc/rts/ProfHeap.c b/ghc/rts/ProfHeap.c index fea4abc..3752543 100644 --- a/ghc/rts/ProfHeap.c +++ b/ghc/rts/ProfHeap.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: ProfHeap.c,v 1.44 2003/03/18 14:36:56 simonmar Exp $ + * $Id: ProfHeap.c,v 1.45 2003/03/24 14:46:55 simonmar Exp $ * * (c) The GHC Team, 1998-2003 * @@ -861,6 +861,10 @@ heapCensusChain( Census *census, bdescr *bd ) break; case BCO: + prim = rtsTrue; + size = bco_sizeW((StgBCO *)p); + break; + case MVAR: case WEAK: case FOREIGN: diff --git a/ghc/rts/Sanity.c b/ghc/rts/Sanity.c index 33d1980..6a5ab22 100644 --- a/ghc/rts/Sanity.c +++ b/ghc/rts/Sanity.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: Sanity.c,v 1.31 2002/12/11 15:36:48 simonmar Exp $ + * $Id: Sanity.c,v 1.32 2003/03/24 14:46:56 simonmar Exp $ * * (c) The GHC Team, 1998-2001 * @@ -272,7 +272,6 @@ checkClosure( StgClosure* p ) case BLACKHOLE: case CAF_BLACKHOLE: case FOREIGN: - case BCO: case STABLE_NAME: case MUT_VAR: case MUT_CONS: @@ -290,6 +289,15 @@ checkClosure( StgClosure* p ) return sizeW_fromITBL(info); } + case BCO: { + StgBCO *bco = (StgBCO *)p; + ASSERT(LOOKS_LIKE_CLOSURE_PTR(bco->instrs)); + ASSERT(LOOKS_LIKE_CLOSURE_PTR(bco->literals)); + ASSERT(LOOKS_LIKE_CLOSURE_PTR(bco->ptrs)); + ASSERT(LOOKS_LIKE_CLOSURE_PTR(bco->itbls)); + return bco_sizeW(bco); + } + case IND_STATIC: /* (1, 0) closure */ ASSERT(LOOKS_LIKE_CLOSURE_PTR(((StgIndStatic*)p)->indirectee)); return sizeW_fromITBL(info); diff --git a/ghc/rts/Storage.h b/ghc/rts/Storage.h index 838248d..dc86e02 100644 --- a/ghc/rts/Storage.h +++ b/ghc/rts/Storage.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: Storage.h,v 1.48 2003/03/21 16:18:39 sof Exp $ + * $Id: Storage.h,v 1.49 2003/03/24 14:46:57 simonmar Exp $ * * (c) The GHC Team, 1998-2002 * @@ -398,6 +398,9 @@ static __inline__ StgOffset mut_arr_ptrs_sizeW( StgMutArrPtrs* x ) static __inline__ StgWord tso_sizeW ( StgTSO *tso ) { return TSO_STRUCT_SIZEW + tso->stack_size; } +static __inline__ StgWord bco_sizeW ( StgBCO *bco ) +{ return bco->size; } + /* ----------------------------------------------------------------------------- Sizes of stack frames -------------------------------------------------------------------------- */ diff --git a/ghc/utils/genapply/GenApply.hs b/ghc/utils/genapply/GenApply.hs index b2486c0..1ec6592 100644 --- a/ghc/utils/genapply/GenApply.hs +++ b/ghc/utils/genapply/GenApply.hs @@ -310,7 +310,7 @@ genApply args = -- else: text "case BCO:", nest 4 (vcat [ - text "arity = BCO_ARITY((StgBCO *)R1.p);", + text "arity = ((StgBCO *)R1.p)->arity;", text "ASSERT(arity > 0);", genMkPAP "BUILD_PAP" "stg_BCO_entry" True{-stack apply-} False{-not a PAP-} -- 1.7.10.4