[project @ 2000-04-14 15:18:05 by sewardj]
[ghc-hetmet.git] / ghc / interpreter / compiler.c
index 97e3eef..20bc336 100644 (file)
@@ -4,85 +4,80 @@
  * `kernel' language, elimination of pattern matching and translation to
  * super combinators (lambda lifting).
  *
- * Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale
- * Haskell Group 1994-99, and is distributed as Open Source software
- * under the Artistic License; see the file "Artistic" that is included
- * in the distribution for details.
+ * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
+ * Yale Haskell Group, and the Oregon Graduate Institute of Science and
+ * Technology, 1994-1999, All rights reserved.  It is distributed as
+ * free software under the license in the file "License", which is
+ * included in the distribution.
  *
  * $RCSfile: compiler.c,v $
- * $Revision: 1.7 $
- * $Date: 1999/06/07 17:22:46 $
+ * $Revision: 1.28 $
+ * $Date: 2000/04/14 15:18:06 $
  * ------------------------------------------------------------------------*/
 
-#include "prelude.h"
+#include "hugsbasictypes.h"
 #include "storage.h"
-#include "backend.h"
 #include "connect.h"
 #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"
-
-Addr inputCode;                        /* Addr of compiled code for expr   */
-static Name currentName;               /* Top level name being processed   */
-#if DEBUG_CODE
-Bool   debugCode     = FALSE;          /* TRUE => print G-code to screen   */
-#endif
-
-
 
 /* --------------------------------------------------------------------------
  * Local function prototypes:
  * ------------------------------------------------------------------------*/
 
-static Cell local translate             Args((Cell));
-static Void local transPair             Args((Pair));
-static Void local transTriple           Args((Triple));
-static Void local transAlt              Args((Cell));
-static Void local transCase             Args((Cell));
-static List local transBinds            Args((List));
-static Cell local transRhs              Args((Cell));
-static Cell local mkConsList            Args((List));
-static Cell local expandLetrec          Args((Cell));
-static Cell local transComp             Args((Cell,List,Cell));
-static Cell local transDo               Args((Cell,Cell,List));
-static Cell local transConFlds          Args((Cell,List));
-static Cell local transUpdFlds          Args((Cell,List,List));
-
-static Cell local refutePat             Args((Cell));
-static Cell local refutePatAp           Args((Cell));
-static Cell local matchPat              Args((Cell));
-static List local remPat                Args((Cell,Cell,List));
-static List local remPat1               Args((Cell,Cell,List));
-
-static Cell local pmcTerm               Args((Int,List,Cell));
-static Cell local pmcPair               Args((Int,List,Pair));
-static Cell local pmcTriple             Args((Int,List,Triple));
-static Cell local pmcVar                Args((List,Text));
-static Void local pmcLetrec             Args((Int,List,Pair));
-static Cell local pmcVarDef             Args((Int,List,List));
-static Void local pmcFunDef             Args((Int,List,Triple));
-static List local altsMatch             Args((Int,Int,List,List));
-static Cell local match                 Args((Int,List));
-static Cell local joinMas               Args((Int,List));
-static Bool local canFail               Args((Cell));
-static List local addConTable           Args((Cell,Cell,List));
-static Void local advance               Args((Int,Int,Cell));
-static Bool local emptyMatch            Args((Cell));
-static Cell local maDiscr               Args((Cell));
-static Bool local isNumDiscr            Args((Cell));
-static Bool local eqNumDiscr            Args((Cell,Cell));
+static Cell local translate             ( Cell );
+static Void local transPair             ( Pair );
+static Void local transTriple           ( Triple );
+static Void local transAlt              ( Cell );
+static Void local transCase             ( Cell );
+static List local transBinds            ( List );
+static Cell local transRhs              ( Cell );
+static Cell local mkConsList            ( List );
+static Cell local expandLetrec          ( Cell );
+static Cell local transComp             ( Cell,List,Cell );
+static Cell local transDo               ( Cell,Cell,List );
+static Cell local transConFlds          ( Cell,List );
+static Cell local transUpdFlds          ( Cell,List,List );
+
+static Cell local refutePat             ( Cell );
+static Cell local refutePatAp           ( Cell );
+static Cell local matchPat              ( Cell );
+static List local remPat                ( Cell,Cell,List );
+static List local remPat1               ( Cell,Cell,List );
+
+static Cell local pmcTerm               ( Int,List,Cell );
+static Cell local pmcPair               ( Int,List,Pair );
+static Cell local pmcTriple             ( Int,List,Triple );
+static Cell local pmcVar                ( List,Text );
+static Void local pmcLetrec             ( Int,List,Pair );
+static Cell local pmcVarDef             ( Int,List,List );
+static Void local pmcFunDef             ( Int,List,Triple );
+static List local altsMatch             ( Int,Int,List,List );
+static Cell local match                 ( Int,List );
+static Cell local joinMas               ( Int,List );
+static Bool local canFail               ( Cell );
+static List local addConTable           ( Cell,Cell,List );
+static Void local advance               ( Int,Int,Cell );
+static Bool local emptyMatch            ( Cell );
+static Cell local maDiscr               ( Cell );
+static Bool local isNumDiscr            ( Cell );
+static Bool local eqNumDiscr            ( Cell,Cell );
 #if TREX
-static Bool local isExtDiscr            Args((Cell));
-static Bool local eqExtDiscr            Args((Cell,Cell));
+static Bool local isExtDiscr            ( Cell );
+static Bool local eqExtDiscr            ( Cell,Cell );
 #endif
 
-static Void local compileGlobalFunction Args((Pair));
-static Void local compileGenFunction    Args((Name));
-static Name local compileSelFunction    Args((Pair));
-static List local addStgVar             Args((List,Pair));
+static Void local compileGlobalFunction ( Pair );
+static Void local compileGenFunction    ( Name );
+static Name local compileSelFunction    ( Pair );
+static List local addStgVar             ( List,Pair );
 
+static Name currentName;               /* Top level name being processed   */
+static Int  lineNumber = 0;            /* previously discarded line number */
 
 /* --------------------------------------------------------------------------
  * Translation:    Convert input expressions into a less complex language
@@ -92,6 +87,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);
@@ -101,6 +99,9 @@ Cell e; {
 
         case AP         : fst(e) = translate(fst(e));
 
+         /* T [id <exp>]        ==> T[<exp>]
+          * T [indirect <exp> ] ==> T[<exp>]
+          */
                           if (fst(e)==nameId || fst(e)==nameInd)
                               return translate(snd(e));
                           if (isName(fst(e)) &&
@@ -109,10 +110,23 @@ Cell e; {
                               return translate(snd(e));
 
                           snd(e) = translate(snd(e));
+
                           return e;
 
-        case NAME       : if (e==nameOtherwise)
+        case NAME       : 
+
+         /* T [otherwise] ==> True
+          */
+
+                          if (e==nameOtherwise)
                               return nameTrue;
+         /* T [assert]    ==> T[assertError "<location info>"]
+          */
+                          if (flagAssert && e==nameAssert) {
+                            Cell str = errAssert(lineNumber);
+                            return (ap(nameAssertError,str));
+                          }
+
                           if (isCfun(e)) {
                               if (isName(name(e).defn))
                                   return name(e).defn;
@@ -135,7 +149,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));
 
@@ -181,7 +197,8 @@ Cell e; {
                                              nv));
                           }
 
-        default         : fprintf(stderr, "stuff=%d\n",whatIs(e));internal("translate");
+        default         : fprintf(stderr, "stuff=%d\n",whatIs(e));
+                          internal("translate");
     }
     return e;
 }
@@ -201,6 +218,9 @@ Triple tr; {                           /* triple of expressions.           */
 
 static Void local transAlt(e)          /* Translate alt:                   */
 Cell e; {                              /* ([Pat], Rhs) ==> ([Pat], Rhs')   */
+#if 0
+    printf ( "transAlt:  " );print(snd(e),100);printf("\n");
+#endif
     snd(e) = transRhs(snd(e));
 }
 
@@ -214,7 +234,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);
         }
@@ -236,7 +264,14 @@ Cell rhs; {
                        mapProc(transPair,snd(rhs));
                        return rhs;
 
-        default      : return translate(snd(rhs));  /* discard line number */
+        default      : {
+                        Cell tmp;
+                        Int prev = lineNumber;
+                        lineNumber = intOf(fst(rhs));
+                        tmp = translate(snd(rhs));  /* discard line number */
+                        lineNumber = prev;
+                        return tmp;
+                      }
     }
 }
 
@@ -600,9 +635,7 @@ Cell pat; {                       /* test with pat.                        */
 
         case STRCELL   :
         case CHARCELL  :
-#if NPLUSK
         case ADDPAT    :
-#endif
         case TUPLE     :
         case NAME      : return pat;
 
@@ -618,10 +651,8 @@ Cell p; {
     Cell h = getHead(p);
     if (h==nameFromInt || h==nameFromInteger || h==nameFromDouble)
         return p;
-#if NPLUSK
     else if (whatIs(h)==ADDPAT)
         return ap(fun(p),refutePat(arg(p)));
-#endif
 #if TREX
     else if (isExt(h)) {
         Cell pf = refutePat(extField(p));
@@ -689,10 +720,8 @@ Cell pat; {                     /* replaces parts of pattern that do not   */
                              if (h==nameFromInt     ||
                                  h==nameFromInteger || h==nameFromDouble)
                                  return WILDCARD;
-#if NPLUSK
                              else if (whatIs(h)==ADDPAT)
                                  return pat;
-#endif
 #if TREX
                              else if (isExt(h)) {
                                  Cell pf = matchPat(extField(pat));
@@ -792,14 +821,12 @@ List lds; {
                              return remPat(snd(pat),nv,lds);
                          }
 
-#if NPLUSK
         case ADDPAT    : return remPat1(arg(pat),       /* n + k = expr */
                                         ap(ap(ap(namePmSub,
                                                  arg(fun(pat))),
                                                  mkInt(snd(fun(fun(pat))))),
                                                  expr),
                                         lds);
-#endif
 
         case FINLIST   : return remPat1(mkConsList(snd(pat)),expr,lds);
 
@@ -820,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);
 
@@ -838,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 {
@@ -919,9 +951,7 @@ Cell e;  {                             /* e  = expr to transform           */
 
         case AP       : return pmcPair(co,sc,e);
 
-#if NPLUSK
         case ADDPAT   :
-#endif
 #if TREX
         case EXT      :
 #endif
@@ -1328,10 +1358,8 @@ Cell ma; {                      /* match, ma.                              */
     Cell h = getHead(p);
     switch (whatIs(h)) {
         case CONFLDS : return fst(snd(p));
-#if NPLUSK
         case ADDPAT  : arg(fun(p)) = translate(arg(fun(p)));
                        return fun(p);
-#endif
 #if TREX
         case EXT     : h      = fun(fun(p));
                        arg(h) = translate(arg(h));
@@ -1372,18 +1400,12 @@ Cell d; {
         case CHARCELL  : return 0;
 #if TREX
         case AP        : switch (whatIs(fun(d))) {
-#if NPLUSK
                              case ADDPAT : return 1;
-#endif
                              case EXT    : return 2;
                              default     : return 0;
                          }
 #else
-#if NPLUSK
         case AP        : return (whatIs(fun(d))==ADDPAT) ? 1 : 0;
-#else
-        case AP        : return 0;      /* must be an Int or Float lit     */
-#endif
 #endif
     }
     internal("discrArity");
@@ -1392,10 +1414,8 @@ Cell d; {
 
 static Bool local eqNumDiscr(d1,d2)     /* Determine whether two numeric   */
 Cell d1, d2; {                          /* descriptors have same value     */
-#if NPLUSK
     if (whatIs(fun(d1))==ADDPAT)
         return whatIs(fun(d2))==ADDPAT && snd(fun(d1))==snd(fun(d2));
-#endif
     if (isInt(arg(d1)))
         return isInt(arg(d2)) && intOf(arg(d1))==intOf(arg(d2));
     if (isFloat(arg(d1)))
@@ -1447,17 +1467,8 @@ static List addGlobals( List binds )
     return binds;
 }
 
-typedef void (*sighandler_t)(int);
-void eval_ctrlbrk ( int dunnowhat )
-{
-   interruptStgRts();
-   /* reinstall the signal handler so that further interrupts which
-      happen before the thread can return to the scheduler, lead back
-      here rather than invoking the previous break handler. */
-   signal(SIGINT, eval_ctrlbrk);
-}
 
-Void evalExp() {                    /* compile and run input expression    */
+Void evalExp ( void ) {             /* compile and run input expression    */
     /* ToDo: this name (and other names generated during pattern match?)
      * get inserted in the symbol table but never get removed.
      */
@@ -1474,46 +1485,87 @@ Void evalExp() {                    /* compile and run input expression    */
     /* Run thread (and any other runnable threads) */
 
     /* Re-initialise the scheduler - ToDo: do I need this? */
-    initScheduler();
-#ifdef CRUDE_PROFILING
+    /* 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(); */
+
+    /* 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
+#   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);
-        signal(SIGINT,old_ctrlbrk);
+        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); 
+        fflush (stdout);
         switch (status) {
         case Deadlock:
-        case AllBlocked: /* I don't understand the distinction - ADR */
-                printf("{Deadlock}");
-                RevertCAFs();
+                printf("{Deadlock or Blackhole}");
                 break;
         case Interrupted:
                 printf("{Interrupted}");
-                RevertCAFs();
                 break;
         case Killed:
-                printf("{Killed}");
-                RevertCAFs();
+                printf("{Interrupted or Killed}");
                 break;
         case Success:
-               RevertCAFs();
                 break;
         default:
                 internal("evalExp: Unrecognised SchedulerStatus");
         }
+
+        /* 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
 
 }
 
@@ -1538,14 +1590,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;
@@ -1587,14 +1631,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);
 
@@ -1615,6 +1651,9 @@ static Void local compileGenFunction(n) /* Produce code for internally     */
 Name n; {                               /* generated function              */
     List defs  = name(n).defn;
     Int  arity = length(fst(hd(defs)));
+#if 0
+    printf ( "compGenFn: " );print(defs,100);printf("\n");
+#endif
     compiler(RESET);
     currentName = n;
     mapProc(transAlt,defs);
@@ -1642,20 +1681,18 @@ Pair p; {                               /* Should be merged with genDefns, */
 Void compiler(what)
 Int what; {
     switch (what) {
-        case INSTALL :
+        case PREPREL :
         case RESET   : freeVars      = NIL;
                        freeFuns      = NIL;
+                      lineNumber    = 0;
                        freeBegin     = mkOffset(0);
-                       //extraVars     = NIL;
-                       //numExtraVars  = 0;
-                       //localOffset   = 0;
-                       //localArity    = 0;
                        break;
 
         case MARK    : mark(freeVars);
                        mark(freeFuns);
-                       //mark(extraVars);
                        break;
+
+        case POSTPREL: break;
     }
 }