diff --git a/ghc/includes/StgStorage.h b/ghc/includes/StgStorage.h
index 86dd60b3d622e24f7a425479cc2bc7534267354f..a6c88f5df7471a435642c790336aa46bb3b5adbd 100644
--- a/ghc/includes/StgStorage.h
+++ b/ghc/includes/StgStorage.h
@@ -1,9 +1,9 @@
/* -----------------------------------------------------------------------------
- * $Id: StgStorage.h,v 1.6 1999/11/09 15:47:09 simonmar Exp $
+ * $Id: StgStorage.h,v 1.7 2000/04/11 16:36:53 sewardj Exp $
*
* (c) The GHC Team, 1998-1999
*
- * STG Storage Manger Interface
+ * STG Storage Manager Interface
*
* ---------------------------------------------------------------------------*/
@@ -108,6 +108,7 @@ typedef struct _generation {
-------------------------------------------------------------------------- */
extern void performGC(void);
+extern void performMajorGC(void);
extern void performGCWithRoots(void (*get_roots)(void));
#endif /* STGSTORAGE_H */
diff --git a/ghc/interpreter/compiler.c b/ghc/interpreter/compiler.c
index ac85831778a5ad87dd96522c96b92fa8da05adce..c6b1cce8f0e1b1cb6d0cab12187e66e792d3df1f 100644
--- a/ghc/interpreter/compiler.c
+++ b/ghc/interpreter/compiler.c
@@ -11,8 +11,8 @@
* included in the distribution.
*
* $RCSfile: compiler.c,v $
- * $Revision: 1.26 $
- * $Date: 2000/04/06 14:23:55 $
+ * $Revision: 1.27 $
+ * $Date: 2000/04/11 16:36:53 $
* ------------------------------------------------------------------------*/
#include "hugsbasictypes.h"
@@ -1490,6 +1490,27 @@ Void evalExp ( void ) { /* compile and run input expression */
unless doRevertCAFs below is permanently TRUE.
*/
/* initScheduler(); */
+
+ /* Further comments, JRS 000411.
+ When control returns to Hugs, you have to be pretty careful about
+ the state of the heap. In particular, hugs.c may subsequently call
+ nukeModule() in storage.c, which removes modules from the system.
+ If a module defines a particular data constructor, the relevant
+ info table is also free()d. That gives a problem if there are
+ still closures hanging round in the heap with references to that
+ info table.
+
+ The solution is to firstly to revert CAFs, and then force a major
+ collection in between transitions from the mutation, ie actually
+ running Haskell, and nukeModule. Since major GCs are potentially
+ expensive, we don't want to do one at every call to nukeModule,
+ so the flag nukeModule_needs_major_gc is used to signal when one
+ is needed.
+
+ This all also seems to imply that doRevertCAFs should always
+ be TRUE.
+ */
+
# ifdef CRUDE_PROFILING
cp_init();
# endif
@@ -1499,6 +1520,7 @@ Void evalExp ( void ) { /* compile and run input expression */
SchedulerStatus status;
Bool doRevertCAFs = TRUE; /* do not change -- comment above */
HugsBreakAction brkOld = setBreakAction ( HugsRtsInterrupt );
+ nukeModule_needs_major_gc = TRUE;
status = rts_eval_(closureOfVar(v),10000,&result);
setBreakAction ( brkOld );
fflush (stderr);
diff --git a/ghc/interpreter/storage.c b/ghc/interpreter/storage.c
index 401168f0c7db026e0a87a7484a7e18cfb3705a00..95627f491275162ac621bfa02f1cd4aaf16553a0 100644
--- a/ghc/interpreter/storage.c
+++ b/ghc/interpreter/storage.c
@@ -9,8 +9,8 @@
* included in the distribution.
*
* $RCSfile: storage.c,v $
- * $Revision: 1.68 $
- * $Date: 2000/04/07 16:25:19 $
+ * $Revision: 1.69 $
+ * $Date: 2000/04/11 16:36:53 $
* ------------------------------------------------------------------------*/
#include "hugsbasictypes.h"
@@ -19,6 +19,7 @@
#include "errors.h"
#include "object.h"
#include <setjmp.h>
+#include "Stg.h"
/*#define DEBUG_SHOWUSE*/
@@ -1628,13 +1629,25 @@ Module newModule ( Text t ) /* add new module to module table */
return mod;
}
+
+Bool nukeModule_needs_major_gc = TRUE;
+
void nukeModule ( Module m )
{
ObjectCode* oc;
ObjectCode* oc2;
Int i;
-assert(isModule(m));
-/*fprintf(stderr, "NUKEMODULE `%s'\n", textToStr(module(m).text)); */
+
+ if (!isModule(m)) internal("nukeModule");
+
+ /* see comment in compiler.c about this,
+ and interaction with info tables */
+ if (nukeModule_needs_major_gc) {
+ /* fprintf ( stderr, "doing major GC in nukeModule\n"); */
+ performMajorGC();
+ nukeModule_needs_major_gc = FALSE;
+ }
+
oc = module(m).object;
while (oc) {
oc2 = oc->next;
diff --git a/ghc/interpreter/storage.h b/ghc/interpreter/storage.h
index 4949a40d0daaebe859e420f770f6be80dfd43b24..881d2730cee52f5949769c5aec6cbb39d3390e96 100644
--- a/ghc/interpreter/storage.h
+++ b/ghc/interpreter/storage.h
@@ -10,8 +10,8 @@
* included in the distribution.
*
* $RCSfile: storage.h,v $
- * $Revision: 1.42 $
- * $Date: 2000/04/07 16:25:20 $
+ * $Revision: 1.43 $
+ * $Date: 2000/04/11 16:36:53 $
* ------------------------------------------------------------------------*/
#define DEBUG_STORAGE /* a moderate level of sanity checking */
@@ -619,7 +619,7 @@ extern Module currentModule; /* Module currently being processed */
extern List moduleGraph; /* :: [GRP_REC | GRP_NONREC] */
extern List prelModules; /* :: [CONID] */
extern List targetModules; /* :: [CONID] */
-
+extern Bool nukeModule_needs_major_gc; /* see comment in compiler.c */
extern Bool isValidModule ( Module );
extern Module newModule ( Text );
diff --git a/ghc/rts/GC.c b/ghc/rts/GC.c
index 3ed912e7cfa7fcf0aa5bc2f38f9a59c3f14ce370..f4308141ae83fdc38a2a317913afe7726faa4632 100644
--- a/ghc/rts/GC.c
+++ b/ghc/rts/GC.c
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: GC.c,v 1.77 2000/03/31 03:09:36 hwloidl Exp $
+ * $Id: GC.c,v 1.78 2000/04/11 16:36:53 sewardj Exp $
*
* (c) The GHC Team 1998-1999
*
@@ -187,7 +187,7 @@ static void gcCAFs ( void );
-------------------------------------------------------------------------- */
//@cindex GarbageCollect
-void GarbageCollect(void (*get_roots)(void))
+void GarbageCollect ( void (*get_roots)(void), rtsBool force_major_gc )
{
bdescr *bd;
step *step;
@@ -217,13 +217,18 @@ void GarbageCollect(void (*get_roots)(void))
/* Figure out which generation to collect
*/
- N = 0;
- for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
- if (generations[g].steps[0].n_blocks >= generations[g].max_blocks) {
- N = g;
+ if (force_major_gc) {
+ N = RtsFlags.GcFlags.generations - 1;
+ major_gc = rtsTrue;
+ } else {
+ N = 0;
+ 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);
}
- major_gc = (N == RtsFlags.GcFlags.generations-1);
/* check stack sanity *before* GC (ToDo: check all threads) */
#if defined(GRAN)
diff --git a/ghc/rts/GC.h b/ghc/rts/GC.h
index 212620e6232d56872818dd2f0a4d6e1ba9ea05ef..9b0e9622cbb28f6c8b1c3753a4c30e0d17eeba19 100644
--- a/ghc/rts/GC.h
+++ b/ghc/rts/GC.h
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: GC.h,v 1.5 2000/01/13 14:34:03 hwloidl Exp $
+ * $Id: GC.h,v 1.6 2000/04/11 16:36:53 sewardj Exp $
*
* (c) The GHC Team, 1998-1999
*
@@ -9,4 +9,4 @@
void threadPaused(StgTSO *);
StgClosure *isAlive(StgClosure *p);
-void GarbageCollect(void (*get_roots)(void));
+void GarbageCollect ( void (*get_roots)(void), rtsBool force_major_gc );
diff --git a/ghc/rts/Schedule.c b/ghc/rts/Schedule.c
index 04ecaf03c1da83ad5f9f094276f96760d08f1380..50009f272120814e9783ff2bbcc34d9f54c6a1c3 100644
--- a/ghc/rts/Schedule.c
+++ b/ghc/rts/Schedule.c
@@ -1,5 +1,5 @@
/* ---------------------------------------------------------------------------
- * $Id: Schedule.c,v 1.65 2000/04/07 09:47:38 simonmar Exp $
+ * $Id: Schedule.c,v 1.66 2000/04/11 16:36:53 sewardj Exp $
*
* (c) The GHC Team, 1998-2000
*
@@ -1089,7 +1089,7 @@ schedule( void )
#ifdef SMP
IF_DEBUG(scheduler,sched_belch("doing GC"));
#endif
- GarbageCollect(GetRoots);
+ GarbageCollect(GetRoots,rtsFalse);
ready_to_gc = rtsFalse;
#ifdef SMP
pthread_cond_broadcast(&gc_pending_cond);
@@ -1943,7 +1943,13 @@ void (*extra_roots)(void);
void
performGC(void)
{
- GarbageCollect(GetRoots);
+ GarbageCollect(GetRoots,rtsFalse);
+}
+
+void
+performMajorGC(void)
+{
+ GarbageCollect(GetRoots,rtsTrue);
}
static void
@@ -1958,7 +1964,7 @@ performGCWithRoots(void (*get_roots)(void))
{
extra_roots = get_roots;
- GarbageCollect(AllRoots);
+ GarbageCollect(AllRoots,rtsFalse);
}
/* -----------------------------------------------------------------------------
diff --git a/ghc/rts/StgCRun.c b/ghc/rts/StgCRun.c
index 8f8c8db24c1e0ce8b18c949a11384cc23b2f4d15..31bd224cd479479b571ed5dffe99677bfaebc67e 100644
--- a/ghc/rts/StgCRun.c
+++ b/ghc/rts/StgCRun.c
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: StgCRun.c,v 1.15 2000/03/31 03:09:36 hwloidl Exp $
+ * $Id: StgCRun.c,v 1.16 2000/04/11 16:36:54 sewardj Exp $
*
* (c) The GHC Team, 1998-2000
*
@@ -72,12 +72,19 @@ extern StgThreadReturnCode StgRun(StgFunPtr f, StgRegTable *basereg)
memcpy((void *) jmp_environment, (void *) save_buf, sizeof(jmp_buf));
if (setjmp(jmp_environment) == 0) {
while ( 1 ) {
+StgFunPtr f_old;
IF_DEBUG(evaluator,
fprintf(stderr,"Jumping to ");
printPtr((P_)f);
fprintf(stderr,"\n");
);
+f_old = f;
f = (StgFunPtr) (f)();
+ if (!IS_CODE_PTR(f)) {
+fprintf ( stderr,"bad ptr given by %p %s\n", f_old, nameFromOPtr(f_old) );
+assert(IS_CODE_PTR(f));
+ }
+
}
}
/* Restore jmp_environment for previous call */
@@ -93,10 +100,17 @@ EXTFUN(StgReturn)
#else
+#define CHECK_STACK 0
+#define STACK_DETAILS 0
+
+static int enters = 0;
+
static void scanStackSeg ( W_* ptr, int nwords )
{
W_ w;
+#if CHECK_STACK
int nwords0 = nwords;
+#if STACK_DETAILS
while (nwords > 0) {
w = *ptr;
if (IS_ARG_TAG(w)) {
@@ -109,80 +123,104 @@ static void scanStackSeg ( W_* ptr, int nwords )
}
}
if (nwords < 0) fprintf(stderr, "erk: nwords < 0\n");
+#endif
checkStackChunk ( ptr, ptr-nwords0 );
+#endif
}
-
+extern StgFunPtr stg_enterStackTop;
extern StgThreadReturnCode StgRun(StgFunPtr f, StgRegTable *basereg)
{
char* nm;
while (1) {
-// #define STACK_DETAILS 0 // I like details -- HWL
-
-#if STACK_DETAILS
+#if CHECK_STACK
{
int i;
- StgWord* sp = basereg->rSp;
- StgWord* su = basereg->rSu;
StgTSO* tso = basereg->rCurrentTSO;
StgWord* sb = tso->stack + tso->stack_size;
+ StgWord* sp;
+ StgWord* su;
int ws;
- fprintf(stderr, "== SP = %p SU = %p\n", sp,su);
+ if (f == &stg_enterStackTop) {
+ sp = tso->sp;
+ su = tso->su;
+ } else {
+ sp = basereg->rSp;
+ su = basereg->rSu;
+ }
+
+#if STACK_DETAILS
+ fprintf(stderr,
+ "== SB = %p SP = %p(%p) SU = %p SpLim = %p(%p)\n",
+ sb, sp, tso->sp, su, basereg->rSpLim, tso->splim);
+#endif
if (su >= sb) goto postloop;
if (!sp || !su) goto postloop;
- //printStack ( sp, sb, su);
+ printStack ( sp, sb, su);
while (1) {
ws = su - sp;
switch (get_itbl((StgClosure*)su)->type) {
case STOP_FRAME:
scanStackSeg(sp,ws);
+#if STACK_DETAILS
fprintf(stderr, "S%d ",ws);
fprintf(stderr, "\n");
+#endif
goto postloop;
case UPDATE_FRAME:
scanStackSeg(sp,ws);
+#if STACK_DETAILS
fprintf(stderr,"U%d ",ws);
+#endif
sp = su + sizeofW(StgUpdateFrame);
su = ((StgUpdateFrame*)su)->link;
break;
case SEQ_FRAME:
scanStackSeg(sp,ws);
+#if STACK_DETAILS
fprintf(stderr,"Q%d ",ws);
+#endif
sp = su + sizeofW(StgSeqFrame);
su = ((StgSeqFrame*)su)->link;
break;
case CATCH_FRAME:
scanStackSeg(sp,ws);
+#if STACK_DETAILS
fprintf(stderr,"C%d ",ws);
+#endif
sp = su + sizeofW(StgCatchFrame);
su = ((StgCatchFrame*)su)->link;
break;
default:
fprintf(stderr, "?\nweird record on stack\n");
+ assert(0);
goto postloop;
}
}
postloop:
}
-#endif
-
+#endif
#if STACK_DETAILS
fprintf(stderr,"\n");
#endif
- fprintf(stderr,"-- enter: ");
+#if 1
+ fprintf(stderr,"-- enter %p ", f);
nm = nameFromOPtr ( f );
- if (nm)
- fprintf(stderr, "%s (%p)", nm, f); else
- printPtr((P_)f);
+ if (nm) fprintf(stderr, "%s", nm); else
+ printPtr((P_)f);
fprintf ( stderr, "\n");
+#endif
#if STACK_DETAILS
fprintf(stderr,"\n");
#endif
+ zzz:
+ if (enters % 1000 == 0) fprintf(stderr, "%d enters\n",enters);
+ enters++;
f = (StgFunPtr) (f)();
if (!f) break;
}
diff --git a/ghc/rts/Storage.h b/ghc/rts/Storage.h
index 17076bf8520ebe18a105f31d4b697b11d23b17b8..53f76f862c275723723f22432f14726086b23eb7 100644
--- a/ghc/rts/Storage.h
+++ b/ghc/rts/Storage.h
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: Storage.h,v 1.14 2000/01/13 14:34:05 hwloidl Exp $
+ * $Id: Storage.h,v 1.15 2000/04/11 16:36:54 sewardj Exp $
*
* (c) The GHC Team, 1998-1999
*
@@ -78,7 +78,7 @@ extern void PleaseStopAllocating(void);
MarkRoot(StgClosure *p) Returns the new location of the root.
-------------------------------------------------------------------------- */
-extern void GarbageCollect(void (*get_roots)(void));
+extern void GarbageCollect(void (*get_roots)(void),rtsBool force_major_gc);
extern StgClosure *MarkRoot(StgClosure *p);
/* -----------------------------------------------------------------------------