X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Finterpreter%2Fcompiler.c;h=5260f20d162f85f081d2d8bd5a183eb682ca2cee;hb=d811abf65c8a370f490e104bef8224f1998e2325;hp=ef0be9b982a2fd0c5734998d61fdf734827eb1b6;hpb=2f1003ae5be04c794fe1f25a8a576b3ff0a8f15b;p=ghc-hetmet.git diff --git a/ghc/interpreter/compiler.c b/ghc/interpreter/compiler.c index ef0be9b..5260f20 100644 --- a/ghc/interpreter/compiler.c +++ b/ghc/interpreter/compiler.c @@ -11,80 +11,72 @@ * included in the distribution. * * $RCSfile: compiler.c,v $ - * $Revision: 1.11 $ - * $Date: 1999/11/11 17:42:31 $ + * $Revision: 1.22 $ + * $Date: 2000/03/13 11:37:16 $ * ------------------------------------------------------------------------*/ #include "prelude.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 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 */ /* -------------------------------------------------------------------------- * Translation: Convert input expressions into a less complex language @@ -94,6 +86,9 @@ static List local addStgVar Args((List,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); @@ -185,7 +180,8 @@ Cell e; { nv)); } - default : fprintf(stderr, "stuff=%d\n",whatIs(e));internal("translate"); + default : fprintf(stderr, "stuff=%d\n",whatIs(e)); + internal("translate"); } return e; } @@ -205,6 +201,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)); } @@ -612,9 +611,7 @@ Cell pat; { /* test with pat. */ case STRCELL : case CHARCELL : -#if NPLUSK case ADDPAT : -#endif case TUPLE : case NAME : return pat; @@ -630,10 +627,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)); @@ -701,10 +696,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)); @@ -804,14 +797,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); @@ -931,9 +922,7 @@ Cell e; { /* e = expr to transform */ case AP : return pmcPair(co,sc,e); -#if NPLUSK case ADDPAT : -#endif #if TREX case EXT : #endif @@ -1340,10 +1329,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)); @@ -1384,18 +1371,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"); @@ -1404,10 +1385,8 @@ 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))) @@ -1469,7 +1448,7 @@ void eval_ctrlbrk ( int dunnowhat ) 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. */ @@ -1486,17 +1465,20 @@ Void evalExp() { /* compile and run input expression */ /* 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 - /* ToDo: don't really initScheduler every time. fix */ { HaskellObj result; /* ignored */ sighandler_t old_ctrlbrk; SchedulerStatus status; - Bool doRevertCAFs = FALSE; + 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); @@ -1505,8 +1487,7 @@ Void evalExp() { /* compile and run input expression */ fflush (stdout); switch (status) { case Deadlock: - case AllBlocked: /* I don't understand the distinction - ADR */ - printf("{Deadlock}"); + printf("{Deadlock or Blackhole}"); if (doRevertCAFs) RevertCAFs(); break; case Interrupted: @@ -1523,6 +1504,7 @@ Void evalExp() { /* compile and run input expression */ default: internal("evalExp: Unrecognised SchedulerStatus"); } + deleteAllThreads(); fflush(stdout); fflush(stderr); } @@ -1553,14 +1535,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) { - implementCfun ( nameCons, NIL ); - implementCfun ( nameNil, NIL ); - implementCfun ( nameUnit, NIL ); - } - { List vss; List vs; @@ -1602,14 +1576,6 @@ Void compileDefns() { /* compile script definitions */ 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); @@ -1630,6 +1596,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))); +#if 0 + printf ( "compGenFn: " );print(defs,100);printf("\n"); +#endif compiler(RESET); currentName = n; mapProc(transAlt,defs); @@ -1657,20 +1626,17 @@ Pair p; { /* Should be merged with genDefns, */ Void compiler(what) Int what; { switch (what) { - case INSTALL : + case PREPREL : case RESET : freeVars = NIL; freeFuns = NIL; freeBegin = mkOffset(0); - //extraVars = NIL; - //numExtraVars = 0; - //localOffset = 0; - //localArity = 0; break; case MARK : mark(freeVars); mark(freeFuns); - //mark(extraVars); break; + + case POSTPREL: break; } }