From 4391e44f910ce579f269986faef9e5db8907a6c0 Mon Sep 17 00:00:00 2001
From: simonm <unknown>
Date: Wed, 13 Jan 1999 17:25:59 +0000
Subject: [PATCH] [project @ 1999-01-13 17:25:37 by simonm] Added a
generational garbage collector.
The collector is reliable but fairly untuned as yet. It works with an
arbitrary number of generations: use +RTS -G<gens> to change the
number of generations used (default 2).
Stats: +RTS -Sstderr is quite useful, but to really see what's going
on compile the RTS with -DDEBUG and use +RTS -D32.
ARR_PTRS removed - it wasn't used anywhere.
Sanity checking improved:
- free blocks are now spammed when sanity checking is turned on
- a check for leaking blocks is performed after each GC.
---
ghc/docs/users_guide/runtime_control.vsgml | 62 +-
ghc/driver/ghc.lprl | 2 +-
ghc/includes/Block.h | 11 +-
ghc/includes/ClosureMacros.h | 8 +-
ghc/includes/ClosureTypes.h | 51 +-
ghc/includes/Closures.h | 26 +-
ghc/includes/InfoTables.h | 55 +-
ghc/includes/PrimOps.h | 11 +-
ghc/includes/Rts.h | 2 +-
ghc/includes/StgMiscClosures.h | 9 +-
ghc/includes/TSO.h | 5 +-
ghc/includes/Updates.h | 29 +-
ghc/rts/BlockAlloc.c | 25 +-
ghc/rts/BlockAlloc.h | 3 +-
ghc/rts/DebugProf.c | 6 +-
ghc/rts/GC.c | 1317 +++++++++++++++-----
ghc/rts/MBlock.c | 6 +-
ghc/rts/MBlock.h | 4 +-
ghc/rts/Makefile | 2 +-
ghc/rts/PrimOps.hc | 10 +-
ghc/rts/RtsFlags.c | 20 +-
ghc/rts/RtsFlags.h | 7 +-
ghc/rts/Sanity.c | 58 +-
ghc/rts/Sanity.h | 7 +-
ghc/rts/Schedule.c | 38 +-
ghc/rts/Stats.c | 109 +-
ghc/rts/Stats.h | 6 +-
ghc/rts/StgMiscClosures.hc | 40 +-
ghc/rts/Storage.c | 215 +++-
ghc/rts/Storage.h | 28 +-
ghc/rts/StoragePriv.h | 111 +-
ghc/rts/Updates.hc | 6 +-
ghc/rts/Weak.c | 8 +-
33 files changed, 1740 insertions(+), 557 deletions(-)
diff --git a/ghc/docs/users_guide/runtime_control.vsgml b/ghc/docs/users_guide/runtime_control.vsgml
index 19967ec53c68..82876bffdfa3 100644
--- a/ghc/docs/users_guide/runtime_control.vsgml
+++ b/ghc/docs/users_guide/runtime_control.vsgml
@@ -63,18 +63,26 @@ operation, but there are several things that can be tweaked for
maximum performance.
<descrip>
+<tag>@-G<generations>@:</tag>
+<nidx>-G<generations> RTS option</nidx>
+<nidx>generations, number of</nidx>
+
+[Default: 2] Set the number of generations used by the garbage
+collector. The default of 2 seems to be good, but the garbage
+collector can support any number of generations. NOTE: -G1 (i.e. a
+two-space copying collector) is currently not supported.
+
<tag>@-A<size>@:</tag>
<nidx>-A<size> RTS option</nidx>
<nidx>allocation area, size</nidx>
-[Default: 256k] Set the minimum (and initial) allocation area size
-used by the garbage collector. The allocation area is resized after
-each garbage collection to be a multiple of the size of the current
-live data (currently a factor of 2).
+[Default: 256k] Set the allocation area size used by the garbage
+collector. The allocation area (actually generation 0 step 0) is
+fixed and is never resized.
-Increasing the minimum allocation area size will typically give better
-performance for programs which quickly generate a large amount of live
-data.
+Increasing the allocation area size may or may not give better
+performance (a bigger allocation area means worse cache behaviour but
+fewer garbage collections and less promotion).
<tag>@-k<size>@:</tag>
<nidx>-k<size> RTS option</nidx>
@@ -132,26 +140,26 @@ heap size based on the current amount of live data.
%PostScript), using the @stat2resid@<nidx>stat2resid</nidx> utility in
%the GHC distribution (@ghc/utils/stat2resid@).
-<tag>@-F2s@:</tag>
-<nidx>-F2s RTS option</nidx>
-
-Forces a program compiled for generational GC to use two-space copying
-collection. The two-space collector may outperform the generational
-collector for programs which have a very low heap residency. It can
-also be used to generate a statistics file from which a basic heap
-residency profile can be produced (see Section <ref name="stat2resid -
-residency info from GC stats" id="stat2resid">).
-
-There will still be a small execution overhead imposed by the
-generational compilation as the test for old generation updates will
-still be executed (of course none will actually happen). This
-overhead is typically less than 1\%.
-
-<tag>@-j<size>@:</tag>
-<nidx>-j<size> RTS option</nidx>
-Force a major garbage collection every @<size>@ bytes. (Normally
-used because you're keen on getting major-GC stats, notably heap residency
-info.)
+% <tag>@-F2s@:</tag>
+% <nidx>-F2s RTS option</nidx>
+%
+% Forces a program compiled for generational GC to use two-space copying
+% collection. The two-space collector may outperform the generational
+% collector for programs which have a very low heap residency. It can
+% also be used to generate a statistics file from which a basic heap
+% residency profile can be produced (see Section <ref name="stat2resid -
+% residency info from GC stats" id="stat2resid">).
+%
+% There will still be a small execution overhead imposed by the
+% generational compilation as the test for old generation updates will
+% still be executed (of course none will actually happen). This
+% overhead is typically less than 1\%.
+%
+% <tag>@-j<size>@:</tag>
+% <nidx>-j<size> RTS option</nidx>
+% Force a major garbage collection every @<size>@ bytes. (Normally
+% used because you're keen on getting major-GC stats, notably heap residency
+% info.)
</descrip>
diff --git a/ghc/driver/ghc.lprl b/ghc/driver/ghc.lprl
index 6ea56678c91d..957c9009e225 100644
--- a/ghc/driver/ghc.lprl
+++ b/ghc/driver/ghc.lprl
@@ -2301,7 +2301,7 @@ sub process_ghc_timings {
$MaxResidency = $1; $ResidencySamples = $2;
}
- $GCs = $1 if /^\s*([0-9,]+) garbage collections? performed/;
+ $GCs = $1 if /^\s*([0-9,]+) (collections? in generation 0|garbage collections? performed)/;
# The presence of -? in the following pattern is only there to
# accommodate 0.29 && <= 2.05 RTS'
diff --git a/ghc/includes/Block.h b/ghc/includes/Block.h
index b8a0260a7a9b..113145e4a493 100644
--- a/ghc/includes/Block.h
+++ b/ghc/includes/Block.h
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: Block.h,v 1.2 1998/12/02 13:20:53 simonm Exp $
+ * $Id: Block.h,v 1.3 1999/01/13 17:25:51 simonm Exp $
*
* Block structure for the storage manager
*
@@ -43,13 +43,14 @@ typedef struct _bdescr {
StgPtr free; /* first free byte of memory */
struct _bdescr *link; /* used for chaining blocks together */
struct _bdescr *back; /* used (occasionally) for doubly-linked lists*/
- StgNat32 gen; /* generation */
- StgNat32 step; /* step */
+ struct _generation *gen; /* generation */
+ struct _step *step; /* step */
StgNat32 blocks; /* no. of blocks (if grp head, 0 otherwise) */
+ StgNat32 evacuated; /* block is in to-space */
#if SIZEOF_VOID_P == 8
- StgNat32 _padding[5];
+ StgNat32 _padding[2];
#else
- StgNat32 _padding[1];
+ StgNat32 _padding[0];
#endif
} bdescr;
diff --git a/ghc/includes/ClosureMacros.h b/ghc/includes/ClosureMacros.h
index 9d8f6cf2add5..76bec3e8e55b 100644
--- a/ghc/includes/ClosureMacros.h
+++ b/ghc/includes/ClosureMacros.h
@@ -1,5 +1,5 @@
/* ----------------------------------------------------------------------------
- * $Id: ClosureMacros.h,v 1.2 1998/12/02 13:20:58 simonm Exp $
+ * $Id: ClosureMacros.h,v 1.3 1999/01/13 17:25:52 simonm Exp $
*
* Macros for building and manipulating closures
*
@@ -186,8 +186,8 @@ static __inline__ StgOffset pap_sizeW( StgPAP* x )
*/
static __inline__ StgOffset arr_words_sizeW( StgArrWords* x )
{ return sizeofW(StgArrWords) + x->words; }
-static __inline__ StgOffset arr_ptrs_sizeW( StgArrPtrs* x )
-{ return sizeofW(StgArrPtrs) + x->ptrs; }
+static __inline__ StgOffset mut_arr_ptrs_sizeW( StgMutArrPtrs* x )
+{ return sizeofW(StgMutArrPtrs) + x->ptrs; }
static __inline__ StgWord bco_sizeW( StgBCO* bco )
{ return BCO_sizeW(bco->n_ptrs,bco->n_words,bco->n_instrs); }
@@ -241,8 +241,6 @@ static __inline__ StgWord tso_sizeW ( StgTSO *tso )
SET_TICKY_HDR((StgClosure *)(c),0); \
}
-/* works for all ARR_WORDS, ARR_PTRS variants (at the moment...) */
-
#define SET_ARR_HDR(c,info,costCentreStack,n_words) \
SET_HDR(c,info,costCentreStack); \
(c)->words = n_words;
diff --git a/ghc/includes/ClosureTypes.h b/ghc/includes/ClosureTypes.h
index 495ca27d0042..c91b9b228189 100644
--- a/ghc/includes/ClosureTypes.h
+++ b/ghc/includes/ClosureTypes.h
@@ -1,5 +1,5 @@
/* ----------------------------------------------------------------------------
- * $Id: ClosureTypes.h,v 1.2 1998/12/02 13:20:58 simonm Exp $
+ * $Id: ClosureTypes.h,v 1.3 1999/01/13 17:25:52 simonm Exp $
*
* Closure Type Constants
*
@@ -12,37 +12,29 @@
/* Object tag 0 raises an internal error */
#define INVALID_OBJECT 0
-
#define CONSTR 1
/* #define CONSTR_p_np */
#define CONSTR_INTLIKE 2
#define CONSTR_CHARLIKE 3
#define CONSTR_STATIC 4
#define CONSTR_NOCAF_STATIC 5
-
#define FUN 6
#define FUN_STATIC 7
-
#define THUNK 8
/* #define THUNK_p_np */
#define THUNK_STATIC 9
#define THUNK_SELECTOR 10
-
#define BCO 11
-
#define AP_UPD 12
#define PAP 13
-
#define IND 14
#define IND_OLDGEN 15
#define IND_PERM 16
#define IND_OLDGEN_PERM 17
#define IND_STATIC 18
-
#define CAF_UNENTERED 19
#define CAF_ENTERED 20
#define CAF_BLACKHOLE 21
-
#define RET_BCO 22
#define RET_SMALL 23
#define RET_VEC_SMALL 24
@@ -50,28 +42,23 @@
#define RET_VEC_BIG 26
#define RET_DYN 27
#define UPDATE_FRAME 28
-#define CATCH_FRAME 29
-#define STOP_FRAME 30
-#define SEQ_FRAME 31
-
-#define BLACKHOLE 32
-#define MVAR 33
-
-#define ARR_WORDS 34
-#define ARR_PTRS 35
-
-#define MUT_ARR_WORDS 36
-#define MUT_ARR_PTRS 37
-#define MUT_ARR_PTRS_FROZEN 38
-#define MUT_VAR 39
-
-#define WEAK 40
-#define FOREIGN 41
-
-#define TSO 42
-#define BLOCKED_FETCH 43
-#define FETCH_ME 44
-
-#define EVACUATED 45
+#define UPDATE_STATIC_FRAME 29
+#define CATCH_FRAME 30
+#define STOP_FRAME 31
+#define SEQ_FRAME 32
+#define BLACKHOLE 33
+#define BLACKHOLE_STATIC 34
+#define MVAR 35
+#define ARR_WORDS 36
+#define MUT_ARR_WORDS 37
+#define MUT_ARR_PTRS 38
+#define MUT_ARR_PTRS_FROZEN 39
+#define MUT_VAR 40
+#define WEAK 41
+#define FOREIGN 42
+#define TSO 43
+#define BLOCKED_FETCH 44
+#define FETCH_ME 45
+#define EVACUATED 46
#endif CLOSURETYPES_H
diff --git a/ghc/includes/Closures.h b/ghc/includes/Closures.h
index a60fe2836108..f77ce9af784e 100644
--- a/ghc/includes/Closures.h
+++ b/ghc/includes/Closures.h
@@ -1,5 +1,5 @@
/* ----------------------------------------------------------------------------
- * $Id: Closures.h,v 1.2 1998/12/02 13:20:59 simonm Exp $
+ * $Id: Closures.h,v 1.3 1999/01/13 17:25:53 simonm Exp $
*
* Closures
*
@@ -113,6 +113,19 @@ typedef struct StgClosure_ {
struct StgClosure_ *payload[0];
} StgClosure;
+/* What a stroke of luck - all our mutable closures follow the same
+ * basic layout, with the mutable link field as the second field after
+ * the header. This means the following structure is the supertype of
+ * mutable closures.
+ */
+
+typedef struct StgMutClosure_ {
+ StgHeader header;
+ StgPtr *padding;
+ struct StgMutClosure_ *mut_link;
+ struct StgClosure_ *payload[0];
+} StgMutClosure;
+
typedef struct {
StgHeader header;
StgClosure *selectee;
@@ -147,8 +160,8 @@ typedef struct {
typedef struct {
StgHeader header;
- StgClosure *mut_link;
StgClosure *indirectee;
+ StgMutClosure *mut_link;
} StgIndOldGen;
typedef struct {
@@ -178,12 +191,14 @@ typedef struct {
typedef struct {
StgHeader header;
StgWord ptrs;
+ StgMutClosure *mut_link; /* mutable list */
StgClosure *payload[0];
-} StgArrPtrs;
+} StgMutArrPtrs;
typedef struct {
StgHeader header;
StgClosure *var;
+ StgMutClosure *mut_link;
} StgMutVar;
typedef struct _StgUpdateFrame {
@@ -251,8 +266,9 @@ typedef struct {
typedef struct {
StgHeader header;
- struct StgTSO_* head;
- struct StgTSO_* tail;
+ struct StgTSO_ *head;
+ StgMutClosure *mut_link;
+ struct StgTSO_ *tail;
StgClosure* value;
} StgMVar;
diff --git a/ghc/includes/InfoTables.h b/ghc/includes/InfoTables.h
index 41a61df4d6c0..20950267ce1c 100644
--- a/ghc/includes/InfoTables.h
+++ b/ghc/includes/InfoTables.h
@@ -1,5 +1,5 @@
/* ----------------------------------------------------------------------------
- * $Id: InfoTables.h,v 1.2 1998/12/02 13:21:10 simonm Exp $
+ * $Id: InfoTables.h,v 1.3 1999/01/13 17:25:53 simonm Exp $
*
* Info Tables
*
@@ -130,7 +130,6 @@ typedef enum {
, MVAR
, ARR_WORDS
- , ARR_PTRS
, MUT_ARR_WORDS
, MUT_ARR_PTRS
@@ -162,9 +161,12 @@ typedef enum {
#define _UPT (1<<6) /* unpointed? */
#define _SRT (1<<7) /* has an SRT? */
-#define isSTATIC(flags) ((flags)&_STA)
+#define isSTATIC(flags) ((flags)&_STA)
+#define isMUTABLE(flags) ((flags) &_MUT)
+
#define closure_STATIC(closure) ( get_itbl(closure)->flags & _STA)
#define closure_SHOULD_SPARK(closure) (!(get_itbl(closure)->flags & _NS))
+#define closure_MUTABLE(closure) ( get_itbl(closure)->flags & _MUT)
#define closure_UNPOINTED(closure) ( get_itbl(closure)->flags & _UPT)
/* HNF BTM NS STA THU MUT UPT SRT */
@@ -191,58 +193,65 @@ typedef enum {
#define FLAGS_EVACUATED 0
#define FLAGS_ARR_WORDS (_HNF| _NS| _UPT )
#define FLAGS_MUT_ARR_WORDS (_HNF| _NS| _MUT|_UPT )
-#define FLAGS_ARR_PTRS (_HNF| _NS| _UPT )
#define FLAGS_MUT_ARR_PTRS (_HNF| _NS| _MUT|_UPT )
#define FLAGS_MUT_ARR_PTRS_FROZEN (_HNF| _NS| _MUT|_UPT )
#define FLAGS_MUT_VAR (_HNF| _NS| _MUT|_UPT )
#define FLAGS_FOREIGN (_HNF| _NS| _UPT )
#define FLAGS_WEAK (_HNF| _NS| _UPT )
-#define FLAGS_BLACKHOLE ( _BTM|_NS| _UPT )
-#define FLAGS_MVAR (_HNF| _NS| _UPT )
+#define FLAGS_BLACKHOLE ( _NS| _UPT )
+#define FLAGS_MVAR (_HNF| _NS| _MUT|_UPT )
#define FLAGS_FETCH_ME (_HNF| _NS )
-#define FLAGS_TSO 0
+#define FLAGS_TSO (_HNF| _NS| _MUT|_UPT )
#define FLAGS_RET_BCO ( _BTM )
#define FLAGS_RET_SMALL ( _BTM| _SRT)
#define FLAGS_RET_VEC_SMALL ( _BTM| _SRT)
#define FLAGS_RET_BIG ( _SRT)
#define FLAGS_RET_VEC_BIG ( _SRT)
#define FLAGS_RET_DYN ( _SRT)
-#define FLAGS_CATCH_FRAME 0
-#define FLAGS_STOP_FRAME 0
-#define FLAGS_SEQ_FRAME 0
-#define FLAGS_UPDATE_FRAME 0
+#define FLAGS_CATCH_FRAME ( _BTM )
+#define FLAGS_STOP_FRAME ( _BTM )
+#define FLAGS_SEQ_FRAME ( _BTM )
+#define FLAGS_UPDATE_FRAME ( _BTM )
/* -----------------------------------------------------------------------------
Info Tables
-------------------------------------------------------------------------- */
/* A large bitmap. Small 32-bit ones live in the info table, but sometimes
- * 32 bits isn't enough and we have to generate a larger one.
+ * 32 bits isn't enough and we have to generate a larger one. (sizes
+ * differ for 64-bit machines.
*/
typedef struct {
- StgNat32 size;
- StgNat32 bitmap[0];
+ StgWord size;
+ StgWord bitmap[0];
} StgLargeBitmap;
/*
* Stuff describing the closure layout. Well, actually, it might
- * contain the selector index for a THUNK_SELECTOR.
+ * contain the selector index for a THUNK_SELECTOR. If we're on a
+ * 64-bit architecture then we can enlarge some of these fields, since
+ * the union contains a pointer field.
*/
typedef union {
- StgNat32 bitmap; /* bit pattern, 1 = pointer, 0 = non-pointer */
-
+ StgWord bitmap; /* bit pattern, 1 = pointer, 0 = non-pointer */
+ StgWord selector_offset; /* used in THUNK_SELECTORs */
StgLargeBitmap* large_bitmap; /* pointer to large bitmap structure */
+#if SIZEOF_VOID_P == 8
+ struct {
+ StgNat32 ptrs; /* number of pointers */
+ StgNat32 nptrs; /* number of non-pointers */
+ } payload;
+#else
struct {
StgNat16 ptrs; /* number of pointers */
StgNat16 nptrs; /* number of non-pointers */
} payload;
+#endif
- StgNat32 selector_offset; /* used in THUNK_SELECTORs */
-
} StgClosureInfo;
/*
@@ -259,10 +268,16 @@ typedef struct _StgInfoTable {
StgParInfo par;
StgProfInfo prof;
StgDebugInfo debug;
- StgClosureInfo layout; /* closure layout info */
+ StgClosureInfo layout; /* closure layout info (pointer-sized) */
+#if SIZEOF_VOID_P == 8
+ StgNat16 flags; /* } */
+ StgClosureType type : 16; /* } These 4 elements fit into 64 bits */
+ StgNat32 srt_len; /* } */
+#else
StgNat8 flags; /* } */
StgClosureType type : 8; /* } These 4 elements fit into 32 bits */
StgNat16 srt_len; /* } */
+#endif
#if USE_MINIINTERPRETER
StgFunPtr (*vector)[];
StgFunPtr entry;
diff --git a/ghc/includes/PrimOps.h b/ghc/includes/PrimOps.h
index ef1a19fa1915..f16af6517ee2 100644
--- a/ghc/includes/PrimOps.h
+++ b/ghc/includes/PrimOps.h
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: PrimOps.h,v 1.2 1998/12/02 13:21:18 simonm Exp $
+ * $Id: PrimOps.h,v 1.3 1999/01/13 17:25:53 simonm Exp $
*
* Macros for primitive operations in STG-ish C code.
*
@@ -109,6 +109,8 @@ typedef union {
c = z.i[C]; \
}
+
+
#define subWithCarryZh(r,c,a,b) \
{ long_long_u z; \
z.l = a + b; \
@@ -407,25 +409,22 @@ LI_ stg_word64ToInt64 (StgNat64);
* about increasing the alignment requirements.
*/
#define REAL_BYTE_ARR_CTS(a) ((void *) (((StgArrWords *)(a))->payload))
-#define REAL_PTRS_ARR_CTS(a) ((P_) (((StgArrPtrs *)(a))->payload))
+#define REAL_PTRS_ARR_CTS(a) ((P_) (((StgMutArrPtrs *)(a))->payload))
#ifdef DEBUG
#define BYTE_ARR_CTS(a) \
({ ASSERT(GET_INFO(a) == &ARR_WORDS_info); \
REAL_BYTE_ARR_CTS(a); })
#define PTRS_ARR_CTS(a) \
- ({ ASSERT((GET_INFO(a) == &ARR_PTRS_info) \
- || (GET_INFO(a) == &MUT_ARR_PTRS_info));\
+ ({ ASSERT((GET_INFO(a) == &MUT_ARR_PTRS_info));\
REAL_PTRS_ARR_CTS(a); })
#else
#define BYTE_ARR_CTS(a) REAL_BYTE_ARR_CTS(a)
#define PTRS_ARR_CTS(a) REAL_PTRS_ARR_CTS(a)
#endif
-/* Todo: define... */
extern I_ genSymZh(void);
extern I_ resetGenSymZh(void);
-extern I_ incSeqWorldZh(void);
/*--- everything except new*Array is done inline: */
diff --git a/ghc/includes/Rts.h b/ghc/includes/Rts.h
index c8dcaaefbdd0..3f7d868f41a6 100644
--- a/ghc/includes/Rts.h
+++ b/ghc/includes/Rts.h
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: Rts.h,v 1.2 1998/12/02 13:21:21 simonm Exp $
+ * $Id: Rts.h,v 1.3 1999/01/13 17:25:54 simonm Exp $
*
* Top-level include file for the RTS itself
*
diff --git a/ghc/includes/StgMiscClosures.h b/ghc/includes/StgMiscClosures.h
index c0bde3b13d1d..2ef0534c8dc9 100644
--- a/ghc/includes/StgMiscClosures.h
+++ b/ghc/includes/StgMiscClosures.h
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: StgMiscClosures.h,v 1.2 1998/12/02 13:21:39 simonm Exp $
+ * $Id: StgMiscClosures.h,v 1.3 1999/01/13 17:25:54 simonm Exp $
*
* Entry code for various built-in closure types.
*
@@ -31,11 +31,12 @@ STGFUN(FULL_MVAR_entry);
STGFUN(EMPTY_MVAR_entry);
STGFUN(ARR_WORDS_entry);
STGFUN(MUT_ARR_WORDS_entry);
-STGFUN(ARR_PTRS_entry);
STGFUN(MUT_ARR_PTRS_entry);
STGFUN(MUT_ARR_PTRS_FROZEN_entry);
STGFUN(MUT_VAR_entry);
STGFUN(END_TSO_QUEUE_entry);
+STGFUN(MUT_CONS_entry);
+STGFUN(END_MUT_LIST_entry);
STGFUN(dummy_ret_entry);
/* info tables */
@@ -59,11 +60,12 @@ extern const StgInfoTable EMPTY_MVAR_info;
extern const StgInfoTable TSO_info;
extern const StgInfoTable ARR_WORDS_info;
extern const StgInfoTable MUT_ARR_WORDS_info;
-extern const StgInfoTable ARR_PTRS_info;
extern const StgInfoTable MUT_ARR_PTRS_info;
extern const StgInfoTable MUT_ARR_PTRS_FROZEN_info;
extern const StgInfoTable MUT_VAR_info;
extern const StgInfoTable END_TSO_QUEUE_info;
+extern const StgInfoTable MUT_CONS_info;
+extern const StgInfoTable END_MUT_LIST_info;
extern const StgInfoTable catch_info;
extern const StgInfoTable seq_info;
extern const StgInfoTable dummy_ret_info;
@@ -78,6 +80,7 @@ extern const StgInfoTable ret_bco_info;
/* closures */
extern const StgClosure END_TSO_QUEUE_closure;
+extern const StgClosure END_MUT_LIST_closure;
extern const StgClosure dummy_ret_closure;
extern StgIntCharlikeClosure CHARLIKE_closure[];
diff --git a/ghc/includes/TSO.h b/ghc/includes/TSO.h
index 6167b3195f04..c5f53c4e97d6 100644
--- a/ghc/includes/TSO.h
+++ b/ghc/includes/TSO.h
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: TSO.h,v 1.2 1998/12/02 13:21:43 simonm Exp $
+ * $Id: TSO.h,v 1.3 1999/01/13 17:25:55 simonm Exp $
*
* The definitions for Thread State Objects.
*
@@ -52,7 +52,7 @@ typedef enum {
* even doing 10^6 forks per second would take 35 million years to
* overflow a 64 bit thread ID :-)
*/
-typedef StgNat64 StgThreadID;
+typedef StgNat32 StgThreadID;
/*
* This type is returned to the scheduler by a thread that has
@@ -76,6 +76,7 @@ typedef enum {
typedef struct StgTSO_ {
StgHeader header;
struct StgTSO_* link;
+ StgMutClosure * mut_link; /* TSO's are mutable of course! */
StgTSOWhatNext whatNext;
StgTSOState state; /* necessary? */
StgThreadID id;
diff --git a/ghc/includes/Updates.h b/ghc/includes/Updates.h
index 92097395dd95..3a599c220b8c 100644
--- a/ghc/includes/Updates.h
+++ b/ghc/includes/Updates.h
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: Updates.h,v 1.2 1998/12/02 13:21:47 simonm Exp $
+ * $Id: Updates.h,v 1.3 1999/01/13 17:25:55 simonm Exp $
*
* Definitions related to updates.
*
@@ -8,18 +8,6 @@
#ifndef UPDATES_H
#define UPDATES_H
-/*
- ticky-ticky wants to use permanent indirections when it's doing
- update entry counts.
- */
-
-#ifndef TICKY_TICKY
-# define Ind_info_TO_USE &IND_info
-#else
-# define Ind_info_TO_USE ((AllFlags.doUpdEntryCounts) ? &IND_PERM_info : &IND_info
-)
-#endif
-
/* -----------------------------------------------------------------------------
Update a closure with an indirection. This may also involve waking
up a queue of blocked threads waiting on the result of this
@@ -31,11 +19,16 @@
* (I think the fancy version of the GC is supposed to do this too.)
*/
+/* This expands to a fair chunk of code, what with waking up threads
+ * and checking whether we're updating something in a old generation.
+ * preferably don't use this macro inline in compiled code.
+ */
+
#define UPD_IND(updclosure, heapptr) \
TICK_UPDATED_SET_UPDATED(updclosure); \
AWAKEN_BQ(updclosure); \
- SET_INFO((StgInd*)updclosure,Ind_info_TO_USE); \
- ((StgInd *)updclosure)->indirectee = (StgClosure *)(heapptr)
+ updateWithIndirection((StgClosure *)updclosure, \
+ (StgClosure *)heapptr);
/* -----------------------------------------------------------------------------
Update a closure inplace with an infotable that expects 1 (closure)
@@ -105,11 +98,11 @@ extern const StgPolyInfoTable Upd_frame_info;
- for the parallel system, which can implement updates more
easily if the updatee is always in the heap. (allegedly).
+
+ When debugging, we maintain a separate CAF list so we can tell when
+ a CAF has been garbage collected.
-------------------------------------------------------------------------- */
-EI_(Caf_info);
-EF_(Caf_entry);
-
/* ToDo: only call newCAF when debugging. */
extern void newCAF(StgClosure*);
diff --git a/ghc/rts/BlockAlloc.c b/ghc/rts/BlockAlloc.c
index e0ded8e25255..26f2a60bc509 100644
--- a/ghc/rts/BlockAlloc.c
+++ b/ghc/rts/BlockAlloc.c
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: BlockAlloc.c,v 1.2 1998/12/02 13:28:12 simonm Exp $
+ * $Id: BlockAlloc.c,v 1.3 1999/01/13 17:25:37 simonm Exp $
*
* The block allocator and free list manager.
*
@@ -210,6 +210,14 @@ freeGroup(bdescr *p)
return;
}
+#ifdef DEBUG
+ p->free = (void *)-1; /* indicates that this block is free */
+ p->step = NULL;
+ p->gen = NULL;
+ /* fill the block group with garbage if sanity checking is on */
+ IF_DEBUG(sanity,memset(p->start, 0xaa, p->blocks * BLOCK_SIZE));
+#endif
+
/* find correct place in free list to place new group */
last = NULL;
for (bd = free_list; bd != NULL && bd->start < p->start;
@@ -252,9 +260,6 @@ freeChain(bdescr *bd)
bdescr *next_bd;
while (bd != NULL) {
next_bd = bd->link;
-#ifdef DEBUG
- bd->free = (void *)-1; /* indicates that this block is free */
-#endif
freeGroup(bd);
bd = next_bd;
}
@@ -301,4 +306,16 @@ checkFreeListSanity(void)
}
}
}
+
+nat /* BLOCKS */
+countFreeList(void)
+{
+ bdescr *bd;
+ lnat total_blocks = 0;
+
+ for (bd = free_list; bd != NULL; bd = bd->link) {
+ total_blocks += bd->blocks;
+ }
+ return total_blocks;
+}
#endif
diff --git a/ghc/rts/BlockAlloc.h b/ghc/rts/BlockAlloc.h
index d3e6d53a3469..1ef18d4dc34a 100644
--- a/ghc/rts/BlockAlloc.h
+++ b/ghc/rts/BlockAlloc.h
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: BlockAlloc.h,v 1.2 1998/12/02 13:28:13 simonm Exp $
+ * $Id: BlockAlloc.h,v 1.3 1999/01/13 17:25:38 simonm Exp $
*
* Block Allocator Interface
*
@@ -36,6 +36,7 @@ static inline bdescr *Bdescr(StgPtr p)
#ifdef DEBUG
extern void checkFreeListSanity(void);
+nat countFreeList(void);
#endif
#endif BLOCK_ALLOC_H
diff --git a/ghc/rts/DebugProf.c b/ghc/rts/DebugProf.c
index 662ad41ccca7..7fe57ca91322 100644
--- a/ghc/rts/DebugProf.c
+++ b/ghc/rts/DebugProf.c
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: DebugProf.c,v 1.2 1998/12/02 13:28:14 simonm Exp $
+ * $Id: DebugProf.c,v 1.3 1999/01/13 17:25:38 simonm Exp $
*
* (c) The GHC Team 1998
*
@@ -160,7 +160,6 @@ static char *type_names[] = {
, "MVAR"
, "ARR_WORDS"
- , "ARR_PTRS"
, "MUT_ARR_WORDS"
, "MUT_ARR_PTRS"
@@ -316,10 +315,9 @@ heapCensus(bdescr *bd)
size = arr_words_sizeW(stgCast(StgArrWords*,p));
break;
- case ARR_PTRS:
case MUT_ARR_PTRS:
case MUT_ARR_PTRS_FROZEN:
- size = arr_ptrs_sizeW((StgArrPtrs *)p);
+ size = mut_arr_ptrs_sizeW((StgMutArrPtrs *)p);
break;
case TSO:
diff --git a/ghc/rts/GC.c b/ghc/rts/GC.c
index 23b83a5b5f4a..0a434b150739 100644
--- a/ghc/rts/GC.c
+++ b/ghc/rts/GC.c
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: GC.c,v 1.5 1999/01/06 12:27:47 simonm Exp $
+ * $Id: GC.c,v 1.6 1999/01/13 17:25:39 simonm Exp $
*
* Two-space garbage collector
*
@@ -23,15 +23,9 @@
StgCAF* enteredCAFs;
-static P_ toHp; /* to-space heap pointer */
-static P_ toHpLim; /* end of current to-space block */
-static bdescr *toHp_bd; /* descriptor of current to-space block */
-static nat blocks = 0; /* number of to-space blocks allocated */
-static bdescr *old_to_space = NULL; /* to-space from the last GC */
-static nat old_to_space_blocks = 0; /* size of previous to-space */
-
/* STATIC OBJECT LIST.
*
+ * During GC:
* We maintain a linked list of static objects that are still live.
* The requirements for this list are:
*
@@ -53,20 +47,42 @@ static nat old_to_space_blocks = 0; /* size of previous to-space */
*
* An object is on the list if its static link field is non-zero; this
* means that we have to mark the end of the list with '1', not NULL.
+ *
+ * Extra notes for generational GC:
+ *
+ * Each generation has a static object list associated with it. When
+ * collecting generations up to N, we treat the static object lists
+ * from generations > N as roots.
+ *
+ * We build up a static object list while collecting generations 0..N,
+ * which is then appended to the static object list of generation N+1.
+ */
+StgClosure* static_objects; /* live static objects */
+StgClosure* scavenged_static_objects; /* static objects scavenged so far */
+
+/* N is the oldest generation being collected, where the generations
+ * are numbered starting at 0. A major GC (indicated by the major_gc
+ * flag) is when we're collecting all generations. We only attempt to
+ * deal with static objects and GC CAFs when doing a major GC.
+ */
+static nat N;
+static rtsBool major_gc;
+
+/* Youngest generation that objects should be evacuated to in
+ * evacuate(). (Logically an argument to evacuate, but it's static
+ * a lot of the time so we optimise it into a global variable).
*/
-#define END_OF_STATIC_LIST stgCast(StgClosure*,1)
-static StgClosure* static_objects;
-static StgClosure* scavenged_static_objects;
+static nat evac_gen;
/* WEAK POINTERS
*/
static StgWeak *old_weak_ptr_list; /* also pending finaliser list */
static rtsBool weak_done; /* all done for this pass */
-/* LARGE OBJECTS.
+/* Flag indicating failure to evacuate an object to the desired
+ * generation.
*/
-static bdescr *new_large_objects; /* large objects evacuated so far */
-static bdescr *scavenged_large_objects; /* large objects scavenged */
+static rtsBool failed_to_evac;
/* -----------------------------------------------------------------------------
Static function declarations
@@ -74,13 +90,16 @@ static bdescr *scavenged_large_objects; /* large objects scavenged */
static StgClosure *evacuate(StgClosure *q);
static void zeroStaticObjectList(StgClosure* first_static);
-static void scavenge_stack(StgPtr p, StgPtr stack_end);
-static void scavenge_static(void);
-static void scavenge_large(void);
-static StgPtr scavenge(StgPtr to_scan);
static rtsBool traverse_weak_ptr_list(void);
+static void zeroMutableList(StgMutClosure *first);
static void revertDeadCAFs(void);
+static void scavenge_stack(StgPtr p, StgPtr stack_end);
+static void scavenge_large(step *step);
+static void scavenge(step *step);
+static void scavenge_static(void);
+static StgMutClosure *scavenge_mutable_list(StgMutClosure *p, nat gen);
+
#ifdef DEBUG
static void gcCAFs(void);
#endif
@@ -88,16 +107,33 @@ static void gcCAFs(void);
/* -----------------------------------------------------------------------------
GarbageCollect
- This function performs a full copying garbage collection.
+ For garbage collecting generation N (and all younger generations):
+
+ - follow all pointers in the root set. the root set includes all
+ mutable objects in all steps in all generations.
+
+ - for each pointer, evacuate the object it points to into either
+ + to-space in the next higher step in that generation, if one exists,
+ + if the object's generation == N, then evacuate it to the next
+ generation if one exists, or else to-space in the current
+ generation.
+ + if the object's generation < N, then evacuate it to to-space
+ in the next generation.
+
+ - repeatedly scavenge to-space from each step in each generation
+ being collected until no more objects can be evacuated.
+
+ - free from-space in each step, and set from-space = to-space.
+
-------------------------------------------------------------------------- */
void GarbageCollect(void (*get_roots)(void))
{
- bdescr *bd, *scan_bd, *to_space;
- StgPtr scan;
- lnat allocated, live;
- nat old_nursery_blocks = nursery_blocks; /* for stats */
- nat old_live_blocks = old_to_space_blocks; /* ditto */
+ bdescr *bd;
+ step *step;
+ lnat live, allocated, collected = 0;
+ nat g, s;
+
#ifdef PROFILING
CostCentreStack *prev_CCS;
#endif
@@ -115,8 +151,7 @@ void GarbageCollect(void (*get_roots)(void))
* which case we need to call threadPaused() because the scheduler
* won't have done it.
*/
- if (CurrentTSO)
- threadPaused(CurrentTSO);
+ if (CurrentTSO) { threadPaused(CurrentTSO); }
/* Approximate how much we allocated: number of blocks in the
* nursery + blocks allocated via allocate() - unused nusery blocks.
@@ -127,34 +162,138 @@ void GarbageCollect(void (*get_roots)(void))
for ( bd = current_nursery->link; bd != NULL; bd = bd->link ) {
allocated -= BLOCK_SIZE_W;
}
-
+
+ /* Figure out which generation to collect
+ */
+ for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
+ if (generations[g].steps[0].n_blocks >= generations[g].max_blocks) {
+ N = g;
+ }
+ }
+ major_gc = (N == RtsFlags.GcFlags.generations-1);
+
/* check stack sanity *before* GC (ToDo: check all threads) */
/*IF_DEBUG(sanity, checkTSO(MainTSO,0)); */
IF_DEBUG(sanity, checkFreeListSanity());
+ /* Initialise the static object lists
+ */
static_objects = END_OF_STATIC_LIST;
scavenged_static_objects = END_OF_STATIC_LIST;
- new_large_objects = NULL;
- scavenged_large_objects = NULL;
+ /* zero the mutable list for the oldest generation (see comment by
+ * zeroMutableList below).
+ */
+ if (major_gc) {
+ zeroMutableList(generations[RtsFlags.GcFlags.generations-1].mut_list);
+ }
+
+ /* Initialise to-space in all the generations/steps that we're
+ * collecting.
+ */
+ for (g = 0; g <= N; g++) {
+ generations[g].mut_list = END_MUT_LIST;
+
+ for (s = 0; s < generations[g].n_steps; s++) {
+ /* generation 0, step 0 doesn't need to-space */
+ if (g == 0 && s == 0) { continue; }
+ /* Get a free block for to-space. Extra blocks will be chained on
+ * as necessary.
+ */
+ bd = allocBlock();
+ step = &generations[g].steps[s];
+ ASSERT(step->gen->no == g);
+ ASSERT(step->hp ? Bdescr(step->hp)->step == step : rtsTrue);
+ bd->gen = &generations[g];
+ bd->step = step;
+ bd->link = NULL;
+ bd->evacuated = 1; /* it's a to-space block */
+ step->hp = bd->start;
+ step->hpLim = step->hp + BLOCK_SIZE_W;
+ step->hp_bd = bd;
+ step->to_space = bd;
+ step->to_blocks = 1; /* ???? */
+ step->scan = bd->start;
+ step->scan_bd = bd;
+ step->new_large_objects = NULL;
+ step->scavenged_large_objects = NULL;
+ /* mark the large objects as not evacuated yet */
+ for (bd = step->large_objects; bd; bd = bd->link) {
+ bd->evacuated = 0;
+ }
+ }
+ }
+
+ /* make sure the older generations have at least one block to
+ * allocate into (this makes things easier for copy(), see below.
+ */
+ for (g = N+1; g < RtsFlags.GcFlags.generations; g++) {
+ for (s = 0; s < generations[g].n_steps; s++) {
+ step = &generations[g].steps[s];
+ if (step->hp_bd == NULL) {
+ bd = allocBlock();
+ bd->gen = &generations[g];
+ bd->step = step;
+ bd->link = NULL;
+ bd->evacuated = 0; /* *not* a to-space block */
+ step->hp = bd->start;
+ step->hpLim = step->hp + BLOCK_SIZE_W;
+ step->hp_bd = bd;
+ step->blocks = bd;
+ step->n_blocks = 1;
+ }
+ /* Set the scan pointer for older generations: remember we
+ * still have to scavenge objects that have been promoted. */
+ step->scan = step->hp;
+ step->scan_bd = step->hp_bd;
+ step->to_space = NULL;
+ step->to_blocks = 0;
+ step->new_large_objects = NULL;
+ step->scavenged_large_objects = NULL;
+#ifdef DEBUG
+ /* retain these so we can sanity-check later on */
+ step->old_scan = step->scan;
+ step->old_scan_bd = step->scan_bd;
+#endif
+ }
+ }
- /* Get a free block for to-space. Extra blocks will be chained on
- * as necessary.
+ /* -----------------------------------------------------------------------
+ * follow all the roots that the application knows about.
*/
- bd = allocBlock();
- bd->step = 1; /* step 1 identifies to-space */
- toHp = bd->start;
- toHpLim = toHp + BLOCK_SIZE_W;
- toHp_bd = bd;
- to_space = bd;
- blocks = 0;
-
- scan = toHp;
- scan_bd = bd;
-
- /* follow all the roots that the application knows about */
+ evac_gen = 0;
get_roots();
+ /* follow all the roots that we know about:
+ * - mutable lists from each generation > N
+ * we want to *scavenge* these roots, not evacuate them: they're not
+ * going to move in this GC.
+ * Also: do them in reverse generation order. This is because we
+ * often want to promote objects that are pointed to by older
+ * generations early, so we don't have to repeatedly copy them.
+ * Doing the generations in reverse order ensures that we don't end
+ * up in the situation where we want to evac an object to gen 3 and
+ * it has already been evaced to gen 2.
+ */
+ {
+ StgMutClosure *tmp, **pp;
+ for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
+ /* the act of scavenging the mutable list for this generation
+ * might place more objects on the mutable list itself. So we
+ * place the current mutable list in a temporary, scavenge it,
+ * and then append it to the new list.
+ */
+ tmp = generations[g].mut_list;
+ generations[g].mut_list = END_MUT_LIST;
+ tmp = scavenge_mutable_list(tmp, g);
+
+ pp = &generations[g].mut_list;
+ while (*pp != END_MUT_LIST) {
+ pp = &(*pp)->mut_link;
+ }
+ *pp = tmp;
+ }
+ }
/* And don't forget to mark the TSO if we got here direct from
* Haskell! */
if (CurrentTSO) {
@@ -195,190 +334,225 @@ void GarbageCollect(void (*get_roots)(void))
}
#endif
- /* Then scavenge all the objects we picked up on the first pass.
- * We may require multiple passes to find all the static objects,
- * large objects and normal objects.
+ /* -------------------------------------------------------------------------
+ * Repeatedly scavenge all the areas we know about until there's no
+ * more scavenging to be done.
*/
{
+ rtsBool flag;
loop:
- if (static_objects != END_OF_STATIC_LIST) {
+ flag = rtsFalse;
+
+ /* scavenge static objects */
+ if (major_gc && static_objects != END_OF_STATIC_LIST) {
scavenge_static();
}
- if (toHp_bd != scan_bd || scan < toHp) {
- scan = scavenge(scan);
- scan_bd = Bdescr(scan);
- goto loop;
- }
- if (new_large_objects != NULL) {
- scavenge_large();
- goto loop;
+
+ /* When scavenging the older generations: Objects may have been
+ * evacuated from generations <= N into older generations, and we
+ * need to scavenge these objects. We're going to try to ensure that
+ * any evacuations that occur move the objects into at least the
+ * same generation as the object being scavenged, otherwise we
+ * have to create new entries on the mutable list for the older
+ * generation.
+ */
+
+ /* scavenge each step in generations 0..maxgen */
+ {
+ int gen;
+ for (gen = RtsFlags.GcFlags.generations-1; gen >= 0; gen--) {
+ for (s = 0; s < generations[gen].n_steps; s++) {
+ step = &generations[gen].steps[s];
+ evac_gen = gen;
+ if (step->hp_bd != step->scan_bd || step->scan < step->hp) {
+ scavenge(step);
+ flag = rtsTrue;
+ }
+ if (step->new_large_objects != NULL) {
+ scavenge_large(step);
+ flag = rtsTrue;
+ }
+ }
+ }
}
+ if (flag) { goto loop; }
+
/* must be last... */
if (traverse_weak_ptr_list()) { /* returns rtsTrue if evaced something */
goto loop;
}
}
- /* tidy up the end of the to-space chain */
- toHp_bd->free = toHp;
- toHp_bd->link = NULL;
+ /* run through all the generations/steps and tidy up
+ */
+ for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
+ for (s = 0; s < generations[g].n_steps; s++) {
+ bdescr *next;
+ step = &generations[g].steps[s];
+
+ if (!(g == 0 && s == 0)) {
+ /* Tidy the end of the to-space chains */
+ step->hp_bd->free = step->hp;
+ step->hp_bd->link = NULL;
+ }
+
+ /* for generations we collected... */
+ if (g <= N) {
+
+ generations[g].collections++; /* for stats */
+ collected += step->n_blocks * BLOCK_SIZE_W; /* for stats */
+
+ /* free old memory and shift to-space into from-space for all
+ * the collected steps (except the allocation area). These
+ * freed blocks will probaby be quickly recycled.
+ */
+ if (!(g == 0 && s == 0)) {
+ freeChain(step->blocks);
+ step->blocks = step->to_space;
+ step->n_blocks = step->to_blocks;
+ step->to_space = NULL;
+ step->to_blocks = 0;
+ for (bd = step->blocks; bd != NULL; bd = bd->link) {
+ bd->evacuated = 0; /* now from-space */
+ }
+ }
+
+ /* LARGE OBJECTS. The current live large objects are chained on
+ * scavenged_large, having been moved during garbage
+ * collection from large_objects. Any objects left on
+ * large_objects list are therefore dead, so we free them here.
+ */
+ for (bd = step->large_objects; bd != NULL; bd = next) {
+ next = bd->link;
+ freeGroup(bd);
+ bd = next;
+ }
+ for (bd = step->scavenged_large_objects; bd != NULL; bd = bd->link) {
+ bd->evacuated = 0;
+ }
+ step->large_objects = step->scavenged_large_objects;
+
+ /* Set the maximum blocks for this generation,
+ * using an arbitrary factor of the no. of blocks in step 0.
+ */
+ if (g != 0) {
+ generation *gen = &generations[g];
+ gen->max_blocks =
+ stg_max(gen->steps[s].n_blocks * 2,
+ RtsFlags.GcFlags.minAllocAreaSize * 4);
+ if (gen->max_blocks > RtsFlags.GcFlags.maxHeapSize / 2) {
+ gen->max_blocks = RtsFlags.GcFlags.maxHeapSize / 2;
+ if (((int)gen->max_blocks - (int)gen->steps[0].n_blocks) <
+ (RtsFlags.GcFlags.pcFreeHeap *
+ RtsFlags.GcFlags.maxHeapSize / 200)) {
+ heapOverflow();
+ }
+ }
+ }
+
+ /* for older generations... */
+ } else {
+
+ /* For older generations, we need to append the
+ * scavenged_large_object list (i.e. large objects that have been
+ * promoted during this GC) to the large_object list for that step.
+ */
+ for (bd = step->scavenged_large_objects; bd; bd = next) {
+ next = bd->link;
+ bd->evacuated = 0;
+ dbl_link_onto(bd, &step->large_objects);
+ }
+
+ /* add the new blocks we promoted during this GC */
+ step->n_blocks += step->to_blocks;
+ }
+ }
+ }
/* revert dead CAFs and update enteredCAFs list */
revertDeadCAFs();
/* mark the garbage collected CAFs as dead */
#ifdef DEBUG
- gcCAFs();
+ if (major_gc) { gcCAFs(); }
#endif
- zeroStaticObjectList(scavenged_static_objects);
-
- /* approximate amount of live data (doesn't take into account slop
- * at end of each block). ToDo: this more accurately.
- */
- live = blocks * BLOCK_SIZE_W + ((lnat)toHp_bd->free -
- (lnat)toHp_bd->start) / sizeof(W_);
+ /* zero the scavenged static object list */
+ if (major_gc) {
+ zeroStaticObjectList(scavenged_static_objects);
+ }
- /* Free the to-space from the last GC, as it has now been collected.
- * we may be able to re-use these blocks in creating a new nursery,
- * below. If not, the blocks will probably be re-used for to-space
- * in the next GC.
+ /* Reset the nursery
*/
- if (old_to_space != NULL) {
- freeChain(old_to_space);
+ for (bd = g0s0->blocks; bd; bd = bd->link) {
+ bd->free = bd->start;
+ ASSERT(bd->gen == g0);
+ ASSERT(bd->step == g0s0);
+ }
+ current_nursery = g0s0->blocks;
+
+ live = 0;
+ for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
+ for (s = 0; s < generations[g].n_steps; s++) {
+ /* approximate amount of live data (doesn't take into account slop
+ * at end of each block). ToDo: this more accurately.
+ */
+ if (g == 0 && s == 0) { continue; }
+ step = &generations[g].steps[s];
+ live += step->n_blocks * BLOCK_SIZE_W +
+ ((lnat)step->hp_bd->free -(lnat)step->hp_bd->start) / sizeof(W_);
+ }
}
- old_to_space = to_space;
- old_to_space_blocks = blocks;
/* Free the small objects allocated via allocate(), since this will
- * all have been copied into to-space now.
+ * all have been copied into G0S1 now.
*/
if (small_alloc_list != NULL) {
freeChain(small_alloc_list);
}
small_alloc_list = NULL;
alloc_blocks = 0;
- alloc_blocks_lim = stg_max(blocks,RtsFlags.GcFlags.minAllocAreaSize);
-
- /* LARGE OBJECTS. The current live large objects are chained on
- * scavenged_large_objects, having been moved during garbage
- * collection from large_alloc_list. Any objects left on
- * large_alloc list are therefore dead, so we free them here.
- */
- {
- bdescr *bd, *next;
- bd = large_alloc_list;
- while (bd != NULL) {
- next = bd->link;
- freeGroup(bd);
- bd = next;
- }
- large_alloc_list = scavenged_large_objects;
- }
-
+ alloc_blocks_lim = RtsFlags.GcFlags.minAllocAreaSize;
+ /* start any pending finalisers */
+ scheduleFinalisers(old_weak_ptr_list);
+
/* check sanity after GC */
- IF_DEBUG(sanity, checkHeap(to_space,1));
- /*IF_DEBUG(sanity, checkTSO(MainTSO,1)); */
- IF_DEBUG(sanity, checkFreeListSanity());
-
#ifdef DEBUG
- /* symbol-table based profiling */
- heapCensus(to_space);
-#endif
-
- /* set up a new nursery. Allocate a nursery size based on a
- * function of the amount of live data (currently a factor of 2,
- * should be configurable (ToDo)). Use the blocks from the old
- * nursery if possible, freeing up any left over blocks.
- *
- * If we get near the maximum heap size, then adjust our nursery
- * size accordingly. If the nursery is the same size as the live
- * data (L), then we need 3L bytes. We can reduce the size of the
- * nursery to bring the required memory down near 2L bytes.
- *
- * A normal 2-space collector would need 4L bytes to give the same
- * performance we get from 3L bytes, reducing to the same
- * performance at 2L bytes.
- */
- if ( blocks * 4 > RtsFlags.GcFlags.maxHeapSize ) {
- int adjusted_blocks; /* signed on purpose */
- int pc_free;
-
- adjusted_blocks = (RtsFlags.GcFlags.maxHeapSize - 2 * blocks);
- IF_DEBUG(gc, fprintf(stderr, "Near maximum heap size of 0x%x blocks, blocks = %d, adjusted to %d\n", RtsFlags.GcFlags.maxHeapSize, blocks, adjusted_blocks));
- pc_free = adjusted_blocks * 100 / RtsFlags.GcFlags.maxHeapSize;
- if (pc_free < RtsFlags.GcFlags.pcFreeHeap) /* might even be < 0 */ {
- heapOverflow();
- }
- blocks = adjusted_blocks;
-
- } else {
- blocks *= 2;
- if (blocks < RtsFlags.GcFlags.minAllocAreaSize) {
- blocks = RtsFlags.GcFlags.minAllocAreaSize;
+ for (g = 0; g <= N; g++) {
+ for (s = 0; s < generations[g].n_steps; s++) {
+ if (g == 0 && s == 0) { continue; }
+ IF_DEBUG(sanity, checkHeap(generations[g].steps[s].blocks, NULL));
+ IF_DEBUG(sanity, checkChain(generations[g].steps[s].large_objects));
}
}
-
- if (nursery_blocks < blocks) {
- IF_DEBUG(gc, fprintf(stderr, "Increasing size of nursery to %d blocks\n",
- blocks));
- nursery = allocNursery(nursery,blocks-nursery_blocks);
- } else {
- bdescr *next_bd = nursery;
-
- IF_DEBUG(gc, fprintf(stderr, "Decreasing size of nursery to %d blocks\n",
- blocks));
- for (bd = nursery; nursery_blocks > blocks; nursery_blocks--) {
- next_bd = bd->link;
- freeGroup(bd);
- bd = next_bd;
+ for (g = N+1; g < RtsFlags.GcFlags.generations; g++) {
+ for (s = 0; s < generations[g].n_steps; s++) {
+ IF_DEBUG(sanity, checkHeap(generations[g].steps[s].old_scan_bd,
+ generations[g].steps[s].old_scan));
+ IF_DEBUG(sanity, checkChain(generations[g].steps[s].large_objects));
}
- nursery = bd;
}
-
- current_nursery = nursery;
- nursery_blocks = blocks;
+ IF_DEBUG(sanity, checkFreeListSanity());
+#endif
- /* set the step number for each block in the nursery to zero */
- for (bd = nursery; bd != NULL; bd = bd->link) {
- bd->step = 0;
- bd->free = bd->start;
- }
- for (bd = to_space; bd != NULL; bd = bd->link) {
- bd->step = 0;
- }
- for (bd = large_alloc_list; bd != NULL; bd = bd->link) {
- bd->step = 0;
- }
+ IF_DEBUG(gc, stat_describe_gens());
#ifdef DEBUG
- /* check that we really have the right number of blocks in the
- * nursery, or things could really get screwed up.
- */
- {
- nat i = 0;
- for (bd = nursery; bd != NULL; bd = bd->link) {
- ASSERT(bd->free == bd->start);
- ASSERT(bd->step == 0);
- i++;
- }
- ASSERT(i == nursery_blocks);
- }
+ /* symbol-table based profiling */
+ /* heapCensus(to_space); */ /* ToDo */
#endif
- /* start any pending finalisers */
- scheduleFinalisers(old_weak_ptr_list);
-
/* restore enclosing cost centre */
#ifdef PROFILING
CCCS = prev_CCS;
#endif
+ /* check for memory leaks if sanity checking is on */
+ IF_DEBUG(sanity, memInventory());
+
/* ok, GC over: tell the stats department what happened. */
- stat_endGC(allocated,
- (old_nursery_blocks + old_live_blocks) * BLOCK_SIZE_W,
- live, "");
+ stat_endGC(allocated, collected, live, N);
}
/* -----------------------------------------------------------------------------
@@ -394,6 +568,11 @@ void GarbageCollect(void (*get_roots)(void))
pointer code decide which weak pointers are dead - if there are no
new live weak pointers, then all the currently unreachable ones are
dead.
+
+ For generational GC: we just don't try to finalise weak pointers in
+ older generations than the one we're collecting. This could
+ probably be optimised by keeping per-generation lists of weak
+ pointers, but for a few weak pointers this scheme will work.
-------------------------------------------------------------------------- */
static rtsBool
@@ -406,17 +585,35 @@ traverse_weak_ptr_list(void)
if (weak_done) { return rtsFalse; }
+ /* doesn't matter where we evacuate values/finalisers to, since
+ * these pointers are treated as roots (iff the keys are alive).
+ */
+ evac_gen = 0;
+
last_w = &old_weak_ptr_list;
for (w = old_weak_ptr_list; w; w = next_w) {
target = w->key;
loop:
+ /* ignore weak pointers in older generations */
+ if (!LOOKS_LIKE_STATIC(target) && Bdescr((P_)target)->gen->no > N) {
+ IF_DEBUG(weak, fprintf(stderr,"Weak pointer still alive (in old gen) at %p\n", w));
+ /* remove this weak ptr from the old_weak_ptr list */
+ *last_w = w->link;
+ /* and put it on the new weak ptr list */
+ next_w = w->link;
+ w->link = weak_ptr_list;
+ weak_ptr_list = w;
+ flag = rtsTrue;
+ continue;
+ }
+
info = get_itbl(target);
switch (info->type) {
case IND:
case IND_STATIC:
case IND_PERM:
- case IND_OLDGEN:
+ case IND_OLDGEN: /* rely on compatible layout with StgInd */
case IND_OLDGEN_PERM:
/* follow indirections */
target = ((StgInd *)target)->indirectee;
@@ -463,36 +660,66 @@ traverse_weak_ptr_list(void)
return rtsTrue;
}
-StgClosure *MarkRoot(StgClosure *root)
+StgClosure *
+MarkRoot(StgClosure *root)
{
root = evacuate(root);
return root;
}
-static __inline__ StgClosure *copy(StgClosure *src, W_ size)
+static inline void addBlock(step *step)
+{
+ bdescr *bd = allocBlock();
+ bd->gen = step->gen;
+ bd->step = step;
+
+ if (step->gen->no <= N) {
+ bd->evacuated = 1;
+ } else {
+ bd->evacuated = 0;
+ }
+
+ step->hp_bd->free = step->hp;
+ step->hp_bd->link = bd;
+ step->hp = bd->start;
+ step->hpLim = step->hp + BLOCK_SIZE_W;
+ step->hp_bd = bd;
+ step->to_blocks++;
+}
+
+static __inline__ StgClosure *
+copy(StgClosure *src, W_ size, bdescr *bd)
{
+ step *step;
P_ to, from, dest;
- if (toHp + size >= toHpLim) {
- bdescr *bd = allocBlock();
- toHp_bd->free = toHp;
- toHp_bd->link = bd;
- bd->step = 1; /* step 1 identifies to-space */
- toHp = bd->start;
- toHpLim = toHp + BLOCK_SIZE_W;
- toHp_bd = bd;
- blocks++;
+ /* Find out where we're going, using the handy "to" pointer in
+ * the step of the source object. If it turns out we need to
+ * evacuate to an older generation, adjust it here (see comment
+ * by evacuate()).
+ */
+ step = bd->step->to;
+ if (step->gen->no < evac_gen) {
+ step = &generations[evac_gen].steps[0];
+ }
+
+ /* chain a new block onto the to-space for the destination step if
+ * necessary.
+ */
+ if (step->hp + size >= step->hpLim) {
+ addBlock(step);
}
- dest = toHp;
- toHp += size;
+ dest = step->hp;
+ step->hp += size;
for(to = dest, from = (P_)src; size>0; --size) {
*to++ = *from++;
}
return (StgClosure *)dest;
}
-static __inline__ void upd_evacuee(StgClosure *p, StgClosure *dest)
+static __inline__ void
+upd_evacuee(StgClosure *p, StgClosure *dest)
{
StgEvacuated *q = (StgEvacuated *)p;
@@ -500,54 +727,167 @@ static __inline__ void upd_evacuee(StgClosure *p, StgClosure *dest)
q->evacuee = dest;
}
+/* -----------------------------------------------------------------------------
+ Evacuate a mutable object
+
+ If we evacuate a mutable object to an old generation, cons the
+ object onto the older generation's mutable list.
+ -------------------------------------------------------------------------- */
+
+static inline void
+evacuate_mutable(StgMutClosure *c)
+{
+ bdescr *bd;
+
+ bd = Bdescr((P_)c);
+ if (bd->gen->no > 0) {
+ c->mut_link = bd->gen->mut_list;
+ bd->gen->mut_list = c;
+ }
+}
+
/* -----------------------------------------------------------------------------
Evacuate a large object
This just consists of removing the object from the (doubly-linked)
large_alloc_list, and linking it on to the (singly-linked)
new_large_objects list, from where it will be scavenged later.
+
+ Convention: bd->evacuated is /= 0 for a large object that has been
+ evacuated, or 0 otherwise.
-------------------------------------------------------------------------- */
-static inline void evacuate_large(StgPtr p)
+static inline void
+evacuate_large(StgPtr p, rtsBool mutable)
{
bdescr *bd = Bdescr(p);
+ step *step;
/* should point to the beginning of the block */
ASSERT(((W_)p & BLOCK_MASK) == 0);
/* already evacuated? */
- if (bd->step == 1) {
+ if (bd->evacuated) {
+ /* Don't forget to set the failed_to_evac flag if we didn't get
+ * the desired destination (see comments in evacuate()).
+ */
+ if (bd->gen->no < evac_gen) {
+ failed_to_evac = rtsTrue;
+ }
return;
}
- /* remove from large_alloc_list */
+ step = bd->step;
+ /* remove from large_object list */
if (bd->back) {
bd->back->link = bd->link;
} else { /* first object in the list */
- large_alloc_list = bd->link;
+ step->large_objects = bd->link;
}
if (bd->link) {
bd->link->back = bd->back;
}
- /* link it on to the evacuated large object list */
- bd->link = new_large_objects;
- new_large_objects = bd;
- bd->step = 1;
-}
+ /* link it on to the evacuated large object list of the destination step
+ */
+ step = bd->step->to;
+ if (step->gen->no < evac_gen) {
+ step = &generations[evac_gen].steps[0];
+ }
+
+ bd->step = step;
+ bd->gen = step->gen;
+ bd->link = step->new_large_objects;
+ step->new_large_objects = bd;
+ bd->evacuated = 1;
+
+ if (mutable) {
+ evacuate_mutable((StgMutClosure *)p);
+ }
+}
+
+/* -----------------------------------------------------------------------------
+ Adding a MUT_CONS to an older generation.
+
+ This is necessary from time to time when we end up with an
+ old-to-new generation pointer in a non-mutable object. We defer
+ the promotion until the next GC.
+ -------------------------------------------------------------------------- */
+
+static StgClosure *
+mkMutCons(StgClosure *ptr, generation *gen)
+{
+ StgMutVar *q;
+ step *step;
+
+ step = &gen->steps[0];
+
+ /* chain a new block onto the to-space for the destination step if
+ * necessary.
+ */
+ if (step->hp + sizeofW(StgIndOldGen) >= step->hpLim) {
+ addBlock(step);
+ }
+
+ q = (StgMutVar *)step->hp;
+ step->hp += sizeofW(StgMutVar);
+
+ SET_HDR(q,&MUT_CONS_info,CCS_GC);
+ q->var = ptr;
+ evacuate_mutable((StgMutClosure *)q);
+
+ return (StgClosure *)q;
+}
/* -----------------------------------------------------------------------------
Evacuate
This is called (eventually) for every live object in the system.
+
+ The caller to evacuate specifies a desired generation in the
+ evac_gen global variable. The following conditions apply to
+ evacuating an object which resides in generation M when we're
+ collecting up to generation N
+
+ if M >= evac_gen
+ if M > N do nothing
+ else evac to step->to
+
+ if M < evac_gen evac to evac_gen, step 0
+
+ if the object is already evacuated, then we check which generation
+ it now resides in.
+
+ if M >= evac_gen do nothing
+ if M < evac_gen set failed_to_evac flag to indicate that we
+ didn't manage to evacuate this object into evac_gen.
+
-------------------------------------------------------------------------- */
-static StgClosure *evacuate(StgClosure *q)
+
+static StgClosure *
+evacuate(StgClosure *q)
{
StgClosure *to;
+ bdescr *bd = NULL;
const StgInfoTable *info;
loop:
+ if (!LOOKS_LIKE_STATIC(q)) {
+ bd = Bdescr((P_)q);
+ if (bd->gen->no > N) {
+ /* Can't evacuate this object, because it's in a generation
+ * older than the ones we're collecting. Let's hope that it's
+ * in evac_gen or older, or we will have to make an IND_OLDGEN object.
+ */
+ if (bd->gen->no < evac_gen) {
+ /* nope */
+ failed_to_evac = rtsTrue;
+ }
+ return q;
+ }
+ }
+
/* make sure the info pointer is into text space */
ASSERT(q && (LOOKS_LIKE_GHC_INFO(GET_INFO(q))
|| IS_HUGS_CONSTR_INFO(GET_INFO(q))));
@@ -556,10 +896,17 @@ loop:
switch (info -> type) {
case BCO:
- to = copy(q,bco_sizeW(stgCast(StgBCO*,q)));
+ to = copy(q,bco_sizeW(stgCast(StgBCO*,q)),bd);
upd_evacuee(q,to);
return to;
+ case MUT_VAR:
+ case MVAR:
+ to = copy(q,sizeW_fromITBL(info),bd);
+ upd_evacuee(q,to);
+ evacuate_mutable((StgMutClosure *)to);
+ return to;
+
case FUN:
case THUNK:
case CONSTR:
@@ -569,22 +916,20 @@ loop:
case CAF_ENTERED:
case WEAK:
case FOREIGN:
- case MUT_VAR:
- case MVAR:
- to = copy(q,sizeW_fromITBL(info));
+ to = copy(q,sizeW_fromITBL(info),bd);
upd_evacuee(q,to);
return to;
case CAF_BLACKHOLE:
case BLACKHOLE:
- to = copy(q,BLACKHOLE_sizeW());
+ to = copy(q,BLACKHOLE_sizeW(),bd);
upd_evacuee(q,to);
return to;
case THUNK_SELECTOR:
{
const StgInfoTable* selectee_info;
- StgClosure* selectee = stgCast(StgSelector*,q)->selectee;
+ StgClosure* selectee = ((StgSelector*)q)->selectee;
selector_loop:
selectee_info = get_itbl(selectee);
@@ -606,7 +951,7 @@ loop:
* with the evacuation, just update the source address with
* a pointer to the (evacuated) constructor field.
*/
- if (IS_USER_PTR(q) && Bdescr((P_)q)->step == 1) {
+ if (IS_USER_PTR(q) && Bdescr((P_)q)->evacuated) {
return q;
}
@@ -646,19 +991,28 @@ loop:
barf("evacuate: THUNK_SELECTOR: strange selectee");
}
}
- to = copy(q,THUNK_SELECTOR_sizeW());
+ to = copy(q,THUNK_SELECTOR_sizeW(),bd);
upd_evacuee(q,to);
return to;
case IND:
case IND_OLDGEN:
/* follow chains of indirections, don't evacuate them */
- q = stgCast(StgInd*,q)->indirectee;
+ q = ((StgInd*)q)->indirectee;
goto loop;
- case CONSTR_STATIC:
+ /* ToDo: optimise STATIC_LINK for known cases.
+ - FUN_STATIC : payload[0]
+ - THUNK_STATIC : payload[1]
+ - IND_STATIC : payload[1]
+ */
case THUNK_STATIC:
case FUN_STATIC:
+ if (info->srt_len == 0) { /* small optimisation */
+ return q;
+ }
+ /* fall through */
+ case CONSTR_STATIC:
case IND_STATIC:
/* don't want to evacuate these, but we do want to follow pointers
* from SRTs - see scavenge_static.
@@ -666,7 +1020,7 @@ loop:
/* put the object on the static list, if necessary.
*/
- if (STATIC_LINK(info,(StgClosure *)q) == NULL) {
+ if (major_gc && STATIC_LINK(info,(StgClosure *)q) == NULL) {
STATIC_LINK(info,(StgClosure *)q) = static_objects;
static_objects = (StgClosure *)q;
}
@@ -697,33 +1051,62 @@ loop:
case PAP:
/* these are special - the payload is a copy of a chunk of stack,
tagging and all. */
- to = copy(q,pap_sizeW(stgCast(StgPAP*,q)));
+ to = copy(q,pap_sizeW(stgCast(StgPAP*,q)),bd);
upd_evacuee(q,to);
return to;
case EVACUATED:
- /* Already evacuated, just return the forwarding address */
- return stgCast(StgEvacuated*,q)->evacuee;
+ /* Already evacuated, just return the forwarding address.
+ * HOWEVER: if the requested destination generation (evac_gen) is
+ * older than the actual generation (because the object was
+ * already evacuated to a younger generation) then we have to
+ * set the failed_to_evac flag to indicate that we couldn't
+ * manage to promote the object to the desired generation.
+ */
+ if (evac_gen > 0) { /* optimisation */
+ StgClosure *p = ((StgEvacuated*)q)->evacuee;
+ if (Bdescr((P_)p)->gen->no < evac_gen) {
+ /* fprintf(stderr,"evac failed!\n");*/
+ failed_to_evac = rtsTrue;
+ }
+ }
+ return ((StgEvacuated*)q)->evacuee;
case MUT_ARR_WORDS:
case ARR_WORDS:
- case MUT_ARR_PTRS:
- case MUT_ARR_PTRS_FROZEN:
- case ARR_PTRS:
{
nat size = arr_words_sizeW(stgCast(StgArrWords*,q));
if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
- evacuate_large((P_)q);
+ evacuate_large((P_)q, rtsFalse);
return q;
} else {
/* just copy the block */
- to = copy(q,size);
+ to = copy(q,size,bd);
upd_evacuee(q,to);
return to;
}
}
+ case MUT_ARR_PTRS:
+ case MUT_ARR_PTRS_FROZEN:
+ {
+ nat size = mut_arr_ptrs_sizeW(stgCast(StgMutArrPtrs*,q));
+
+ if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
+ evacuate_large((P_)q, info->type == MUT_ARR_PTRS);
+ to = q;
+ } else {
+ /* just copy the block */
+ to = copy(q,size,bd);
+ upd_evacuee(q,to);
+ if (info->type == MUT_ARR_PTRS) {
+ evacuate_mutable((StgMutClosure *)to);
+ }
+ }
+ return to;
+ }
+
case TSO:
{
StgTSO *tso = stgCast(StgTSO *,q);
@@ -733,14 +1116,15 @@ loop:
/* Large TSOs don't get moved, so no relocation is required.
*/
if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
- evacuate_large((P_)q);
+ evacuate_large((P_)q, rtsFalse);
+ tso->mut_link = NULL; /* see below */
return q;
/* To evacuate a small TSO, we need to relocate the update frame
* list it contains.
*/
} else {
- StgTSO *new_tso = (StgTSO *)copy((StgClosure *)tso,tso_sizeW(tso));
+ StgTSO *new_tso = (StgTSO *)copy((StgClosure *)tso,tso_sizeW(tso),bd);
diff = (StgPtr)new_tso - (StgPtr)tso; /* In *words* */
@@ -751,6 +1135,15 @@ loop:
relocate_TSO(tso, new_tso);
upd_evacuee(q,(StgClosure *)new_tso);
+
+ /* don't evac_mutable - these things are marked mutable as
+ * required. We *do* need to zero the mut_link field, though:
+ * this TSO might have been on the mutable list for this
+ * generation, but we're collecting this generation anyway so
+ * we didn't follow the mutable list.
+ */
+ new_tso->mut_link = NULL;
+
return (StgClosure *)new_tso;
}
}
@@ -820,7 +1213,7 @@ relocate_TSO(StgTSO *src, StgTSO *dest)
}
static inline void
-evacuate_srt(const StgInfoTable *info)
+scavenge_srt(const StgInfoTable *info)
{
StgClosure **srt, **srt_end;
@@ -835,29 +1228,48 @@ evacuate_srt(const StgInfoTable *info)
}
}
-static StgPtr
-scavenge(StgPtr to_scan)
+/* -----------------------------------------------------------------------------
+ Scavenge a given step until there are no more objects in this step
+ to scavenge.
+
+ evac_gen is set by the caller to be either zero (for a step in a
+ generation < N) or G where G is the generation of the step being
+ scavenged.
+
+ We sometimes temporarily change evac_gen back to zero if we're
+ scavenging a mutable object where early promotion isn't such a good
+ idea.
+ -------------------------------------------------------------------------- */
+
+
+static void
+scavenge(step *step)
{
- StgPtr p;
+ StgPtr p, q;
const StgInfoTable *info;
bdescr *bd;
+ nat saved_evac_gen = evac_gen; /* used for temporarily changing evac_gen */
+
+ p = step->scan;
+ bd = step->scan_bd;
- p = to_scan;
- bd = Bdescr((P_)p);
+ failed_to_evac = rtsFalse;
/* scavenge phase - standard breadth-first scavenging of the
* evacuated objects
*/
- while (bd != toHp_bd || p < toHp) {
+ while (bd != step->hp_bd || p < step->hp) {
/* If we're at the end of this block, move on to the next block */
- if (bd != toHp_bd && p == bd->free) {
+ if (bd != step->hp_bd && p == bd->free) {
bd = bd->link;
p = bd->start;
continue;
}
+ q = p; /* save ptr to object */
+
ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO((StgClosure *)p))
|| IS_HUGS_CONSTR_INFO(GET_INFO((StgClosure *)p))));
@@ -872,19 +1284,32 @@ scavenge(StgPtr to_scan)
bcoConstCPtr(bco,i) = evacuate(bcoConstCPtr(bco,i));
}
p += bco_sizeW(bco);
- continue;
+ break;
+ }
+
+ case MVAR:
+ /* treat MVars specially, because we don't want to evacuate the
+ * mut_link field in the middle of the closure.
+ */
+ {
+ StgMVar *mvar = ((StgMVar *)p);
+ evac_gen = 0;
+ (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
+ (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
+ (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
+ p += sizeofW(StgMVar);
+ evac_gen = saved_evac_gen;
+ break;
}
case FUN:
case THUNK:
- evacuate_srt(info);
+ scavenge_srt(info);
/* fall through */
case CONSTR:
case WEAK:
case FOREIGN:
- case MVAR:
- case MUT_VAR:
case IND_PERM:
case IND_OLDGEN_PERM:
case CAF_UNENTERED:
@@ -897,9 +1322,19 @@ scavenge(StgPtr to_scan)
(StgClosure *)*p = evacuate((StgClosure *)*p);
}
p += info->layout.payload.nptrs;
- continue;
+ break;
}
+ case MUT_VAR:
+ /* ignore MUT_CONSs */
+ if (((StgMutVar *)p)->header.info != &MUT_CONS_info) {
+ evac_gen = 0;
+ ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
+ evac_gen = saved_evac_gen;
+ }
+ p += sizeofW(StgMutVar);
+ break;
+
case CAF_BLACKHOLE:
case BLACKHOLE:
{
@@ -907,7 +1342,7 @@ scavenge(StgPtr to_scan)
(StgClosure *)bh->blocking_queue =
evacuate((StgClosure *)bh->blocking_queue);
p += BLACKHOLE_sizeW();
- continue;
+ break;
}
case THUNK_SELECTOR:
@@ -915,7 +1350,7 @@ scavenge(StgPtr to_scan)
StgSelector *s = (StgSelector *)p;
s->selectee = evacuate(s->selectee);
p += THUNK_SELECTOR_sizeW();
- continue;
+ break;
}
case IND:
@@ -956,27 +1391,44 @@ scavenge(StgPtr to_scan)
pap->fun = evacuate(pap->fun);
scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
p += pap_sizeW(pap);
- continue;
+ break;
}
case ARR_WORDS:
case MUT_ARR_WORDS:
/* nothing to follow */
p += arr_words_sizeW(stgCast(StgArrWords*,p));
- continue;
+ break;
- case ARR_PTRS:
case MUT_ARR_PTRS:
- case MUT_ARR_PTRS_FROZEN:
/* follow everything */
{
StgPtr next;
- next = p + arr_ptrs_sizeW(stgCast(StgArrPtrs*,p));
- for (p = (P_)((StgArrPtrs *)p)->payload; p < next; p++) {
+ evac_gen = 0; /* repeatedly mutable */
+ next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
+ for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
(StgClosure *)*p = evacuate((StgClosure *)*p);
}
- continue;
+ evac_gen = saved_evac_gen;
+ break;
+ }
+
+ case MUT_ARR_PTRS_FROZEN:
+ /* follow everything */
+ {
+ StgPtr start = p, next;
+
+ next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
+ for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
+ (StgClosure *)*p = evacuate((StgClosure *)*p);
+ }
+ if (failed_to_evac) {
+ /* we can do this easier... */
+ evacuate_mutable((StgMutClosure *)start);
+ failed_to_evac = rtsFalse;
+ }
+ break;
}
case TSO:
@@ -984,12 +1436,14 @@ scavenge(StgPtr to_scan)
StgTSO *tso;
tso = (StgTSO *)p;
+ evac_gen = 0;
/* chase the link field for any TSOs on the same queue */
(StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
/* scavenge this thread's stack */
scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
+ evac_gen = saved_evac_gen;
p += tso_sizeW(tso);
- continue;
+ break;
}
case BLOCKED_FETCH:
@@ -1000,12 +1454,253 @@ scavenge(StgPtr to_scan)
default:
barf("scavenge");
}
+
+ /* If we didn't manage to promote all the objects pointed to by
+ * the current object, then we have to designate this object as
+ * mutable (because it contains old-to-new generation pointers).
+ */
+ if (failed_to_evac) {
+ mkMutCons((StgClosure *)q, &generations[evac_gen]);
+ failed_to_evac = rtsFalse;
+ }
}
- return (P_)p;
+
+ step->scan_bd = bd;
+ step->scan = p;
}
-/* scavenge_static is the scavenge code for a static closure.
- */
+/* -----------------------------------------------------------------------------
+ Scavenge one object.
+
+ This is used for objects that are temporarily marked as mutable
+ because they contain old-to-new generation pointers. Only certain
+ objects can have this property.
+ -------------------------------------------------------------------------- */
+static rtsBool
+scavenge_one(StgPtr p)
+{
+ StgInfoTable *info;
+ rtsBool no_luck;
+
+ ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO((StgClosure *)p))
+ || IS_HUGS_CONSTR_INFO(GET_INFO((StgClosure *)p))));
+
+ info = get_itbl((StgClosure *)p);
+
+ switch (info -> type) {
+
+ case FUN:
+ case THUNK:
+ case CONSTR:
+ case WEAK:
+ case FOREIGN:
+ case IND_PERM:
+ case IND_OLDGEN_PERM:
+ case CAF_UNENTERED:
+ case CAF_ENTERED:
+ {
+ StgPtr end;
+
+ end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
+ for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
+ (StgClosure *)*p = evacuate((StgClosure *)*p);
+ }
+ break;
+ }
+
+ case CAF_BLACKHOLE:
+ case BLACKHOLE:
+ {
+ StgBlackHole *bh = (StgBlackHole *)p;
+ (StgClosure *)bh->blocking_queue =
+ evacuate((StgClosure *)bh->blocking_queue);
+ break;
+ }
+
+ case THUNK_SELECTOR:
+ {
+ StgSelector *s = (StgSelector *)p;
+ s->selectee = evacuate(s->selectee);
+ break;
+ }
+
+ case AP_UPD: /* same as PAPs */
+ case PAP:
+ /* Treat a PAP just like a section of stack, not forgetting to
+ * evacuate the function pointer too...
+ */
+ {
+ StgPAP* pap = stgCast(StgPAP*,p);
+
+ pap->fun = evacuate(pap->fun);
+ scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
+ break;
+ }
+
+ case IND_OLDGEN:
+ /* This might happen if for instance a MUT_CONS was pointing to a
+ * THUNK which has since been updated. The IND_OLDGEN will
+ * be on the mutable list anyway, so we don't need to do anything
+ * here.
+ */
+ break;
+
+ default:
+ barf("scavenge_one: strange object");
+ }
+
+ no_luck = failed_to_evac;
+ failed_to_evac = rtsFalse;
+ return (no_luck);
+}
+
+
+/* -----------------------------------------------------------------------------
+ Scavenging mutable lists.
+
+ We treat the mutable list of each generation > N (i.e. all the
+ generations older than the one being collected) as roots. We also
+ remove non-mutable objects from the mutable list at this point.
+ -------------------------------------------------------------------------- */
+
+static StgMutClosure *
+scavenge_mutable_list(StgMutClosure *p, nat gen)
+{
+ StgInfoTable *info;
+ StgMutClosure *start;
+ StgMutClosure **prev;
+
+ evac_gen = 0;
+
+ prev = &start;
+ start = p;
+
+ failed_to_evac = rtsFalse;
+
+ for (; p != END_MUT_LIST; p = *prev) {
+
+ /* make sure the info pointer is into text space */
+ ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
+ || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
+
+ info = get_itbl(p);
+ switch(info->type) {
+
+ case MUT_ARR_PTRS_FROZEN:
+ /* remove this guy from the mutable list, but follow the ptrs
+ * anyway (and make sure they get promoted to this gen).
+ */
+ {
+ StgPtr end, q;
+
+ end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
+ evac_gen = gen;
+ for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
+ (StgClosure *)*q = evacuate((StgClosure *)*q);
+ }
+ evac_gen = 0;
+
+ if (failed_to_evac) {
+ failed_to_evac = rtsFalse;
+ prev = &p->mut_link;
+ } else {
+ *prev = p->mut_link;
+ }
+ continue;
+ }
+
+ case MUT_ARR_PTRS:
+ /* follow everything */
+ prev = &p->mut_link;
+ {
+ StgPtr end, q;
+
+ end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
+ for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
+ (StgClosure *)*q = evacuate((StgClosure *)*q);
+ }
+ continue;
+ }
+
+ case MUT_VAR:
+ /* MUT_CONS is a kind of MUT_VAR, except that we try to remove
+ * it from the mutable list if possible by promoting whatever it
+ * points to.
+ */
+ if (p->header.info == &MUT_CONS_info) {
+ evac_gen = gen;
+ if (scavenge_one((P_)((StgMutVar *)p)->var) == rtsTrue) {
+ /* didn't manage to promote everything, so leave the
+ * MUT_CONS on the list.
+ */
+ prev = &p->mut_link;
+ } else {
+ *prev = p->mut_link;
+ }
+ evac_gen = 0;
+ } else {
+ ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
+ prev = &p->mut_link;
+ }
+ continue;
+
+ case TSO:
+ /* follow ptrs and remove this from the mutable list */
+ {
+ StgTSO *tso = (StgTSO *)p;
+
+ /* Don't bother scavenging if this thread is dead
+ */
+ if (!(tso->whatNext == ThreadComplete ||
+ tso->whatNext == ThreadKilled)) {
+ /* Don't need to chase the link field for any TSOs on the
+ * same queue. Just scavenge this thread's stack
+ */
+ scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
+ }
+
+ /* Don't take this TSO off the mutable list - it might still
+ * point to some younger objects (because we set evac_gen to 0
+ * above).
+ */
+ prev = &tso->mut_link;
+ continue;
+ }
+
+ case IND_OLDGEN:
+ case IND_OLDGEN_PERM:
+ case IND_STATIC:
+ /* Try to pull the indirectee into this generation, so we can
+ * remove the indirection from the mutable list.
+ */
+ evac_gen = gen;
+ ((StgIndOldGen *)p)->indirectee =
+ evacuate(((StgIndOldGen *)p)->indirectee);
+ evac_gen = 0;
+
+ if (failed_to_evac) {
+ failed_to_evac = rtsFalse;
+ prev = &p->mut_link;
+ } else {
+ *prev = p->mut_link;
+ /* the mut_link field of an IND_STATIC is overloaded as the
+ * static link field too (it just so happens that we don't need
+ * both at the same time), so we need to NULL it out when
+ * removing this object from the mutable list because the static
+ * link fields are all assumed to be NULL before doing a major
+ * collection.
+ */
+ p->mut_link = NULL;
+ }
+ continue;
+
+ default:
+ /* shouldn't have anything else on the mutables list */
+ barf("scavenge_mutable_object: non-mutable object?");
+ }
+ }
+ return start;
+}
static void
scavenge_static(void)
@@ -1013,26 +1708,29 @@ scavenge_static(void)
StgClosure* p = static_objects;
const StgInfoTable *info;
+ /* Always evacuate straight to the oldest generation for static
+ * objects */
+ evac_gen = oldest_gen->no;
+
/* keep going until we've scavenged all the objects on the linked
list... */
while (p != END_OF_STATIC_LIST) {
+ info = get_itbl(p);
+
/* make sure the info pointer is into text space */
- ASSERT(p && LOOKS_LIKE_GHC_INFO(GET_INFO(p)));
ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
|| IS_HUGS_CONSTR_INFO(GET_INFO(p))));
-
- info = get_itbl(p);
-
+
/* Take this object *off* the static_objects list,
* and put it on the scavenged_static_objects list.
*/
static_objects = STATIC_LINK(info,p);
STATIC_LINK(info,p) = scavenged_static_objects;
scavenged_static_objects = p;
-
+
switch (info -> type) {
-
+
case IND_STATIC:
{
StgInd *ind = (StgInd *)p;
@@ -1042,9 +1740,9 @@ scavenge_static(void)
case THUNK_STATIC:
case FUN_STATIC:
- evacuate_srt(info);
+ scavenge_srt(info);
/* fall through */
-
+
case CONSTR_STATIC:
{
StgPtr q, next;
@@ -1145,21 +1843,22 @@ scavenge_stack(StgPtr p, StgPtr stack_end)
StgClosure *to;
StgClosureType type = get_itbl(frame->updatee)->type;
+ p += sizeofW(StgUpdateFrame);
if (type == EVACUATED) {
frame->updatee = evacuate(frame->updatee);
- p += sizeofW(StgUpdateFrame);
continue;
} else {
+ bdescr *bd = Bdescr((P_)frame->updatee);
ASSERT(type == BLACKHOLE || type == CAF_BLACKHOLE);
- to = copy(frame->updatee, BLACKHOLE_sizeW());
+ if (bd->gen->no >= evac_gen && bd->gen->no > N) { continue; }
+ to = copy(frame->updatee, BLACKHOLE_sizeW(), bd);
upd_evacuee(frame->updatee,to);
frame->updatee = to;
- p += sizeofW(StgUpdateFrame);
continue;
}
}
- /* small bitmap (< 32 entries) */
+ /* small bitmap (< 32 entries, or 64 on a 64-bit machine) */
case RET_BCO:
case RET_SMALL:
case RET_VEC_SMALL:
@@ -1178,7 +1877,7 @@ scavenge_stack(StgPtr p, StgPtr stack_end)
}
follow_srt:
- evacuate_srt(info);
+ scavenge_srt(info);
continue;
/* large bitmap (> 32 entries) */
@@ -1222,32 +1921,33 @@ scavenge_stack(StgPtr p, StgPtr stack_end)
/*-----------------------------------------------------------------------------
scavenge the large object list.
+
+ evac_gen set by caller; similar games played with evac_gen as with
+ scavenge() - see comment at the top of scavenge(). Most large
+ objects are (repeatedly) mutable, so most of the time evac_gen will
+ be zero.
--------------------------------------------------------------------------- */
static void
-scavenge_large(void)
+scavenge_large(step *step)
{
bdescr *bd;
StgPtr p;
const StgInfoTable* info;
+ nat saved_evac_gen = evac_gen; /* used for temporarily changing evac_gen */
- bd = new_large_objects;
+ evac_gen = 0; /* most objects are mutable */
+ bd = step->new_large_objects;
- for (; bd != NULL; bd = new_large_objects) {
+ for (; bd != NULL; bd = step->new_large_objects) {
/* take this object *off* the large objects list and put it on
* the scavenged large objects list. This is so that we can
* treat new_large_objects as a stack and push new objects on
* the front when evacuating.
*/
- new_large_objects = bd->link;
- /* scavenged_large_objects is doubly linked */
- bd->link = scavenged_large_objects;
- bd->back = NULL;
- if (scavenged_large_objects) {
- scavenged_large_objects->back = bd;
- }
- scavenged_large_objects = bd;
+ step->new_large_objects = bd->link;
+ dbl_link_onto(bd, &step->scavenged_large_objects);
p = bd->start;
info = get_itbl(stgCast(StgClosure*,p));
@@ -1261,27 +1961,44 @@ scavenge_large(void)
/* nothing to follow */
continue;
- case ARR_PTRS:
case MUT_ARR_PTRS:
- case MUT_ARR_PTRS_FROZEN:
/* follow everything */
{
StgPtr next;
- next = p + arr_ptrs_sizeW(stgCast(StgArrPtrs*,p));
- for (p = (P_)((StgArrPtrs *)p)->payload; p < next; p++) {
+ next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
+ for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
(StgClosure *)*p = evacuate((StgClosure *)*p);
}
continue;
}
+ case MUT_ARR_PTRS_FROZEN:
+ /* follow everything */
+ {
+ StgPtr start = p, next;
+
+ evac_gen = saved_evac_gen; /* not really mutable */
+ next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
+ for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
+ (StgClosure *)*p = evacuate((StgClosure *)*p);
+ }
+ evac_gen = 0;
+ if (failed_to_evac) {
+ evacuate_mutable((StgMutClosure *)start);
+ }
+ continue;
+ }
+
case BCO:
{
StgBCO* bco = stgCast(StgBCO*,p);
nat i;
+ evac_gen = saved_evac_gen;
for (i = 0; i < bco->n_ptrs; i++) {
bcoConstCPtr(bco,i) = evacuate(bcoConstCPtr(bco,i));
}
+ evac_gen = 0;
continue;
}
@@ -1302,6 +2019,7 @@ scavenge_large(void)
}
}
}
+
static void
zeroStaticObjectList(StgClosure* first_static)
{
@@ -1316,23 +2034,40 @@ zeroStaticObjectList(StgClosure* first_static)
}
}
+/* This function is only needed because we share the mutable link
+ * field with the static link field in an IND_STATIC, so we have to
+ * zero the mut_link field before doing a major GC, which needs the
+ * static link field.
+ *
+ * It doesn't do any harm to zero all the mutable link fields on the
+ * mutable list.
+ */
+static void
+zeroMutableList(StgMutClosure *first)
+{
+ StgMutClosure *next, *c;
+
+ for (c = first; c != END_MUT_LIST; c = next) {
+ next = c->mut_link;
+ c->mut_link = NULL;
+ }
+}
+
/* -----------------------------------------------------------------------------
Reverting CAFs
-
-------------------------------------------------------------------------- */
void RevertCAFs(void)
{
- while (enteredCAFs != END_CAF_LIST) {
- StgCAF* caf = enteredCAFs;
- const StgInfoTable *info = get_itbl(caf);
-
- enteredCAFs = caf->link;
- ASSERT(get_itbl(caf)->type == CAF_ENTERED);
- SET_INFO(caf,&CAF_UNENTERED_info);
- caf->value = stgCast(StgClosure*,0xdeadbeef);
- caf->link = stgCast(StgCAF*,0xdeadbeef);
- }
+ while (enteredCAFs != END_CAF_LIST) {
+ StgCAF* caf = enteredCAFs;
+
+ enteredCAFs = caf->link;
+ ASSERT(get_itbl(caf)->type == CAF_ENTERED);
+ SET_INFO(caf,&CAF_UNENTERED_info);
+ caf->value = stgCast(StgClosure*,0xdeadbeef);
+ caf->link = stgCast(StgCAF*,0xdeadbeef);
+ }
}
void revertDeadCAFs(void)
@@ -1455,7 +2190,7 @@ threadLazyBlackHole(StgTSO *tso)
if (bh->header.info != &BLACKHOLE_info
&& bh->header.info != &CAF_BLACKHOLE_info) {
SET_INFO(bh,&BLACKHOLE_info);
- bh->blocking_queue = stgCast(StgTSO*,&END_TSO_QUEUE_closure);
+ bh->blocking_queue = END_TSO_QUEUE;
}
update_frame = update_frame->link;
@@ -1619,7 +2354,7 @@ threadSqueezeStack(StgTSO *tso)
&& bh->header.info != &CAF_BLACKHOLE_info
) {
SET_INFO(bh,&BLACKHOLE_info);
- bh->blocking_queue = stgCast(StgTSO*,&END_TSO_QUEUE_closure);
+ bh->blocking_queue = END_TSO_QUEUE;
}
}
diff --git a/ghc/rts/MBlock.c b/ghc/rts/MBlock.c
index 61bbbf7f9be2..3c5225fe8a64 100644
--- a/ghc/rts/MBlock.c
+++ b/ghc/rts/MBlock.c
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: MBlock.c,v 1.2 1998/12/02 13:28:28 simonm Exp $
+ * $Id: MBlock.c,v 1.3 1999/01/13 17:25:40 simonm Exp $
*
* MegaBlock Allocator Interface. This file contains all the dirty
* architecture-dependent hackery required to get a chunk of aligned
@@ -62,6 +62,8 @@
/* ToDo: memory locations on other architectures */
#endif
+lnat mblocks_allocated = 0;
+
void *
getMBlock(void)
{
@@ -134,5 +136,7 @@ getMBlocks(nat n)
next_request += size;
+ mblocks_allocated += n;
+
return ret;
}
diff --git a/ghc/rts/MBlock.h b/ghc/rts/MBlock.h
index 094c4fe393db..0fb902e7342c 100644
--- a/ghc/rts/MBlock.h
+++ b/ghc/rts/MBlock.h
@@ -1,9 +1,11 @@
/* -----------------------------------------------------------------------------
- * $Id: MBlock.h,v 1.2 1998/12/02 13:28:30 simonm Exp $
+ * $Id: MBlock.h,v 1.3 1999/01/13 17:25:41 simonm Exp $
*
* MegaBlock Allocator interface.
*
* ---------------------------------------------------------------------------*/
+extern lnat mblocks_allocated;
+
extern void * getMBlock(void);
extern void * getMBlocks(nat n);
diff --git a/ghc/rts/Makefile b/ghc/rts/Makefile
index 83bc74426d69..a1b7711b00c3 100644
--- a/ghc/rts/Makefile
+++ b/ghc/rts/Makefile
@@ -1,5 +1,5 @@
#-----------------------------------------------------------------------------
-# $Id: Makefile,v 1.2 1998/12/02 13:28:32 simonm Exp $
+# $Id: Makefile,v 1.3 1999/01/13 17:25:41 simonm Exp $
# This is the Makefile for the runtime-system stuff.
# This stuff is written in C (and cannot be written in Haskell).
diff --git a/ghc/rts/PrimOps.hc b/ghc/rts/PrimOps.hc
index 0d16ae613dbf..9c7eb6f81839 100644
--- a/ghc/rts/PrimOps.hc
+++ b/ghc/rts/PrimOps.hc
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: PrimOps.hc,v 1.2 1998/12/02 13:28:32 simonm Exp $
+ * $Id: PrimOps.hc,v 1.3 1999/01/13 17:25:41 simonm Exp $
*
* Primitive functions / data
*
@@ -213,21 +213,21 @@ newByteArray(StablePtr, sizeof(StgStablePtr));
FN_(newArrayZh_fast)
{
W_ size, n, init;
- StgArrPtrs* arr;
+ StgMutArrPtrs* arr;
StgPtr p;
FB_
n = R1.w;
MAYBE_GC(R2_PTR,newArrayZh_fast);
- size = sizeofW(StgArrPtrs) + n;
- arr = (StgArrPtrs *)allocate(size);
+ size = sizeofW(StgMutArrPtrs) + n;
+ arr = (StgMutArrPtrs *)allocate(size);
SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS);
arr->ptrs = n;
init = R2.w;
- for (p = (P_)arr + sizeofW(StgArrPtrs);
+ for (p = (P_)arr + sizeofW(StgMutArrPtrs);
p < (P_)arr + size; p++) {
*p = (W_)init;
}
diff --git a/ghc/rts/RtsFlags.c b/ghc/rts/RtsFlags.c
index 530ff9f099d0..19c522eabd01 100644
--- a/ghc/rts/RtsFlags.c
+++ b/ghc/rts/RtsFlags.c
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: RtsFlags.c,v 1.2 1998/12/02 13:28:39 simonm Exp $
+ * $Id: RtsFlags.c,v 1.3 1999/01/13 17:25:42 simonm Exp $
*
* Functions for parsing the argument list.
*
@@ -64,8 +64,8 @@ void initRtsFlagsDefaults(void)
RtsFlags.GcFlags.minAllocAreaSize = (256 * 1024) / BLOCK_SIZE;
RtsFlags.GcFlags.maxHeapSize = (64 * 1024 * 1024) / BLOCK_SIZE;
RtsFlags.GcFlags.pcFreeHeap = 3; /* 3% */
+ RtsFlags.GcFlags.generations = 2;
- RtsFlags.GcFlags.force2s = rtsFalse;
RtsFlags.GcFlags.forceGC = rtsFalse;
RtsFlags.GcFlags.forcingInterval = 5000000; /* 5MB (or words?) */
RtsFlags.GcFlags.ringBell = rtsFalse;
@@ -213,6 +213,7 @@ usage_text[] = {
" -A<size> Sets the minimum allocation area size (default 256k) Egs: -A1m -A10k",
" -M<size> Sets the maximum heap size (default 64M) Egs: -H256k -H1G",
" -m<n>% Minimum % of heap which must be available (default 3%)",
+" -G<n> Number of generations (default: 2)",
" -s<file> Summary GC statistics (default file: <program>.stat)",
" -S<file> Detailed GC statistics (with -Sstderr going to stderr)",
"",
@@ -435,14 +436,6 @@ error = rtsTrue;
break;
#endif
- case 'F':
- if (strequal(rts_argv[arg]+2, "2s")) {
- RtsFlags.GcFlags.force2s = rtsTrue;
- } else {
- bad_option( rts_argv[arg] );
- }
- break;
-
case 'K':
RtsFlags.GcFlags.maxStkSize =
decode(rts_argv[arg]+2) / sizeof(W_);
@@ -477,6 +470,13 @@ error = rtsTrue;
bad_option( rts_argv[arg] );
break;
+ case 'G':
+ RtsFlags.GcFlags.generations = decode(rts_argv[arg]+2);
+ if (RtsFlags.GcFlags.generations <= 1) {
+ bad_option(rts_argv[arg]);
+ }
+ break;
+
case 'H':
/* ignore for compatibility with older versions */
break;
diff --git a/ghc/rts/RtsFlags.h b/ghc/rts/RtsFlags.h
index 1939ebef3821..7d2982bc5e9d 100644
--- a/ghc/rts/RtsFlags.h
+++ b/ghc/rts/RtsFlags.h
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: RtsFlags.h,v 1.2 1998/12/02 13:28:40 simonm Exp $
+ * $Id: RtsFlags.h,v 1.3 1999/01/13 17:25:43 simonm Exp $
*
* Datatypes that holds the command-line flag settings.
*
@@ -23,9 +23,8 @@ struct GC_FLAGS {
nat minAllocAreaSize; /* in *blocks* */
double pcFreeHeap;
- rtsBool force2s; /* force the use of 2-space copying collection;
- forced to rtsTrue if we do *heap* profiling.
- */
+ nat generations;
+
rtsBool forceGC; /* force a major GC every <interval> bytes */
int forcingInterval; /* actually, stored as a number of *words* */
rtsBool ringBell;
diff --git a/ghc/rts/Sanity.c b/ghc/rts/Sanity.c
index 1977aab6b24b..874533a08617 100644
--- a/ghc/rts/Sanity.c
+++ b/ghc/rts/Sanity.c
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: Sanity.c,v 1.2 1998/12/02 13:28:43 simonm Exp $
+ * $Id: Sanity.c,v 1.3 1999/01/13 17:25:43 simonm Exp $
*
* Sanity checking code for the heap and stack.
*
@@ -21,10 +21,8 @@
#include "BlockAlloc.h"
#include "Sanity.h"
-static nat heap_step;
-
#define LOOKS_LIKE_PTR(r) \
- (IS_DATA_PTR(r) || ((IS_USER_PTR(r) && Bdescr((P_)r)->step == heap_step)))
+ (IS_DATA_PTR(r) || ((IS_USER_PTR(r) && Bdescr((P_)r)->free != (void *)-1)))
/* -----------------------------------------------------------------------------
Check stack sanity
@@ -199,6 +197,7 @@ checkClosure( StgClosure* p )
case THUNK:
case CONSTR:
case IND_PERM:
+ case IND_OLDGEN:
case IND_OLDGEN_PERM:
case CAF_UNENTERED:
case CAF_ENTERED:
@@ -241,14 +240,16 @@ checkClosure( StgClosure* p )
return sizeofW(StgHeader) + MIN_UPD_SIZE;
case IND:
- case IND_OLDGEN:
{
/* we don't expect to see any of these after GC
* but they might appear during execution
*/
+ P_ q;
StgInd *ind = stgCast(StgInd*,p);
ASSERT(LOOKS_LIKE_PTR(ind->indirectee));
- return sizeofW(StgInd);
+ q = (P_)p + sizeofW(StgInd);
+ while (!*q) { q++; }; /* skip padding words (see GC.c: evacuate())*/
+ return q - (P_)p;
}
case RET_BCO:
@@ -278,20 +279,19 @@ checkClosure( StgClosure* p )
case MUT_ARR_WORDS:
return arr_words_sizeW(stgCast(StgArrWords*,p));
- case ARR_PTRS:
case MUT_ARR_PTRS:
case MUT_ARR_PTRS_FROZEN:
{
- StgArrPtrs* a = stgCast(StgArrPtrs*,p);
+ StgMutArrPtrs* a = stgCast(StgMutArrPtrs*,p);
nat i;
for (i = 0; i < a->ptrs; i++) {
- ASSERT(LOOKS_LIKE_PTR(payloadPtr(a,i)));
+ ASSERT(LOOKS_LIKE_PTR(a->payload[i]));
}
- return arr_ptrs_sizeW(a);
+ return mut_arr_ptrs_sizeW(a);
}
case TSO:
- checkTSO((StgTSO *)p, heap_step);
+ checkTSO((StgTSO *)p);
return tso_sizeW((StgTSO *)p);
case BLOCKED_FETCH:
@@ -309,27 +309,44 @@ checkClosure( StgClosure* p )
After garbage collection, the live heap is in a state where we can
run through and check that all the pointers point to the right
- place.
+ place. This function starts at a given position and sanity-checks
+ all the objects in the remainder of the chain.
-------------------------------------------------------------------------- */
extern void
-checkHeap(bdescr *bd, nat step)
+checkHeap(bdescr *bd, StgPtr start)
{
StgPtr p;
- heap_step = step;
+ if (start == NULL) {
+ p = bd->start;
+ } else {
+ p = start;
+ }
while (bd != NULL) {
- p = bd->start;
while (p < bd->free) {
nat size = checkClosure(stgCast(StgClosure*,p));
/* This is the smallest size of closure that can live in the heap. */
ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
p += size;
+ while (*p == 0) { p++; } /* skip over slop */
}
bd = bd->link;
+ if (bd != NULL) {
+ p = bd->start;
+ }
}
-}
+}
+
+extern void
+checkChain(bdescr *bd)
+{
+ while (bd != NULL) {
+ checkClosure((StgClosure *)bd->start);
+ bd = bd->link;
+ }
+}
/* check stack - making sure that update frames are linked correctly */
void
@@ -361,7 +378,7 @@ checkStack(StgPtr sp, StgPtr stack_end, StgUpdateFrame* su )
}
extern void
-checkTSO(StgTSO *tso, nat step)
+checkTSO(StgTSO *tso)
{
StgPtr sp = tso->sp;
StgPtr stack = tso->stack;
@@ -369,7 +386,12 @@ checkTSO(StgTSO *tso, nat step)
StgOffset stack_size = tso->stack_size;
StgPtr stack_end = stack + stack_size;
- heap_step = step;
+ if (tso->whatNext == ThreadComplete || tso->whatNext == ThreadKilled) {
+ /* The garbage collector doesn't bother following any pointers
+ * from dead threads, so don't check sanity here.
+ */
+ return;
+ }
ASSERT(stack <= sp && sp < stack_end);
ASSERT(sp <= stgCast(StgPtr,su));
diff --git a/ghc/rts/Sanity.h b/ghc/rts/Sanity.h
index 7fc6b4f7b579..581e02938ca3 100644
--- a/ghc/rts/Sanity.h
+++ b/ghc/rts/Sanity.h
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: Sanity.h,v 1.2 1998/12/02 13:28:44 simonm Exp $
+ * $Id: Sanity.h,v 1.3 1999/01/13 17:25:44 simonm Exp $
*
* Prototypes for functions in Sanity.c
*
@@ -7,9 +7,10 @@
#ifdef DEBUG
/* debugging routines */
-extern void checkHeap ( bdescr *bd, nat step );
+extern void checkHeap ( bdescr *bd, StgPtr start );
+extern void checkChain ( bdescr *bd );
extern void checkStack ( StgPtr sp, StgPtr stack_end, StgUpdateFrame* su );
-extern void checkTSO ( StgTSO* tso, nat step );
+extern void checkTSO ( StgTSO* tso );
extern StgOffset checkClosure( StgClosure* p );
diff --git a/ghc/rts/Schedule.c b/ghc/rts/Schedule.c
index cade9089f070..d3af45977c47 100644
--- a/ghc/rts/Schedule.c
+++ b/ghc/rts/Schedule.c
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: Schedule.c,v 1.3 1999/01/06 11:44:44 simonm Exp $
+ * $Id: Schedule.c,v 1.4 1999/01/13 17:25:44 simonm Exp $
*
* Scheduler
*
@@ -119,7 +119,7 @@ initThread(StgTSO *tso, nat stack_size)
SET_HDR((StgClosure*)tso->sp,(StgInfoTable *)&stg_stop_thread_info,CCS_MAIN);
tso->su = (StgUpdateFrame*)tso->sp;
- IF_DEBUG(scheduler,belch("Initialised thread %lld, stack size = %lx words\n",
+ IF_DEBUG(scheduler,belch("Initialised thread %ld, stack size = %lx words\n",
tso->id, tso->stack_size));
/* Put the new thread on the head of the runnable queue.
@@ -160,7 +160,7 @@ void deleteThread(StgTSO *tso)
return;
}
- IF_DEBUG(scheduler, belch("Killing thread %lld.", tso->id));
+ IF_DEBUG(scheduler, belch("Killing thread %ld.", tso->id));
tso->whatNext = ThreadKilled; /* changed to ThreadComplete in schedule() */
tso->link = END_TSO_QUEUE; /* Just to be on the safe side... */
@@ -363,7 +363,7 @@ SchedulerStatus schedule(StgTSO *main, StgClosure **ret_val)
ccalling_threads = CurrentTSO;
in_ccall_gc = rtsTrue;
IF_DEBUG(scheduler,
- fprintf(stderr, "Re-entry, thread %lld did a _ccall_gc\n",
+ fprintf(stderr, "Re-entry, thread %d did a _ccall_gc\n",
CurrentTSO->id););
} else {
in_ccall_gc = rtsFalse;
@@ -391,7 +391,12 @@ SchedulerStatus schedule(StgTSO *main, StgClosure **ret_val)
} else {
context_switch = 0;
}
- IF_DEBUG(scheduler, belch("Running thread %lld...\n", t->id));
+ IF_DEBUG(scheduler, belch("Running thread %ld...\n", t->id));
+
+ /* Be friendly to the storage manager: we're about to *run* this
+ * thread, so we better make sure the TSO is mutable.
+ */
+ recordMutable((StgMutClosure *)t);
/* Run the current thread */
switch (t->whatNext) {
@@ -441,14 +446,14 @@ SchedulerStatus schedule(StgTSO *main, StgClosure **ret_val)
switch (ret) {
case HeapOverflow:
- IF_DEBUG(scheduler,belch("Thread %lld stopped: HeapOverflow\n", t->id));
+ IF_DEBUG(scheduler,belch("Thread %ld stopped: HeapOverflow\n", t->id));
threadPaused(t);
PUSH_ON_RUN_QUEUE(t);
GarbageCollect(GetRoots);
break;
case StackOverflow:
- IF_DEBUG(scheduler,belch("Thread %lld stopped, StackOverflow\n", t->id));
+ IF_DEBUG(scheduler,belch("Thread %ld stopped, StackOverflow\n", t->id));
{
nat i;
/* enlarge the stack */
@@ -474,9 +479,9 @@ SchedulerStatus schedule(StgTSO *main, StgClosure **ret_val)
/* ToDo: or maybe a timer expired when we were in Hugs?
* or maybe someone hit ctrl-C
*/
- belch("Thread %lld stopped to switch to Hugs\n", t->id);
+ belch("Thread %ld stopped to switch to Hugs\n", t->id);
} else {
- belch("Thread %lld stopped, timer expired\n", t->id);
+ belch("Thread %ld stopped, timer expired\n", t->id);
}
);
threadPaused(t);
@@ -510,7 +515,7 @@ SchedulerStatus schedule(StgTSO *main, StgClosure **ret_val)
break;
case ThreadBlocked:
- IF_DEBUG(scheduler,belch("Thread %lld stopped, blocking\n", t->id));
+ IF_DEBUG(scheduler,belch("Thread %ld stopped, blocking\n", t->id));
threadPaused(t);
/* assume the thread has put itself on some blocked queue
* somewhere.
@@ -518,7 +523,7 @@ SchedulerStatus schedule(StgTSO *main, StgClosure **ret_val)
break;
case ThreadFinished:
- IF_DEBUG(scheduler,belch("Thread %lld finished\n", t->id));
+ IF_DEBUG(scheduler,belch("Thread %ld finished\n", t->id));
deleteThread(t);
t->whatNext = ThreadComplete;
break;
@@ -690,7 +695,14 @@ threadStackOverflow(StgTSO *tso)
/* and relocate the update frame list */
relocate_TSO(tso, dest);
- IF_DEBUG(sanity,checkTSO(tso,0)); /* Step 0 because we're not GC'ing. */
+ /* Mark the old one as dead so we don't try to scavenge it during
+ * garbage collection (the TSO will likely be on a mutables list in
+ * some generation, but it'll get collected soon enough).
+ */
+ tso->whatNext = ThreadKilled;
+ dest->mut_link = NULL;
+
+ IF_DEBUG(sanity,checkTSO(tso));
#if 0
IF_DEBUG(scheduler,printTSO(dest));
#endif
@@ -714,7 +726,7 @@ void awaken_blocked_queue(StgTSO *q)
tso = q;
q = tso->link;
PUSH_ON_RUN_QUEUE(tso);
- IF_DEBUG(scheduler,belch("Waking up thread %lld", tso->id));
+ IF_DEBUG(scheduler,belch("Waking up thread %ld", tso->id));
}
}
diff --git a/ghc/rts/Stats.c b/ghc/rts/Stats.c
index b4421ff9bc12..1cbc0ba236b7 100644
--- a/ghc/rts/Stats.c
+++ b/ghc/rts/Stats.c
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: Stats.c,v 1.2 1998/12/02 13:28:49 simonm Exp $
+ * $Id: Stats.c,v 1.3 1999/01/13 17:25:46 simonm Exp $
*
* Statistics and timing-related functions.
*
@@ -10,6 +10,8 @@
#include "Rts.h"
#include "RtsFlags.h"
#include "RtsUtils.h"
+#include "StoragePriv.h"
+#include "MBlock.h"
/**
* Ian: For the moment we just want to ignore
@@ -85,14 +87,6 @@ static ullong GC_tot_alloc = 0;
static StgDouble GC_start_time, GC_tot_time = 0; /* User GC Time */
static StgDouble GCe_start_time, GCe_tot_time = 0; /* Elapsed GC time */
-static StgDouble GC_min_time = 0;
-static StgDouble GCe_min_time = 0;
-static lnat GC_maj_no = 0;
-static lnat GC_min_no = 0;
-static lnat GC_min_since_maj = 0;
-static lnat GC_live_maj = 0; /* Heap live at last major collection */
-static lnat GC_alloc_since_maj = 0; /* Heap alloc since collection major */
-
lnat MaxResidency = 0; /* in words; for stats only */
lnat ResidencySamples = 0; /* for stats only */
@@ -185,8 +179,8 @@ initStats(void)
FILE *sf = RtsFlags.GcFlags.statsFile;
if (RtsFlags.GcFlags.giveStats) {
- fprintf(sf, " Alloc Collect Live Resid GC GC TOT TOT Page Flts\n");
- fprintf(sf, " bytes bytes bytes ency user elap user elap\n");
+ fprintf(sf, " Alloc Collect Live GC GC TOT TOT Page Flts\n");
+ fprintf(sf, " bytes bytes bytes user elap user elap\n");
}
}
@@ -265,7 +259,7 @@ stat_startGC(void)
-------------------------------------------------------------------------- */
void
-stat_endGC(lnat alloc, lnat collect, lnat live, char *comment)
+stat_endGC(lnat alloc, lnat collect, lnat live, lnat gen)
{
FILE *sf = RtsFlags.GcFlags.statsFile;
@@ -276,25 +270,31 @@ stat_endGC(lnat alloc, lnat collect, lnat live, char *comment)
if (RtsFlags.GcFlags.giveStats) {
nat faults = pagefaults();
- fprintf(sf, "%8ld %7ld %7ld %5.1f%%",
- alloc*sizeof(W_), collect*sizeof(W_), live*sizeof(W_), collect == 0 ? 0.0 : (live / (StgDouble) collect * 100));
- fprintf(sf, " %5.2f %5.2f %7.2f %7.2f %4ld %4ld %s\n",
+ fprintf(sf, "%9ld %9ld %9ld",
+ alloc*sizeof(W_), collect*sizeof(W_), live*sizeof(W_));
+ fprintf(sf, " %5.2f %5.2f %7.2f %7.2f %4ld %4ld (Gen: %2ld)\n",
(time-GC_start_time),
(etime-GCe_start_time),
time,
etime,
faults - GC_start_faults,
GC_start_faults - GC_end_faults,
- comment);
+ gen);
GC_end_faults = faults;
fflush(sf);
}
- GC_maj_no++;
GC_tot_alloc += (ullong) alloc;
GC_tot_time += time-GC_start_time;
GCe_tot_time += etime-GCe_start_time;
+
+ if (gen == RtsFlags.GcFlags.generations-1) { /* major GC? */
+ if (live > MaxResidency) {
+ MaxResidency = live;
+ }
+ ResidencySamples++;
+ }
}
if (rub_bell) {
@@ -327,31 +327,32 @@ stat_exit(int alloc)
if (etime == 0.0) etime = 0.0001;
- if (RtsFlags.GcFlags.giveStats) {
- fprintf(sf, "%8d\n\n", alloc*sizeof(W_));
- }
+ fprintf(sf, "%9ld %9.9s %9.9s",
+ (lnat)alloc*sizeof(W_), "", "");
+ fprintf(sf, " %5.2f %5.2f\n\n", 0.0, 0.0);
+
+ GC_tot_alloc += alloc;
- else {
- fprintf(sf, "%8ld %7.7s %6.6s %7.7s %6.6s",
- (GC_alloc_since_maj + alloc)*sizeof(W_), "", "", "", "");
- fprintf(sf, " %3ld %5.2f %5.2f\n\n",
- GC_min_since_maj, GC_min_time, GCe_min_time);
- }
- GC_min_no += GC_min_since_maj;
- GC_tot_time += GC_min_time;
- GCe_tot_time += GCe_min_time;
- GC_tot_alloc += GC_alloc_since_maj + alloc;
ullong_format_string(GC_tot_alloc*sizeof(W_), temp, rtsTrue/*commas*/);
fprintf(sf, "%11s bytes allocated in the heap\n", temp);
+
if ( ResidencySamples > 0 ) {
ullong_format_string(MaxResidency*sizeof(W_), temp, rtsTrue/*commas*/);
- fprintf(sf, "%11s bytes maximum residency (%.1f%%, %ld sample(s))\n",
+ fprintf(sf, "%11s bytes maximum residency (%ld sample(s))\n",
temp,
- MaxResidency / (StgDouble) RtsFlags.GcFlags.maxHeapSize * 100,
ResidencySamples);
}
- fprintf(sf, "%11ld garbage collections performed (%ld major, %ld minor)\n\n",
- GC_maj_no + GC_min_no, GC_maj_no, GC_min_no);
+ fprintf(sf,"\n");
+
+ { /* Count garbage collections */
+ nat g;
+ for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
+ fprintf(sf, "%11d collections in generation %d\n",
+ generations[g].collections, g);
+ }
+ }
+ fprintf(sf,"\n%11ld Mb total memory in use\n\n",
+ mblocks_allocated * MBLOCK_SIZE / (1024 * 1024));
MutTime = time - GC_tot_time - InitUserTime;
if (MutTime < 0) { MutTime = 0; }
@@ -386,3 +387,43 @@ stat_exit(int alloc)
fclose(sf);
}
}
+
+/* -----------------------------------------------------------------------------
+ stat_describe_gens
+
+ Produce some detailed info on the state of the generational GC.
+ -------------------------------------------------------------------------- */
+void
+stat_describe_gens(void)
+{
+ nat g, s, mut, lge, live;
+ StgMutClosure *m;
+ bdescr *bd;
+ step *step;
+
+ fprintf(stderr, " Gen Steps Max Mutable Step Blocks Live Large\n" " Blocks Closures Objects\n");
+
+ for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
+ for (m = generations[g].mut_list, mut = 0; m != END_MUT_LIST;
+ m = m->mut_link)
+ mut++;
+ fprintf(stderr, "%8d %8d %8d %9d", g, generations[g].n_steps,
+ generations[g].max_blocks, mut);
+
+ for (s = 0; s < generations[g].n_steps; s++) {
+ step = &generations[g].steps[s];
+ for (bd = step->large_objects, lge = 0; bd; bd = bd->link)
+ lge++;
+ live = 0;
+ for (bd = step->blocks; bd; bd = bd->link) {
+ live += (bd->free - bd->start) * sizeof(W_);
+ }
+ if (s != 0) {
+ fprintf(stderr,"%36s","");
+ }
+ fprintf(stderr,"%6d %8d %8d %8d\n", s, step->n_blocks,
+ live, lge);
+ }
+ }
+ fprintf(stderr,"\n");
+}
diff --git a/ghc/rts/Stats.h b/ghc/rts/Stats.h
index be95442f1ac2..2b9c0a5a5b69 100644
--- a/ghc/rts/Stats.h
+++ b/ghc/rts/Stats.h
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: Stats.h,v 1.2 1998/12/02 13:28:50 simonm Exp $
+ * $Id: Stats.h,v 1.3 1999/01/13 17:25:46 simonm Exp $
*
* Statistics and timing-related functions.
*
@@ -11,6 +11,6 @@ extern StgDouble usertime(void);
extern void end_init(void);
extern void stat_exit(int alloc);
extern void stat_startGC(void);
-extern void stat_endGC(lnat alloc, lnat collect, lnat live,
- char *comment);
+extern void stat_endGC(lnat alloc, lnat collect, lnat live, lnat gen);
extern void initStats(void);
+extern void stat_describe_gens(void);
diff --git a/ghc/rts/StgMiscClosures.hc b/ghc/rts/StgMiscClosures.hc
index 227b27d1d2dd..3e8cd99527b2 100644
--- a/ghc/rts/StgMiscClosures.hc
+++ b/ghc/rts/StgMiscClosures.hc
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: StgMiscClosures.hc,v 1.2 1998/12/02 13:28:52 simonm Exp $
+ * $Id: StgMiscClosures.hc,v 1.3 1999/01/13 17:25:46 simonm Exp $
*
* Entry code for various built-in closure types.
*
@@ -64,7 +64,7 @@ ling */
FE_
}
-INFO_TABLE(IND_OLDGEN_info,IND_OLDGEN_entry,1,0,IND_OLDGEN,const,EF_,0,0);
+INFO_TABLE(IND_OLDGEN_info,IND_OLDGEN_entry,1,1,IND_OLDGEN,const,EF_,0,0);
STGFUN(IND_OLDGEN_entry)
{
FB_
@@ -76,7 +76,7 @@ STGFUN(IND_OLDGEN_entry)
FE_
}
-INFO_TABLE(IND_OLDGEN_PERM_info,IND_OLDGEN_PERM_entry,1,0,IND_OLDGEN_PERM,const,EF_,0,0);
+INFO_TABLE(IND_OLDGEN_PERM_info,IND_OLDGEN_PERM_entry,1,1,IND_OLDGEN_PERM,const,EF_,0,0);
STGFUN(IND_OLDGEN_PERM_entry)
{
FB_
@@ -127,12 +127,12 @@ STGFUN(CAF_ENTERED_entry)
-------------------------------------------------------------------------- */
/* Note: a black hole must be big enough to be overwritten with an
- * indirection/evacuee/catch. Thus we claim it has 2 non-pointer words of
- * payload, which should be big enough for an old-generation
- * indirection.
+ * indirection/evacuee/catch. Thus we claim it has 1 non-pointer word of
+ * payload (in addition to the pointer word for the blocking queue), which
+ * should be big enough for an old-generation indirection.
*/
-INFO_TABLE(BLACKHOLE_info, BLACKHOLE_entry,0,2,BLACKHOLE,const,EF_,0,0);
+INFO_TABLE(BLACKHOLE_info, BLACKHOLE_entry,1,1,BLACKHOLE,const,EF_,0,0);
STGFUN(BLACKHOLE_entry)
{
FB_
@@ -146,7 +146,7 @@ STGFUN(BLACKHOLE_entry)
}
/* identical to BLACKHOLEs except for the infotag */
-INFO_TABLE(CAF_BLACKHOLE_info, CAF_BLACKHOLE_entry,0,2,CAF_BLACKHOLE,const,EF_,0,0);
+INFO_TABLE(CAF_BLACKHOLE_info, CAF_BLACKHOLE_entry,1,1,CAF_BLACKHOLE,const,EF_,0,0);
STGFUN(CAF_BLACKHOLE_entry)
{
FB_
@@ -226,10 +226,10 @@ NON_ENTERABLE_ENTRY_CODE(FOREIGN);
and entry code for each type.
-------------------------------------------------------------------------- */
-INFO_TABLE(FULL_MVAR_info,FULL_MVAR_entry,3,0,MVAR,const,EF_,0,0);
+INFO_TABLE(FULL_MVAR_info,FULL_MVAR_entry,4,0,MVAR,const,EF_,0,0);
NON_ENTERABLE_ENTRY_CODE(FULL_MVAR);
-INFO_TABLE(EMPTY_MVAR_info,EMPTY_MVAR_entry,3,0,MVAR,const,EF_,0,0);
+INFO_TABLE(EMPTY_MVAR_info,EMPTY_MVAR_entry,4,0,MVAR,const,EF_,0,0);
NON_ENTERABLE_ENTRY_CODE(EMPTY_MVAR);
/* -----------------------------------------------------------------------------
@@ -245,6 +245,23 @@ NON_ENTERABLE_ENTRY_CODE(END_TSO_QUEUE);
SET_STATIC_HDR(END_TSO_QUEUE_closure,END_TSO_QUEUE_info,0/*CC*/,const,EI_)
};
+/* -----------------------------------------------------------------------------
+ Mutable lists
+
+ Mutable lists (used by the garbage collector) consist of a chain of
+ StgMutClosures connected through their mut_link fields, ending in
+ an END_MUT_LIST closure.
+ -------------------------------------------------------------------------- */
+
+INFO_TABLE_CONSTR(END_MUT_LIST_info,END_MUT_LIST_entry,0,0,0,CONSTR_NOCAF_STATIC,const,EF_,0,0);
+NON_ENTERABLE_ENTRY_CODE(END_MUT_LIST);
+
+SET_STATIC_HDR(END_MUT_LIST_closure,END_MUT_LIST_info,0/*CC*/,const,EI_)
+};
+
+INFO_TABLE(MUT_CONS_info, MUT_CONS_entry, 1, 1, MUT_VAR, const, EF_, 0, 0);
+NON_ENTERABLE_ENTRY_CODE(MUT_CONS);
+
/* -----------------------------------------------------------------------------
Arrays
@@ -266,7 +283,6 @@ NON_ENTERABLE_ENTRY_CODE(type);
ArrayInfo(ARR_WORDS);
ArrayInfo(MUT_ARR_WORDS);
-ArrayInfo(ARR_PTRS);
ArrayInfo(MUT_ARR_PTRS);
ArrayInfo(MUT_ARR_PTRS_FROZEN);
@@ -276,7 +292,7 @@ ArrayInfo(MUT_ARR_PTRS_FROZEN);
Mutable Variables
-------------------------------------------------------------------------- */
-INFO_TABLE(MUT_VAR_info, MUT_VAR_entry, 1, 0, MUT_VAR, const, EF_, 0, 0);
+INFO_TABLE(MUT_VAR_info, MUT_VAR_entry, 1, 1, MUT_VAR, const, EF_, 0, 0);
NON_ENTERABLE_ENTRY_CODE(MUT_VAR);
/* -----------------------------------------------------------------------------
diff --git a/ghc/rts/Storage.c b/ghc/rts/Storage.c
index e08ba9ba355e..3d7a0b7ca570 100644
--- a/ghc/rts/Storage.c
+++ b/ghc/rts/Storage.c
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: Storage.c,v 1.2 1998/12/02 13:28:57 simonm Exp $
+ * $Id: Storage.c,v 1.3 1999/01/13 17:25:47 simonm Exp $
*
* Storage manager front end
*
@@ -11,13 +11,13 @@
#include "Stats.h"
#include "Hooks.h"
#include "BlockAlloc.h"
+#include "MBlock.h"
#include "gmp.h"
#include "Weak.h"
#include "Storage.h"
#include "StoragePriv.h"
-bdescr *nursery; /* chained-blocks in the nursery */
bdescr *current_nursery; /* next available nursery block, or NULL */
nat nursery_blocks; /* number of blocks in the nursery */
@@ -31,9 +31,15 @@ nat alloc_blocks_lim; /* approximate limit on alloc_blocks */
StgPtr alloc_Hp = NULL; /* next free byte in small_alloc_list */
StgPtr alloc_HpLim = NULL; /* end of block at small_alloc_list */
+generation *generations; /* all the generations */
+generation *g0; /* generation 0, for convenience */
+generation *oldest_gen; /* oldest generation, for convenience */
+step *g0s0; /* generation 0, step 0, for convenience */
+
/*
* Forward references
*/
+static bdescr *allocNursery (nat blocks);
static void *stgAllocForGMP (size_t size_in_bytes);
static void *stgReallocForGMP (void *ptr, size_t old_size, size_t new_size);
static void stgDeallocForGMP (void *ptr, size_t size);
@@ -41,9 +47,83 @@ static void stgDeallocForGMP (void *ptr, size_t size);
void
initStorage (void)
{
+ nat g, s;
+ step *step;
+
initBlockAllocator();
- nursery = allocNursery(NULL, RtsFlags.GcFlags.minAllocAreaSize);
+ /* allocate generation info array */
+ generations = (generation *)stgMallocBytes(RtsFlags.GcFlags.generations
+ * sizeof(struct _generation),
+ "initStorage: gens");
+
+ /* set up all generations */
+ for(g = 0; g < RtsFlags.GcFlags.generations; g++) {
+ generations[g].no = g;
+ generations[g].mut_list = END_MUT_LIST;
+ generations[g].collections = 0;
+ generations[g].failed_promotions = 0;
+ }
+
+ /* Oldest generation: one step */
+ g = RtsFlags.GcFlags.generations-1;
+ generations[g].n_steps = 1;
+ generations[g].steps =
+ stgMallocBytes(1 * sizeof(struct _step), "initStorage: last step");
+ generations[g].max_blocks = RtsFlags.GcFlags.minAllocAreaSize * 4;
+ step = &generations[g].steps[0];
+ step->no = 0;
+ step->gen = &generations[g];
+ step->blocks = NULL;
+ step->n_blocks = 0;
+ step->to = step; /* destination is this step */
+ step->hp = NULL;
+ step->hpLim = NULL;
+ step->hp_bd = NULL;
+
+ /* set up all except the oldest generation with 2 steps */
+ for(g = 0; g < RtsFlags.GcFlags.generations-1; g++) {
+ generations[g].n_steps = 2;
+ generations[g].steps = stgMallocBytes (2 * sizeof(struct _step),
+ "initStorage: steps");
+ generations[g].max_blocks = RtsFlags.GcFlags.minAllocAreaSize * 4;
+ }
+
+ for (g = 0; g < RtsFlags.GcFlags.generations-1; g++) {
+ for (s = 0; s < generations[g].n_steps; s++) {
+ step = &generations[g].steps[s];
+ step->no = s;
+ step->blocks = NULL;
+ step->n_blocks = 0;
+ step->gen = &generations[g];
+ if ( s == 1 ) {
+ step->to = &generations[g+1].steps[0];
+ } else {
+ step->to = &generations[g].steps[s+1];
+ }
+ step->hp = NULL;
+ step->hpLim = NULL;
+ step->hp_bd = NULL;
+ step->large_objects = NULL;
+ step->new_large_objects = NULL;
+ step->scavenged_large_objects = NULL;
+ }
+ }
+
+ oldest_gen = &generations[RtsFlags.GcFlags.generations-1];
+
+ /* generation 0 is special: that's the nursery */
+ g0 = &generations[0];
+ generations[0].max_blocks = 0;
+
+ /* G0S0: the allocation area */
+ step = &generations[0].steps[0];
+ g0s0 = step;
+ step->blocks = allocNursery(RtsFlags.GcFlags.minAllocAreaSize);
+ step->n_blocks = RtsFlags.GcFlags.minAllocAreaSize;
+ nursery_blocks = RtsFlags.GcFlags.minAllocAreaSize;
+ current_nursery = step->blocks;
+ /* hp, hpLim, hp_bd, to_space etc. aren't used in G0S0 */
weak_ptr_list = NULL;
caf_list = NULL;
@@ -58,24 +138,27 @@ initStorage (void)
/* Tell GNU multi-precision pkg about our custom alloc functions */
mp_set_memory_functions(stgAllocForGMP, stgReallocForGMP, stgDeallocForGMP);
#endif
+
+ IF_DEBUG(gc, stat_describe_gens());
}
-bdescr *
-allocNursery (bdescr *last_bd, nat blocks)
+static bdescr *
+allocNursery (nat blocks)
{
- bdescr *bd;
+ bdescr *last_bd, *bd;
nat i;
+ last_bd = NULL;
/* Allocate a nursery */
for (i=0; i < blocks; i++) {
bd = allocBlock();
bd->link = last_bd;
- bd->step = 0;
+ bd->step = g0s0;
+ bd->gen = g0;
+ bd->evacuated = 0;
bd->free = bd->start;
last_bd = bd;
}
- nursery_blocks = blocks;
- current_nursery = last_bd;
return last_bd;
}
@@ -94,14 +177,47 @@ exitStorage (void)
stat_exit(allocated);
}
+void
+recordMutable(StgMutClosure *p)
+{
+ bdescr *bd;
+
+ ASSERT(closure_MUTABLE(p));
+
+ bd = Bdescr((P_)p);
+
+ /* no need to bother in generation 0 */
+ if (bd->gen == g0) {
+ return;
+ }
+
+ if (p->mut_link == NULL) {
+ p->mut_link = bd->gen->mut_list;
+ bd->gen->mut_list = p;
+ }
+}
+
void
newCAF(StgClosure* caf)
{
- const StgInfoTable *info = get_itbl(caf);
+ const StgInfoTable *info;
+
+ /* Put this CAF on the mutable list for the old generation.
+ * This is a HACK - the IND_STATIC closure doesn't really have
+ * a mut_link field, but we pretend it has - in fact we re-use
+ * the STATIC_LINK field for the time being, because when we
+ * come to do a major GC we won't need the mut_link field
+ * any more and can use it as a STATIC_LINK.
+ */
+ ((StgMutClosure *)caf)->mut_link = oldest_gen->mut_list;
+ oldest_gen->mut_list = (StgMutClosure *)caf;
+#ifdef DEBUG
+ info = get_itbl(caf);
ASSERT(info->type == IND_STATIC);
STATIC_LINK2(info,caf) = caf_list;
caf_list = caf;
+#endif
}
/* -----------------------------------------------------------------------------
@@ -122,16 +238,15 @@ allocate(nat n)
CCS_ALLOC(CCCS,n);
/* big allocation (>LARGE_OBJECT_THRESHOLD) */
+ /* ToDo: allocate directly into generation 1 */
if (n >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
nat req_blocks = (lnat)BLOCK_ROUND_UP(n*sizeof(W_)) / BLOCK_SIZE;
bd = allocGroup(req_blocks);
- bd->link = large_alloc_list;
- bd->back = NULL;
- if (large_alloc_list) {
- large_alloc_list->back = bd; /* double-link the list */
- }
- large_alloc_list = bd;
- bd->step = 0;
+ dbl_link_onto(bd, &g0s0->large_objects);
+ bd->gen = g0;
+ bd->step = g0s0;
+ bd->evacuated = 0;
+ bd->free = bd->start;
/* don't add these blocks to alloc_blocks, since we're assuming
* that large objects are likely to remain live for quite a while
* (eg. running threads), so garbage collecting early won't make
@@ -147,7 +262,9 @@ allocate(nat n)
bd = allocBlock();
bd->link = small_alloc_list;
small_alloc_list = bd;
- bd->step = 0;
+ bd->gen = g0;
+ bd->step = g0s0;
+ bd->evacuated = 0;
alloc_Hp = bd->start;
alloc_HpLim = bd->start + BLOCK_SIZE_W;
alloc_blocks++;
@@ -215,3 +332,65 @@ stgDeallocForGMP (void *ptr STG_UNUSED,
{
/* easy for us: the garbage collector does the dealloc'n */
}
+
+/* -----------------------------------------------------------------------------
+ Debugging
+
+ memInventory() checks for memory leaks by counting up all the
+ blocks we know about and comparing that to the number of blocks
+ allegedly floating around in the system.
+ -------------------------------------------------------------------------- */
+
+#ifdef DEBUG
+
+extern void
+memInventory(void)
+{
+ nat g, s;
+ step *step;
+ bdescr *bd;
+ lnat total_blocks = 0, free_blocks = 0;
+
+ /* count the blocks we current have */
+ for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
+ for (s = 0; s < generations[g].n_steps; s++) {
+ step = &generations[g].steps[s];
+ total_blocks += step->n_blocks;
+ for (bd = step->large_objects; bd; bd = bd->link) {
+ total_blocks += bd->blocks;
+ /* hack for megablock groups: they have an extra block or two in
+ the second and subsequent megablocks where the block
+ descriptors would normally go.
+ */
+ if (bd->blocks > BLOCKS_PER_MBLOCK) {
+ total_blocks -= (MBLOCK_SIZE / BLOCK_SIZE - BLOCKS_PER_MBLOCK)
+ * bd->blocks/(MBLOCK_SIZE/BLOCK_SIZE);
+ }
+ }
+ }
+ }
+
+ /* any blocks held by allocate() */
+ for (bd = small_alloc_list; bd; bd = bd->link) {
+ total_blocks += bd->blocks;
+ }
+ for (bd = large_alloc_list; bd; bd = bd->link) {
+ total_blocks += bd->blocks;
+ }
+
+ /* count the blocks on the free list */
+ free_blocks = countFreeList();
+
+ ASSERT(total_blocks + free_blocks == mblocks_allocated * BLOCKS_PER_MBLOCK);
+
+#if 0
+ if (total_blocks + free_blocks != mblocks_allocated *
+ BLOCKS_PER_MBLOCK) {
+ fprintf(stderr, "Blocks: %ld live + %ld free = %ld total (%ld around)\n",
+ total_blocks, free_blocks, total_blocks + free_blocks,
+ mblocks_allocated * BLOCKS_PER_MBLOCK);
+ }
+#endif
+}
+
+#endif
diff --git a/ghc/rts/Storage.h b/ghc/rts/Storage.h
index b11e8aa61609..d197087b1494 100644
--- a/ghc/rts/Storage.h
+++ b/ghc/rts/Storage.h
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: Storage.h,v 1.2 1998/12/02 13:28:58 simonm Exp $
+ * $Id: Storage.h,v 1.3 1999/01/13 17:25:48 simonm Exp $
*
* External Storage Manger Interface
*
@@ -87,8 +87,30 @@ extern StgClosure *MarkRoot(StgClosure *p);
-------------------------------------------------------------------------- */
-extern void RecordMutable(StgPtr p);
-extern void UpdateWithIndirection(StgPtr p1, StgPtr p2);
+extern void recordMutable(StgMutClosure *p);
+
+#ifdef TICKY_TICKY
+#error updateWithIndirection: maybe permanent indirection?
+# define Ind_info_TO_USE ((AllFlags.doUpdEntryCounts) ? &IND_PERM_info : &IND_info
+)
+#endif
+
+static inline void
+updateWithIndirection(StgClosure *p1, StgClosure *p2)
+{
+ bdescr *bd;
+
+ bd = Bdescr((P_)p1);
+ if (bd->gen->no == 0) {
+ SET_INFO(p1,&IND_info);
+ ((StgInd *)p1)->indirectee = p2;
+ } else {
+ SET_INFO(p1,&IND_OLDGEN_info);
+ ((StgIndOldGen *)p1)->indirectee = p2;
+ ((StgIndOldGen *)p1)->mut_link = bd->gen->mut_list;
+ bd->gen->mut_list = (StgMutClosure *)p1;
+ }
+}
/* -----------------------------------------------------------------------------
The CAF list - used to let us revert CAFs
diff --git a/ghc/rts/StoragePriv.h b/ghc/rts/StoragePriv.h
index c3054a501e3d..82318655a505 100644
--- a/ghc/rts/StoragePriv.h
+++ b/ghc/rts/StoragePriv.h
@@ -1,11 +1,96 @@
/* -----------------------------------------------------------------------------
- * $Id: StoragePriv.h,v 1.2 1998/12/02 13:28:59 simonm Exp $
+ * $Id: StoragePriv.h,v 1.3 1999/01/13 17:25:48 simonm Exp $
*
* Internal Storage Manger Interface
*
* ---------------------------------------------------------------------------*/
-extern bdescr *allocNursery (bdescr *last_bd, nat blocks);
+#ifndef STORAGEPRIV_H
+#define STORAGEPRIV_H
+
+/* GENERATION GC NOTES
+ *
+ * We support an arbitrary number of generations, with an arbitrary number
+ * of steps per generation. Notes (in no particular order):
+ *
+ * - all generations except the oldest should have two steps. This gives
+ * objects a decent chance to age before being promoted, and in
+ * particular will ensure that we don't end up with too many
+ * thunks being updated in older generations.
+ *
+ * - the oldest generation has one step. There's no point in aging
+ * objects in the oldest generation.
+ *
+ * - generation 0, step 0 (G0S0) is the allocation area. It is given
+ * a fixed set of blocks during initialisation, and these blocks
+ * are never freed.
+ *
+ * - during garbage collection, each step which is an evacuation
+ * destination (i.e. all steps except G0S0) is allocated a to-space.
+ * evacuated objects are allocated into the step's to-space until
+ * GC is finished, when the original step's contents may be freed
+ * and replaced by the to-space.
+ *
+ * - the mutable-list is per-generation (not per-step). G0 doesn't
+ * have one (since every garbage collection collects at least G0).
+ *
+ * - block descriptors contain pointers to both the step and the
+ * generation that the block belongs to, for convenience.
+ *
+ * - static objects are stored in per-generation lists. See GC.c for
+ * details of how we collect CAFs in the generational scheme.
+ *
+ * - large objects are per-step, and are promoted in the same way
+ * as small objects, except that we may allocate large objects into
+ * generation 1 initially.
+ */
+
+typedef struct _step {
+ nat no; /* step number */
+ bdescr *blocks; /* blocks in this step */
+ nat n_blocks; /* number of blocks */
+ struct _step *to; /* where collected objects from this step go */
+ struct _generation *gen; /* generation this step belongs to */
+ bdescr *large_objects; /* large objects (doubly linked) */
+
+ /* temporary use during GC: */
+ StgPtr hp; /* next free locn in to-space */
+ StgPtr hpLim; /* end of current to-space block */
+ bdescr *hp_bd; /* bdescr of current to-space block */
+ bdescr *to_space; /* bdescr of first to-space block */
+ nat to_blocks; /* number of blocks in to-space */
+ bdescr *scan_bd; /* block currently being scanned */
+ StgPtr scan; /* scan pointer in current block */
+ bdescr *new_large_objects; /* large objects collected so far */
+ bdescr *scavenged_large_objects; /* live large objects after GC (dbl link) */
+
+#ifdef DEBUG
+ /* for sanity checking: */
+ bdescr *old_scan_bd;
+ StgPtr old_scan;
+#endif
+} step;
+
+typedef struct _generation {
+ nat no; /* generation number */
+ step *steps; /* steps */
+ nat n_steps; /* number of steps */
+ nat max_blocks; /* max blocks in step 0 */
+ StgMutClosure *mut_list; /* mutable objects in this generation (not G0)*/
+
+ /* stats information */
+ nat collections;
+ nat failed_promotions;
+} generation;
+
+#define END_OF_STATIC_LIST stgCast(StgClosure*,1)
+
+extern generation *generations;
+
+extern generation *g0;
+extern step *g0s0;
+extern generation *oldest_gen;
+
extern void newCAF(StgClosure*);
extern StgTSO *relocate_TSO(StgTSO *src, StgTSO *dest);
@@ -24,3 +109,25 @@ extern nat nursery_blocks;
extern nat alloc_blocks;
extern nat alloc_blocks_lim;
+static inline void
+dbl_link_onto(bdescr *bd, bdescr **list)
+{
+ bd->link = *list;
+ bd->back = NULL;
+ if (*list) {
+ (*list)->back = bd; /* double-link the list */
+ }
+ *list = bd;
+}
+
+/* MUTABLE LISTS
+ * A mutable list is ended with END_MUT_LIST, so that we can use NULL
+ * as an indication that an object is not on a mutable list.
+ */
+#define END_MUT_LIST ((StgMutClosure *)(void *)&END_MUT_LIST_closure)
+
+#ifdef DEBUG
+extern void memInventory(void);
+#endif
+
+#endif /* STORAGEPRIV_H */
diff --git a/ghc/rts/Updates.hc b/ghc/rts/Updates.hc
index e4359d2489b2..012a88dab211 100644
--- a/ghc/rts/Updates.hc
+++ b/ghc/rts/Updates.hc
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: Updates.hc,v 1.2 1998/12/02 13:29:00 simonm Exp $
+ * $Id: Updates.hc,v 1.3 1999/01/13 17:25:49 simonm Exp $
*
* Code to perform updates.
*
@@ -8,6 +8,7 @@
#include "Rts.h"
#include "RtsUtils.h"
#include "HeapStackCheck.h"
+#include "Storage.h"
/*
The update frame return address must be *polymorphic*, that means
@@ -51,7 +52,7 @@
TICK_UPD_EXISTING(); \
\
updatee = ((StgUpdateFrame *)Sp)->updatee; \
- \
+ \
/* update the updatee with an indirection to the return value */\
UPD_IND(updatee,R1.p); \
\
@@ -75,7 +76,6 @@ UPD_FRAME_ENTRY_TEMPLATE(Upd_frame_5_entry,RET_VEC(Sp[0],5));
UPD_FRAME_ENTRY_TEMPLATE(Upd_frame_6_entry,RET_VEC(Sp[0],6));
UPD_FRAME_ENTRY_TEMPLATE(Upd_frame_7_entry,RET_VEC(Sp[0],7));
-
/*
Make sure this table is big enough to handle the maximum vectored
return size!
diff --git a/ghc/rts/Weak.c b/ghc/rts/Weak.c
index db97eccedeac..9cd70eb8afa3 100644
--- a/ghc/rts/Weak.c
+++ b/ghc/rts/Weak.c
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: Weak.c,v 1.2 1998/12/02 13:29:01 simonm Exp $
+ * $Id: Weak.c,v 1.3 1999/01/13 17:25:49 simonm Exp $
*
* Weak pointers / finalisers
*
@@ -50,6 +50,12 @@ scheduleFinalisers(StgWeak *list)
createIOThread(RtsFlags.GcFlags.initialStkSize, w->finaliser);
#endif
w->header.info = &DEAD_WEAK_info;
+
+ /* need to fill the slop with zeros if we're sanity checking */
+ IF_DEBUG(sanity, {
+ nat dw_size = sizeW_fromITBL(get_itbl(w));
+ memset((P_)w + dw_size, 0, (sizeofW(StgWeak) - dw_size) * sizeof(W_));
+ });
}
}
--
GitLab