[project @ 2000-04-14 15:18:05 by sewardj]

[ghc-hetmet.git] / ghc / interpreter / compiler.c

diff --git a/ghc/interpreter/compiler.c b/ghc/interpreter/compiler.c
index 4ab3144..20bc336 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.25 $
- * $Date: 2000/03/24 14:32:03 $
+ * $Revision: 1.28 $
+ * $Date: 2000/04/14 15:18:06 $
  * ------------------------------------------------------------------------*/
 
 #include "hugsbasictypes.h"
@@ -847,7 +847,7 @@ List lds; {
                          }
 
         case DICTVAR   : /* shouldn't really occur */
-                         assert(0); /* so let's test for it then! ADR */
+         //assert(0); /* so let's test for it then! ADR */
         case VARIDCELL :
         case VAROPCELL : return addEqn(pat,expr,lds);
 
@@ -865,10 +865,15 @@ List lds; {
                          /* intentional fall-thru */
         case TUPLE     : {   List ps = getArgs(pat);
 
+                             /* get rid of leading dictionaries in args */
+                             if (isName(c) && isCfun(c)) {
+                                Int i = numQualifiers(name(c).type);
+                                for (; i > 0; i--) ps = tl(ps);
+                             }
+
                              if (nonNull(ps)) {
                                  Cell nv, sel;
                                  Int  i;
-
                                  if (isVar(expr) || isName(expr))
                                      nv  = expr;
                                  else {
@@ -1485,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
@@ -1494,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); 
@@ -1501,29 +1528,44 @@ Void evalExp ( void ) {             /* compile and run input expression    */
         switch (status) {
         case Deadlock:
                 printf("{Deadlock or Blackhole}");
-                if (doRevertCAFs) RevertCAFs();
                 break;
         case Interrupted:
                 printf("{Interrupted}");
-                if (doRevertCAFs) RevertCAFs();
                 break;
         case Killed:
                 printf("{Interrupted or Killed}");
-                if (doRevertCAFs) RevertCAFs();
                 break;
         case Success:
-               if (doRevertCAFs) RevertCAFs();
                 break;
         default:
                 internal("evalExp: Unrecognised SchedulerStatus");
         }
-        deleteAllThreads();
+
+        /* Begin heap cleanup sequence */
+        do {
+           /* fprintf ( stderr, "finalisation loop START\n" ); */
+           finishAllThreads();
+           finalizeWeakPointersNow();
+           /* fprintf ( stderr, "finalisation loop END %d\n", 
+                                howManyThreadsAvail() ); */
+        } 
+           while (howManyThreadsAvail() > 0);
+
+        RevertCAFs();
+        performMajorGC();
+        if (combined && SPT_size != 0) {
+           FPrintf ( stderr, 
+             "hugs: fatal: stable pointers are not yet allowed in combined mode" );
+           internal("evalExp");
+        }
+        /* End heap cleanup sequence */
+
         fflush(stdout);
         fflush(stderr);
     }
-#ifdef CRUDE_PROFILING
+#   ifdef CRUDE_PROFILING
     cp_show();
-#endif
+#   endif
 
 }