[project @ 2000-01-14 14:57:08 by sewardj]

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

diff --git a/ghc/interpreter/compiler.c b/ghc/interpreter/compiler.c
index c70d56c..5ee1ae1 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.9 $
- * $Date: 1999/10/15 21:41:03 $
+ * $Revision: 1.17 $
+ * $Date: 2000/01/13 10:47:05 $
  * ------------------------------------------------------------------------*/
 
 #include "prelude.h"
@@ -22,6 +22,7 @@
 #include "errors.h"
 #include "Rts.h"                       /* for rts_eval and related stuff   */
 #include "RtsAPI.h"                    /* for rts_eval and related stuff   */
+#include "SchedAPI.h"                  /* for RevertCAFs                   */
 #include "Schedule.h"
 #include "link.h"
 
@@ -93,6 +94,9 @@ static List local addStgVar             Args((List,Pair));
 
 static Cell local translate(e)         /* Translate expression:            */
 Cell e; {
+#if 0
+    printf ( "translate: " );print(e,100);printf("\n");
+#endif
     switch (whatIs(e)) {
         case LETREC     : snd(snd(e)) = translate(snd(snd(e)));
                           return expandLetrec(e);
@@ -136,7 +140,9 @@ Cell e; {
         case STRCELL    :
         case BIGCELL    :
         case CHARCELL   : return e;
-
+#if IPARAM
+       case IPVAR      : return nameId;
+#endif
         case FINLIST    : mapOver(translate,snd(e));
                           return mkConsList(snd(e));
 
@@ -215,7 +221,15 @@ static List local transBinds(bs)        /* Translate list of bindings:     */
 List bs; {                              /* eliminating pattern matching on */
     List newBinds = NIL;                /* lhs of bindings.                */
     for (; nonNull(bs); bs=tl(bs)) {
+#if IPARAM
+       Cell v = fst(hd(bs));
+       while (isAp(v) && fst(v) == nameInd)
+           v = arg(v);
+       fst(hd(bs)) = v;
+       if (isVar(v)) {
+#else
         if (isVar(fst(hd(bs)))) {
+#endif
             mapProc(transAlt,snd(hd(bs)));
             newBinds = cons(hd(bs),newBinds);
         }
@@ -1475,43 +1489,46 @@ Void evalExp() {                    /* compile and run input expression    */
     /* Run thread (and any other runnable threads) */
 
     /* Re-initialise the scheduler - ToDo: do I need this? */
-    initScheduler();
+    /* JRS, 991118: on SM's advice, don't call initScheduler every time.
+       This causes an assertion failure in GC.c(revert_dead_cafs)
+       unless doRevertCAFs below is permanently TRUE.
+     */
+    /* initScheduler(); */
 #ifdef CRUDE_PROFILING
     cp_init();
 #endif
 
-    /* ToDo: don't really initScheduler every time.  fix */
     {
         HaskellObj      result; /* ignored */
         sighandler_t    old_ctrlbrk;
         SchedulerStatus status;
-        old_ctrlbrk    = signal(SIGINT, eval_ctrlbrk);
-        assert(old_ctrlbrk != SIG_ERR);
-        status         = rts_eval_(closureOfVar(v),10000,&result);
+        Bool            doRevertCAFs = TRUE;  /* do not change -- comment above */
+        old_ctrlbrk         = signal(SIGINT, eval_ctrlbrk);
+        ASSERT(old_ctrlbrk != SIG_ERR);
+        status              = rts_eval_(closureOfVar(v),10000,&result);
         signal(SIGINT,old_ctrlbrk);
+        fflush (stderr); 
+        fflush (stdout);
         switch (status) {
         case Deadlock:
-        case AllBlocked: /* I don't understand the distinction - ADR */
-                printf("{Deadlock}");
-                RevertCAFs();
+                printf("{Deadlock or Blackhole}");
+                if (doRevertCAFs) RevertCAFs();
                 break;
         case Interrupted:
                 printf("{Interrupted}");
-                RevertCAFs();
+                if (doRevertCAFs) RevertCAFs();
                 break;
         case Killed:
-                printf("{Killed}");
-                RevertCAFs();
+                printf("{Interrupted or Killed}");
+                if (doRevertCAFs) RevertCAFs();
                 break;
         case Success:
-         //fflush(stderr);fflush(stdout);
-         //fprintf(stderr, "\n\nFinal top-of-stack is\n" );
-         //printObj ( *(MainRegTable.rSp) );
-               RevertCAFs();
+               if (doRevertCAFs) RevertCAFs();
                 break;
         default:
                 internal("evalExp: Unrecognised SchedulerStatus");
         }
+        deleteAllThreads();
         fflush(stdout);
         fflush(stderr);
     }
@@ -1542,14 +1559,6 @@ Void compileDefns() {                  /* compile script definitions       */
     Target i = 0;
     List binds = NIL;
 
-    /* a nasty hack.  But I don't know an easier way to make */
-    /* these things appear.                                  */
-    if (lastModule() == modulePrelude) {
-       implementCfun ( nameCons, NIL );
-       implementCfun ( nameNil, NIL );
-       implementCfun ( nameUnit, NIL );
-    }
-
     {
         List vss;
         List vs;
@@ -1591,14 +1600,6 @@ Void compileDefns() {                  /* compile script definitions       */
 
     binds = addGlobals(binds);
     done();
-#if USE_HUGS_OPTIMIZER
-    if (optimise) {
-       t = length(binds);
-       setGoal("Simplifying",t);
-       optimiseTopBinds(binds);
-       done();
-    }
-#endif
     setGoal("Generating code",t);
     stgCGBinds(binds);
 
@@ -1646,20 +1647,17 @@ Pair p; {                               /* Should be merged with genDefns, */
 Void compiler(what)
 Int what; {
     switch (what) {
-        case INSTALL :
+        case PREPREL :
         case RESET   : freeVars      = NIL;
                        freeFuns      = NIL;
                        freeBegin     = mkOffset(0);
-                       //extraVars     = NIL;
-                       //numExtraVars  = 0;
-                       //localOffset   = 0;
-                       //localArity    = 0;
                        break;
 
         case MARK    : mark(freeVars);
                        mark(freeFuns);
-                       //mark(extraVars);
                        break;
+
+        case POSTPREL: break;
     }
 }