X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Finterpreter%2Fcompiler.c;h=f536ae2e12bb56214a5b9439f9eba082d49f9074;hb=56f7d139f3266a43b2c77be5239b9d8f29c773bb;hp=41799cc1e8f53539c91d35c745b03b9ae4fb7767;hpb=42d2afc52ff5ffec48a5a56a94c110deba4a9549;p=ghc-hetmet.git diff --git a/ghc/interpreter/compiler.c b/ghc/interpreter/compiler.c index 41799cc..f536ae2 100644 --- a/ghc/interpreter/compiler.c +++ b/ghc/interpreter/compiler.c @@ -11,80 +11,74 @@ * included in the distribution. * * $RCSfile: compiler.c,v $ - * $Revision: 1.20 $ - * $Date: 2000/03/10 14:53:00 $ + * $Revision: 1.31 $ + * $Date: 2000/05/10 09:00:20 $ * ------------------------------------------------------------------------*/ -#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" - -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 - - +#include "Weak.h" /* for finalizeWeakPointersNow */ /* -------------------------------------------------------------------------- * 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 @@ -106,6 +100,9 @@ Cell e; { case AP : fst(e) = translate(fst(e)); + /* T [id ] ==> T[] + * T [indirect ] ==> T[] + */ if (fst(e)==nameId || fst(e)==nameInd) return translate(snd(e)); if (isName(fst(e)) && @@ -114,10 +111,23 @@ Cell 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 ""] + */ + if (flagAssert && e==nameAssert) { + Cell str = errAssert(lineNumber); + return (ap(nameAssertError,str)); + } + if (isCfun(e)) { if (isName(name(e).defn)) return name(e).defn; @@ -255,7 +265,14 @@ Cell rhs; { 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; + } } } @@ -831,7 +848,7 @@ List 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); @@ -849,10 +866,15 @@ List 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 { @@ -1417,58 +1439,22 @@ Cell d1, d2; { /* discriminators have same label */ /*-------------------------------------------------------------------------*/ - - -/* -------------------------------------------------------------------------- - * 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 ) -{ - /* 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; -} - -typedef void (*sighandler_t)(int); -void eval_ctrlbrk ( int dunnowhat ) +Void evalExp ( void ) /* compile and run input expression */ { - 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 */ - /* 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) */ @@ -1478,89 +1464,97 @@ Void evalExp() { /* compile and run input expression */ 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 */ - 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); - status = rts_eval_(closureOfVar(v),10000,&result); - signal(SIGINT,old_ctrlbrk); + HugsBreakAction brkOld = setBreakAction ( HugsRtsInterrupt ); + 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 ); } } } @@ -1568,9 +1562,16 @@ Void compileDefns() { /* compile script definitions */ 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)) { @@ -1582,10 +1583,9 @@ Void compileDefns() { /* compile script definitions */ soFar(i++); } - binds = addGlobals(binds); done(); setGoal("Generating code",t); - stgCGBinds(binds); + cgModule ( currentModule ); done(); } @@ -1604,9 +1604,7 @@ 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); @@ -1637,6 +1635,7 @@ Int what; { case PREPREL : case RESET : freeVars = NIL; freeFuns = NIL; + lineNumber = 0; freeBegin = mkOffset(0); break;