* included in the distribution.
*
* $RCSfile: compiler.c,v $
- * $Revision: 1.21 $
- * $Date: 2000/03/10 20:03:36 $
+ * $Revision: 1.28 $
+ * $Date: 2000/04/14 15:18:06 $
* ------------------------------------------------------------------------*/
-#include "prelude.h"
+#include "hugsbasictypes.h"
#include "storage.h"
#include "connect.h"
#include "errors.h"
* 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
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)) &&
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;
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 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 {
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.
*/
unless doRevertCAFs below is permanently TRUE.
*/
/* initScheduler(); */
-#ifdef CRUDE_PROFILING
+
+ /* 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
{
HaskellObj result; /* ignored */
- sighandler_t old_ctrlbrk;
SchedulerStatus status;
Bool doRevertCAFs = TRUE; /* do not change -- comment above */
- old_ctrlbrk = signal(SIGINT, eval_ctrlbrk);
- ASSERT(old_ctrlbrk != SIG_ERR);
+ HugsBreakAction brkOld = setBreakAction ( HugsRtsInterrupt );
+ nukeModule_needs_major_gc = TRUE;
status = rts_eval_(closureOfVar(v),10000,&result);
- signal(SIGINT,old_ctrlbrk);
+ setBreakAction ( brkOld );
fflush (stderr);
fflush (stdout);
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
}
case PREPREL :
case RESET : freeVars = NIL;
freeFuns = NIL;
+ lineNumber = 0;
freeBegin = mkOffset(0);
break;
projects / ghc-hetmet.git / blobdiff