[project @ 2000-04-14 15:18:05 by sewardj]
[ghc-hetmet.git] / ghc / interpreter / compiler.c
index a0481f0..20bc336 100644 (file)
@@ -4,83 +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.4 $
- * $Date: 1999/03/01 14:46:43 $
+ * $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 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
@@ -90,6 +87,9 @@ static Name local compileSelFunction    Args((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);
@@ -99,29 +99,34 @@ 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 EVAL_INSTANCES
-                          if (fst(e)==nameStrict)
-                              return nameIStrict;
-                          if (fst(e)==nameSeq)
-                              return nameISeq;
-#endif
                           if (isName(fst(e)) &&
                               isMfun(fst(e)) &&
                               mfunOf(fst(e))==0)
                               return translate(snd(e));
 
                           snd(e) = translate(snd(e));
+
                           return e;
 
-#if BIGNUMS
-        case POSNUM     :
-        case ZERONUM    :
-        case NEGNUM     : return e;
-#endif
-        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;
@@ -142,8 +147,11 @@ Cell e; {
         case INTCELL    :
         case FLOATCELL  :
         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));
 
@@ -189,7 +197,8 @@ Cell e; {
                                              nv));
                           }
 
-        default         : internal("translate");
+        default         : fprintf(stderr, "stuff=%d\n",whatIs(e));
+                          internal("translate");
     }
     return e;
 }
@@ -209,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));
 }
 
@@ -222,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);
         }
@@ -244,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;
+                      }
     }
 }
 
@@ -608,9 +635,7 @@ Cell pat; {                       /* test with pat.                        */
 
         case STRCELL   :
         case CHARCELL  :
-#if NPLUSK
         case ADDPAT    :
-#endif
         case TUPLE     :
         case NAME      : return pat;
 
@@ -626,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));
@@ -697,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));
@@ -800,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);
 
@@ -828,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);
 
@@ -846,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 {
@@ -927,14 +951,7 @@ Cell e;  {                             /* e  = expr to transform           */
 
         case AP       : return pmcPair(co,sc,e);
 
-#if BIGNUMS
-        case POSNUM   :
-        case ZERONUM  :
-        case NEGNUM   :
-#endif
-#if NPLUSK
         case ADDPAT   :
-#endif
 #if TREX
         case EXT      :
 #endif
@@ -942,6 +959,7 @@ Cell e;  {                             /* e  = expr to transform           */
         case NAME     :
         case CHARCELL :
         case INTCELL  :
+        case BIGCELL  :
         case FLOATCELL:
         case STRCELL  : break;
 
@@ -1302,11 +1320,12 @@ tidyHd: switch (whatIs(p=hd(maPats(ma)))) {
                              return FALSE;
 
             case STRCELL   : {   String s = textToStr(textOf(p));
-                                 for (p=NIL; *s!='\0'; ++s)
+                                 for (p=NIL; *s!='\0'; ++s) {
                                      if (*s!='\\' || *++s=='\\')
                                          p = ap(consChar(*s),p);
                                      else
                                          p = ap(consChar('\0'),p);
+                                 }
                                  hd(maPats(ma)) = revOnto(p,nameNil);
                              }
                              return FALSE;
@@ -1339,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));
@@ -1383,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");
@@ -1403,18 +1414,12 @@ 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)))
         return isFloat(arg(d2)) && floatOf(arg(d1))==floatOf(arg(d2));
-#if BIGNUMS
-    if (isBignum(arg(d1)))
-        return isBignum(arg(d2)) && bigCmp(arg(d1),arg(d2))==0;
-#endif
     internal("eqNumDiscr");
     return FALSE;/*NOTREACHED*/
 }
