projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
[project @ 2000-01-14 14:57:08 by sewardj]
[ghc-hetmet.git]
/
ghc
/
interpreter
/
compiler.c
diff --git
a/ghc/interpreter/compiler.c
b/ghc/interpreter/compiler.c
index
c70d56c
..
5ee1ae1
100644
(file)
--- a/
ghc/interpreter/compiler.c
+++ b/
ghc/interpreter/compiler.c
@@
-11,8
+11,8
@@
* included in the distribution.
*
* $RCSfile: compiler.c,v $
* included in the distribution.
*
* $RCSfile: compiler.c,v $
- * $Revision: 1.9 $
- * $Date: 1999/10/15 21:41:03 $
+ * $Revision: 1.17 $
+ * $Date: 2000/01/13 10:47:05 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
* ------------------------------------------------------------------------*/
#include "prelude.h"
@@
-22,6
+22,7
@@
#include "errors.h"
#include "Rts.h" /* for rts_eval and related stuff */
#include "RtsAPI.h" /* for rts_eval and related stuff */
#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"
#include "Schedule.h"
#include "link.h"
@@
-93,6
+94,9
@@
static List local addStgVar Args((List,Pair));
static Cell local translate(e) /* Translate expression: */
Cell e; {
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);
switch (whatIs(e)) {
case LETREC : snd(snd(e)) = translate(snd(snd(e)));
return expandLetrec(e);
@@
-136,7
+140,9
@@
Cell e; {
case STRCELL :
case BIGCELL :
case CHARCELL : return 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));
case FINLIST : mapOver(translate,snd(e));
return mkConsList(snd(e));
@@
-215,7
+221,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)) {
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)))) {
if (isVar(fst(hd(bs)))) {
+#endif
mapProc(transAlt,snd(hd(bs)));
newBinds = cons(hd(bs),newBinds);
}
mapProc(transAlt,snd(hd(bs)));
newBinds = cons(hd(bs),newBinds);
}
@@
-1475,43
+1489,46
@@
Void evalExp() { /* compile and run input expression */
/* Run thread (and any other runnable threads) */
/* Re-initialise the scheduler - ToDo: do I need this? */
/* Run thread (and any other runnable threads) */
/* Re-initialise the scheduler - ToDo: do I need this? */
- initScheduler();
+ /* 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(); */
#ifdef CRUDE_PROFILING
cp_init();
#endif
#ifdef CRUDE_PROFILING
cp_init();
#endif
- /* ToDo: don't really initScheduler every time. fix */
{
HaskellObj result; /* ignored */
sighandler_t old_ctrlbrk;
SchedulerStatus status;
{
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);
+ Bool doRevertCAFs = TRUE; /* do not change -- comment above */
+ old_ctrlbrk = signal(SIGINT, eval_ctrlbrk);
+ ASSERT(old_ctrlbrk != SIG_ERR);
+ status = rts_eval_(closureOfVar(v),10000,&result);
signal(SIGINT,old_ctrlbrk);
signal(SIGINT,old_ctrlbrk);
+ fflush (stderr);
+ fflush (stdout);
switch (status) {
case Deadlock:
switch (status) {
case Deadlock:
- case AllBlocked: /* I don't understand the distinction - ADR */
- printf("{Deadlock}");
- RevertCAFs();
+ printf("{Deadlock or Blackhole}");
+ if (doRevertCAFs) RevertCAFs();
break;
case Interrupted:
printf("{Interrupted}");
break;
case Interrupted:
printf("{Interrupted}");
- RevertCAFs();
+ if (doRevertCAFs) RevertCAFs();
break;
case Killed:
break;
case Killed:
- printf("{Killed}");
- RevertCAFs();
+ printf("{Interrupted or Killed}");
+ if (doRevertCAFs) RevertCAFs();
break;
case Success:
break;
case Success:
- //fflush(stderr);fflush(stdout);
- //fprintf(stderr, "\n\nFinal top-of-stack is\n" );
- //printObj ( *(MainRegTable.rSp) );
- RevertCAFs();
+ if (doRevertCAFs) RevertCAFs();
break;
default:
internal("evalExp: Unrecognised SchedulerStatus");
}
break;
default:
internal("evalExp: Unrecognised SchedulerStatus");
}
+ deleteAllThreads();
fflush(stdout);
fflush(stderr);
}
fflush(stdout);
fflush(stderr);
}
@@
-1542,14
+1559,6
@@
Void compileDefns() { /* compile script definitions */
Target i = 0;
List binds = NIL;
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;
{
List vss;
List vs;
@@
-1591,14
+1600,6
@@
Void compileDefns() { /* compile script definitions */
binds = addGlobals(binds);
done();
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);
setGoal("Generating code",t);
stgCGBinds(binds);
@@
-1646,20
+1647,17
@@
Pair p; { /* Should be merged with genDefns, */
Void compiler(what)
Int what; {
switch (what) {
Void compiler(what)
Int what; {
switch (what) {
- case INSTALL :
+ case PREPREL :
case RESET : freeVars = NIL;
freeFuns = NIL;
freeBegin = mkOffset(0);
case RESET : freeVars = NIL;
freeFuns = NIL;
freeBegin = mkOffset(0);
- //extraVars = NIL;
- //numExtraVars = 0;
- //localOffset = 0;
- //localArity = 0;
break;
case MARK : mark(freeVars);
mark(freeFuns);
break;
case MARK : mark(freeVars);
mark(freeFuns);
- //mark(extraVars);
break;
break;
+
+ case POSTPREL: break;
}
}
}
}