* `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.3 $
- * $Date: 1999/02/03 17:08:26 $
+ * $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"
-
-/*#define DEBUG_SHOWSC*/ /* Must also be set in output.c */
-
-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 Cell local lift Args((Int,List,Cell));
-static Void local liftPair Args((Int,List,Pair));
-static Void local liftTriple Args((Int,List,Triple));
-static Void local liftAlt Args((Int,List,Cell));
-static Void local liftNumcase Args((Int,List,Triple));
-static Cell local liftVar Args((List,Cell));
-static Cell local liftLetrec Args((Int,List,Cell));
-static Void local liftFundef Args((Int,List,Triple));
-static Void local solve Args((List));
-
-static Cell local preComp Args((Cell));
-static Cell local preCompPair Args((Pair));
-static Cell local preCompTriple Args((Triple));
-static Void local preCompCase Args((Pair));
-static Cell local preCompOffset Args((Int));
-
-static Void local compileGlobalFunction Args((Pair));
-static Void local compileGenFunction Args((Name));
-static Name local compileSelFunction Args((Pair));
-static Void local newGlobalFunction Args((Name,Int,List,Int,Cell));
+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
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);
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;
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));
nv));
}
- default : internal("translate");
+ default : fprintf(stderr, "stuff=%d\n",whatIs(e));
+ internal("translate");
}
return e;
}
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));
}
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);
}
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;
+ }
}
}
case STRCELL :
case CHARCELL :
-#if NPLUSK
case ADDPAT :
-#endif
case TUPLE :
case NAME : return pat;
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));
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));
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);
}
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);
/* 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 {
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
case NAME :
case CHARCELL :
case INTCELL :
+ case BIGCELL :
case FLOATCELL:
case STRCELL : break;
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;
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));
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");
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*/
}
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))) {
}
-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.
*/
Name n = newName(inventText(),NIL);
+ Cell e;
StgVar v = mkStgVar(NIL,NIL);
name(n).stgVar = v;
compiler(RESET);
- stgDefn(n,0,pmcTerm(0,NIL,translate(inputExpr)));
+ e = pmcTerm(0,NIL,translate(inputExpr));
+ 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 )
{
Void compileDefns() { /* compile script definitions */
Target t = length(valDefns) + length(genDefns) + length(selDefns);
Target i = 0;
-
List binds = NIL;
+
{
List vss;
List vs;
}
}
- 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));
soFar(i++);
}
- /* binds=revOnto(binds,NIL); *//* ToDo: maintain compilation order?? */
binds = addGlobals(binds);
-#if USE_HUGS_OPTIMIZER
- mapProc(optimiseBind,binds);
-#endif
+ done();
+ setGoal("Generating code",t);
stgCGBinds(binds);
done();
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);
}
-#if 0
-I think this is 98-specific.
-static Void local newGlobalFunction(n,arity,fvs,co,e)
-Name n;
-Int arity;
-List fvs;
-Int co;
-Cell e; {
-#ifdef DEBUG_SHOWSC
- extern Void printSc Args((FILE*, Text, Int, Cell));
-#endif
- extraVars = fvs;
- numExtraVars = length(extraVars);
- localOffset = co;
- localArity = arity;
- name(n).arity = arity+numExtraVars;
- e = preComp(e);
-#ifdef DEBUG_SHOWSC
- if (debugCode) {
- printSc(stdout,name(n).text,name(n).arity,e);
- }
-#endif
- name(n).code = codeGen(n,name(n).arity,e);
-}
-#endif
-
/* --------------------------------------------------------------------------
* Compiler control:
* ------------------------------------------------------------------------*/
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;
}
}