@@ -1452,7 +1457,7 @@ List binds; {
 
 static List addGlobals( List binds )
 {
-    /* stgGlobals = pieces of code generated for selectors, tuples, etc */
+    /* stgGlobals = list of top-level STG binds */
     for(;nonNull(stgGlobals);stgGlobals=tl(stgGlobals)) {
         StgVar bind = snd(hd(stgGlobals));
         if (nonNull(stgVarBody(bind))) {
@@ -1463,7 +1468,7 @@ static List addGlobals( List binds )
 }
 
 
-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.
      */
@@ -1473,51 +1478,104 @@ Void evalExp() {                    /* compile and run input expression    */
     name(n).stgVar = v;
     compiler(RESET);
     e = pmcTerm(0,NIL,translate(inputExpr));
-    stgDefn(n,0,e); //ppStg(name(n).stgVar);
+    stgDefn(n,0,e);
     inputExpr = NIL;
     stgCGBinds(addGlobals(singleton(v)));
     
     /* Run thread (and any other runnable threads) */
 
     /* Re-initialise the scheduler - ToDo: do I need this? */
-    initScheduler();
-    /* ToDo: don't really initScheduler every time.  fix */
+    /* 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
+
     {
-        HaskellObj result; /* ignored */
-        SchedulerStatus status = rts_eval_(closureOfVar(v),10000,&result);
+        HaskellObj      result; /* ignored */
+        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); 
+        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:
-                /* Nothing to do */
                 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
+    cp_show();
+#   endif
+
 }
 
-static List local addStgVar( List binds, Pair bind ); /* todo */
 
 static List local addStgVar( List binds, Pair bind )
 {
     StgVar nv = mkStgVar(NIL,NIL);
     Text   t  = textOf(fst(bind));
     Name   n  = findName(t);
-    //printf ( "addStgVar %s\n", textToStr(t));
+
     if (isNull(n)) {                   /* Lookup global name - the only way*/
         n = newName(t,NIL);            /* this (should be able to happen)  */
     }                                  /* is with new global var introduced*/
@@ -1532,15 +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) {
-       //printf ( "------ Adding cons (:) [] () \n" );
-       implementCfun ( nameCons, NIL );
-       implementCfun ( nameNil, NIL );
-       implementCfun ( nameUnit, NIL );
-    }
-
     {
         List vss;
         List vs;
@@ -1563,7 +1612,7 @@ Void compileDefns() {                  /* compile script definitions       */
         }
     }
 
-    setGoal("Compiling",t);
+    setGoal("Translating",t);
     /* do valDefns before everything else so that all stgVar's get added. */
     for (; nonNull(valDefns); valDefns=tl(valDefns)) {
         hd(valDefns) = transBinds(hd(valDefns));
@@ -1580,12 +1629,9 @@ Void compileDefns() {                  /* compile script definitions       */
         soFar(i++);
     }
 
-    /* binds=revOnto(binds,NIL); *//* ToDo: maintain compilation order?? */
     binds = addGlobals(binds);
-#if USE_HUGS_OPTIMIZER
-    mapProc(optimiseBind,binds);
-#error optimiser
-#endif
+    done();
+    setGoal("Generating code",t);
     stgCGBinds(binds);
 
     done();
@@ -1597,20 +1643,6 @@ Pair bind; {
     List defs  = snd(bind);
     Int  arity = length(fst(hd(defs)));
     assert(isName(n));
-
-    //{ Cell cc;
-    //  printf ( "compileGlobalFunction %s\n", textToStr(name(n).text));
-    //  cc = defs;
-    //  while (nonNull(cc)) {
-    //     printExp(stdout, fst(hd(cc)));
-    //     printf ( "\n   = " );
-    //     printExp(stdout, snd(hd(cc)));
-    //     printf( "\n" );
-    //     cc = tl(cc);
-    //  }
-    //  printf ( "\n\n\n" );
-    //}
-
     compiler(RESET);
     stgDefn(n,arity,match(arity,altsMatch(1,arity,NIL,defs)));
 }
@@ -1619,20 +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)));
-
-    //{ Cell cc;
-    //  printf ( "compileGenFunction %s\n", textToStr(name(n).text));
-    //  cc = defs;
-    //  while (nonNull(cc)) {
-    //     printExp(stdout, fst(hd(cc)));
-    //     printf ( "\n   = " );
-    //     printExp(stdout, snd(hd(cc)));
-    //     printf( "\n" );
-    //     cc = tl(cc);
-    //  }
-    //  printf ( "\n\n\n" );
-    //}
-
+#if 0
+    printf ( "compGenFn: " );print(defs,100);printf("\n");
+#endif
     compiler(RESET);
     currentName = n;
     mapProc(transAlt,defs);
@@ -1660,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;
     }
 }