* included in the distribution.
*
* $RCSfile: compiler.c,v $
- * $Revision: 1.25 $
- * $Date: 2000/03/24 14:32:03 $
+ * $Revision: 1.31 $
+ * $Date: 2000/05/10 09:00:20 $
* ------------------------------------------------------------------------*/
#include "hugsbasictypes.h"
#include "RtsAPI.h" /* for rts_eval and related stuff */
#include "SchedAPI.h" /* for RevertCAFs */
#include "Schedule.h"
+#include "Weak.h" /* for finalizeWeakPointersNow */
/* --------------------------------------------------------------------------
* Local function prototypes:
}
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 {
/*-------------------------------------------------------------------------*/
-
-
-/* --------------------------------------------------------------------------
- * STG stuff
- * ------------------------------------------------------------------------*/
-
-static Void local stgCGBinds( List );
-
-static Void local stgCGBinds(binds)
-List binds; {
- cgBinds(binds);
-}
-
/* --------------------------------------------------------------------------
* Main entry points to compiler:
* ------------------------------------------------------------------------*/
-static List addGlobals( List binds )
+Void evalExp ( void ) /* compile and run input expression */
{
- /* stgGlobals = list of top-level STG binds */
- for(;nonNull(stgGlobals);stgGlobals=tl(stgGlobals)) {
- StgVar bind = snd(hd(stgGlobals));
- if (nonNull(stgVarBody(bind))) {
- binds = cons(bind,binds);
- }
- }
- return binds;
-}
-
-
-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;
+ Name n = newName(inventText(),NIL);
+ StgVar v = mkStgVar(NIL,NIL);
+ name(n).closure = v;
+ module(currentModule).codeList = singleton(n);
compiler(RESET);
e = pmcTerm(0,NIL,translate(inputExpr));
stgDefn(n,0,e);
inputExpr = NIL;
- stgCGBinds(addGlobals(singleton(v)));
+ cgModule ( name(n).mod );
/* Run thread (and any other runnable threads) */
unless doRevertCAFs below is permanently TRUE.
*/
/* initScheduler(); */
-# ifdef CRUDE_PROFILING
- cp_init();
-# endif
+ /* 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.
+ */
{
HaskellObj result; /* ignored */
SchedulerStatus status;
Bool doRevertCAFs = TRUE; /* do not change -- comment above */
HugsBreakAction brkOld = setBreakAction ( HugsRtsInterrupt );
- status = rts_eval_(closureOfVar(v),10000,&result);
+ nukeModule_needs_major_gc = TRUE;
+ status = rts_eval_(cptrOf(name(n).closure),10000,&result);
setBreakAction ( brkOld );
fflush (stderr);
fflush (stdout);
switch (status) {
case Deadlock:
- printf("{Deadlock or Blackhole}");
- if (doRevertCAFs) RevertCAFs();
+ printf("{Deadlock or Blackhole}"); fflush(stdout);
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
- cp_show();
-#endif
-
-}
-
-
-static List local addStgVar( List binds, Pair bind )
-{
- StgVar nv = mkStgVar(NIL,NIL);
- Text t = textOf(fst(bind));
- Name n = findName(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*/
- /* after type check; e.g. remPat1 */
- name(n).stgVar = nv;
- return cons(nv,binds);
}
Void compileDefns() { /* compile script definitions */
Target t = length(valDefns) + length(genDefns) + length(selDefns);
Target i = 0;
- List binds = NIL;
{
List vss;
List vs;
- for(vs=genDefns; nonNull(vs); vs=tl(vs)) {
- Name n = hd(vs);
- StgVar nv = mkStgVar(NIL,NIL);
- assert(isName(n));
- name(n).stgVar = nv;
- binds = cons(nv,binds);
+ for (vs = genDefns; nonNull(vs); vs = tl(vs)) {
+ Name n = hd(vs);
+ StgVar nv = mkStgVar(NIL,NIL);
+ name(n).closure = nv;
+ addToCodeList ( currentModule, n );
}
- for(vss=selDefns; nonNull(vss); vss=tl(vss)) {
- for(vs=hd(vss); nonNull(vs); vs=tl(vs)) {
- Pair p = hd(vs);
- Name n = fst(p);
- StgVar nv = mkStgVar(NIL,NIL);
- assert(isName(n));
- name(n).stgVar = nv;
- binds = cons(nv,binds);
+ for (vss = selDefns; nonNull(vss); vss = tl(vss)) {
+ for (vs = hd(vss); nonNull(vs); vs = tl(vs)) {
+ Pair p = hd(vs);
+ Name n = fst(p);
+ StgVar nv = mkStgVar(NIL,NIL);
+ name(n).closure = nv;
+ addToCodeList ( currentModule, n );
}
}
}
setGoal("Translating",t);
/* do valDefns before everything else so that all stgVar's get added. */
for (; nonNull(valDefns); valDefns=tl(valDefns)) {
+ List qq;
hd(valDefns) = transBinds(hd(valDefns));
- mapAccum(addStgVar,binds,hd(valDefns));
- mapProc(compileGlobalFunction,hd(valDefns));
+ for (qq = hd(valDefns); nonNull(qq); qq = tl(qq)) {
+ Name n = findName ( textOf(fst(hd(qq))) );
+ StgVar nv = mkStgVar(NIL,NIL);
+ assert(nonNull(n));
+ name(n).closure = nv;
+ addToCodeList ( currentModule, n );
+ compileGlobalFunction(hd(qq));
+ }
soFar(i++);
}
for (; nonNull(genDefns); genDefns=tl(genDefns)) {
soFar(i++);
}
- binds = addGlobals(binds);
done();
setGoal("Generating code",t);
- stgCGBinds(binds);
+ cgModule ( currentModule );
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);
projects / ghc-hetmet.git / blobdiff