[project @ 2000-04-11 16:36:53 by sewardj]

Ensure that when Hugs decides to unload a module (nukeModule()), there are
no closures anywhere in the system which refers to infotables defined
in that module.  That means reverting all CAFs and doing a major GC
prior to deleting the module.  A flag is used to avoid redundant GCs.

diff --git a/ghc/includes/StgStorage.h b/ghc/includes/StgStorage.h
index 86dd60b..a6c88f5 100644 (file)
--- 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 ac85831..c6b1cce 100644 (file)
--- 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 401168f..95627f4 100644 (file)
--- 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 4949a40..881d273 100644 (file)
--- 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 3ed912e..f430814 100644 (file)
--- 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 212620e..9b0e962 100644 (file)
--- 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 04ecaf0..50009f2 100644 (file)
--- 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 8f8c8db..31bd224 100644 (file)
--- 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 17076bf..53f76f8 100644 (file)
--- 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);
 
 /* -----------------------------------------------------------------------------