X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Finterpreter%2Fcompiler.c;h=f536ae2e12bb56214a5b9439f9eba082d49f9074;hb=d6297149dd0c8f4e7071692de38d87289b27639c;hp=ac85831778a5ad87dd96522c96b92fa8da05adce;hpb=260c34f4f706780db7d985d0e84c71d171b7255d;p=ghc-hetmet.git diff --git a/ghc/interpreter/compiler.c b/ghc/interpreter/compiler.c index ac85831..f536ae2 100644 --- a/ghc/interpreter/compiler.c +++ b/ghc/interpreter/compiler.c @@ -11,8 +11,8 @@ * included in the distribution. * * $RCSfile: compiler.c,v $ - * $Revision: 1.26 $ - * $Date: 2000/04/06 14:23:55 $ + * $Revision: 1.31 $ + * $Date: 2000/05/10 09:00:20 $ * ------------------------------------------------------------------------*/ #include "hugsbasictypes.h" @@ -24,6 +24,7 @@ #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: @@ -1438,49 +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 ) +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) */ @@ -1490,87 +1464,97 @@ Void evalExp ( void ) { /* 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 */ 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 ); } } } @@ -1578,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)) { @@ -1592,10 +1583,9 @@ Void compileDefns() { /* compile script definitions */ soFar(i++); } - binds = addGlobals(binds); done(); setGoal("Generating code",t); - stgCGBinds(binds); + cgModule ( currentModule ); done(); } @@ -1614,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);