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.
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 )
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
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) :
)
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",
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
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,
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(..) )
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
:: 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
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
-----------------------------------------------------------------------
--- $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
--
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
/* ----------------------------------------------------------------------------
- * $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
*
* 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
ProjectName = The Glorious Glasgow Haskell Compilation System
ProjectNameShort = ghc
-ProjectVersion = 5.05
+ProjectVersion = 5.05.20030323
ProjectVersionInt = 505
ProjectPatchLevel = 0
/* -----------------------------------------------------------------------------
- * $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
*
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:
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:
case WEAK:
case FOREIGN:
case STABLE_NAME:
- case BCO:
{
StgPtr end;
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
case WEAK:
case FOREIGN:
case STABLE_NAME:
- case BCO:
{
StgPtr end;
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
/* -----------------------------------------------------------------------------
- * $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
*
#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.
except for the info pointer.
-------------------------------------------------------------------------- */
-static inline void
+static INLINE void
thread( StgPtr p )
{
StgPtr q = (StgPtr)*p;
}
}
-static inline void
+static INLINE void
unthread( StgPtr p, StgPtr free )
{
StgPtr q = (StgPtr)*p, r;
*p = (StgWord)q;
}
-static inline StgInfoTable *
+static INLINE StgInfoTable *
get_threaded_info( StgPtr p )
{
StgPtr q = (P_)GET_INFO((StgClosure *)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) {
}
}
-static inline nat
+static INLINE nat
obj_sizeW( StgClosure *p, StgInfoTable *info )
{
switch (info->type) {
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);
}
}
}
-static inline void
+static INLINE void
thread_large_bitmap( StgPtr p, StgLargeBitmap *large_bitmap, nat size )
{
nat i, b;
}
}
-static inline StgPtr
+static INLINE StgPtr
thread_arg_block (StgFunInfoTable *fun_info, StgClosure **args)
{
StgPtr p;
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;
}
}
-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;
}
break;
}
+
+ thread((StgPtr)&pap->fun);
return p;
}
-static inline StgPtr
+static INLINE StgPtr
thread_AP_STACK (StgAP_STACK *ap)
{
thread((StgPtr)&ap->fun);
}
}
-static inline StgPtr
+static INLINE StgPtr
thread_obj (StgInfoTable *info, StgPtr p)
{
switch (info->type) {
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:
break;
case BCO:
- ASSERT(BCO_ARITY(obj) > 0);
+ ASSERT(((StgBCO *)obj)->arity > 0);
break;
case AP: /* Copied from stg_AP_entry. */
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
{
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**)
/* -----------------------------------------------------------------------------
- * $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
*
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);
// 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);
/* -----------------------------------------------------------------------------
- * $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
*
break;
case BCO:
+ prim = rtsTrue;
+ size = bco_sizeW((StgBCO *)p);
+ break;
+
case MVAR:
case WEAK:
case FOREIGN:
/* -----------------------------------------------------------------------------
- * $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
*
case BLACKHOLE:
case CAF_BLACKHOLE:
case FOREIGN:
- case BCO:
case STABLE_NAME:
case MUT_VAR:
case MUT_CONS:
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);
/* -----------------------------------------------------------------------------
- * $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
*
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
-------------------------------------------------------------------------- */
-- 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-}
projects / ghc-hetmet.git / commitdiff