X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Finterpreter%2Fcompiler.c;h=f536ae2e12bb56214a5b9439f9eba082d49f9074;hb=ea659be5faea43df1b2c113d2f22947dff23367e;hp=cc9b536091cd7164145724ea9df9f90daee16fb3;hpb=57131ad0203977941eb50d60550fa82e88614496;p=ghc-hetmet.git diff --git a/ghc/interpreter/compiler.c b/ghc/interpreter/compiler.c index cc9b536..f536ae2 100644 --- a/ghc/interpreter/compiler.c +++ b/ghc/interpreter/compiler.c @@ -4,102 +4,81 @@ * `kernel' language, elimination of pattern matching and translation to * super combinators (lambda lifting). * - * Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale - * Haskell Group 1994-99, and is distributed as Open Source software - * under the Artistic License; see the file "Artistic" that is included - * in the distribution for details. + * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the + * Yale Haskell Group, and the Oregon Graduate Institute of Science and + * Technology, 1994-1999, All rights reserved. It is distributed as + * free software under the license in the file "License", which is + * included in the distribution. * * $RCSfile: compiler.c,v $ - * $Revision: 1.3 $ - * $Date: 1999/02/03 17:08:26 $ + * $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" - -/*#define DEBUG_SHOWSC*/ /* Must also be set in output.c */ - -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 Cell local lift Args((Int,List,Cell)); -static Void local liftPair Args((Int,List,Pair)); -static Void local liftTriple Args((Int,List,Triple)); -static Void local liftAlt Args((Int,List,Cell)); -static Void local liftNumcase Args((Int,List,Triple)); -static Cell local liftVar Args((List,Cell)); -static Cell local liftLetrec Args((Int,List,Cell)); -static Void local liftFundef Args((Int,List,Triple)); -static Void local solve Args((List)); - -static Cell local preComp Args((Cell)); -static Cell local preCompPair Args((Pair)); -static Cell local preCompTriple Args((Triple)); -static Void local preCompCase Args((Pair)); -static Cell local preCompOffset Args((Int)); - -static Void local compileGlobalFunction Args((Pair)); -static Void local compileGenFunction Args((Name)); -static Name local compileSelFunction Args((Pair)); -static Void local newGlobalFunction Args((Name,Int,List,Int,Cell)); +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 @@ -109,6 +88,9 @@ static Void local newGlobalFunction Args((Name,Int,List,Int,Cell)); 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); @@ -118,29 +100,34 @@ 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 EVAL_INSTANCES - if (fst(e)==nameStrict) - return nameIStrict; - if (fst(e)==nameSeq) - return nameISeq; -#endif if (isName(fst(e)) && isMfun(fst(e)) && mfunOf(fst(e))==0) return translate(snd(e)); snd(e) = translate(snd(e)); + return e; -#if BIGNUMS - case POSNUM : - case ZERONUM : - case NEGNUM : return e; -#endif - 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; @@ -161,8 +148,11 @@ Cell e; { case INTCELL : case FLOATCELL : 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)); @@ -208,7 +198,8 @@ Cell e; { nv)); } - default : internal("translate"); + default : fprintf(stderr, "stuff=%d\n",whatIs(e)); + internal("translate"); } return e; } @@ -228,6 +219,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)); } @@ -241,7 +235,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)) { +#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)))) { +#endif mapProc(transAlt,snd(hd(bs))); newBinds = cons(hd(bs),newBinds); } @@ -263,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; + } } } @@ -627,9 +636,7 @@ Cell pat; { /* test with pat. */ case STRCELL : case CHARCELL : -#if NPLUSK case ADDPAT : -#endif case TUPLE : case NAME : return pat; @@ -645,10 +652,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)); @@ -716,10 +721,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)); @@ -819,14 +822,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); @@ -847,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); @@ -865,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 { @@ -946,14 +952,7 @@ Cell e; { /* e = expr to transform */ case AP : return pmcPair(co,sc,e); -#if BIGNUMS - case POSNUM : - case ZERONUM : - case NEGNUM : -#endif -#if NPLUSK case ADDPAT : -#endif #if TREX case EXT : #endif @@ -961,6 +960,7 @@ Cell e; { /* e = expr to transform */ case NAME : case CHARCELL : case INTCELL : + case BIGCELL : case FLOATCELL: case STRCELL : break; @@ -1321,11 +1321,12 @@ tidyHd: switch (whatIs(p=hd(maPats(ma)))) { return FALSE; case STRCELL : { String s = textToStr(textOf(p)); - for (p=NIL; *s!='\0'; ++s) + for (p=NIL; *s!='\0'; ++s) { if (*s!='\\' || *++s=='\\') p = ap(consChar(*s),p); else p = ap(consChar('\0'),p); + } hd(maPats(ma)) = revOnto(p,nameNil); } return FALSE; @@ -1358,10 +1359,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)); @@ -1402,18 +1401,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"); @@ -1422,18 +1415,12 @@ 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))) return isFloat(arg(d2)) && floatOf(arg(d1))==floatOf(arg(d2)); -#if BIGNUMS - if (isBignum(arg(d1))) - return isBignum(arg(d2)) && bigCmp(arg(d1),arg(d2))==0; -#endif internal("eqNumDiscr"); return FALSE;/*NOTREACHED*/ } @@ -1452,132 +1439,139 @@ 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 = pieces of code generated for selectors, tuples, etc */ - for(;nonNull(stgGlobals);stgGlobals=tl(stgGlobals)) { - StgVar bind = snd(hd(stgGlobals)); - if (nonNull(stgVarBody(bind))) { - binds = cons(bind,binds); - } - } - return binds; -} - - -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); - StgVar v = mkStgVar(NIL,NIL); - name(n).stgVar = v; + Cell e; + Name n = newName(inventText(),NIL); + StgVar v = mkStgVar(NIL,NIL); + name(n).closure = v; + module(currentModule).codeList = singleton(n); compiler(RESET); - stgDefn(n,0,pmcTerm(0,NIL,translate(inputExpr))); + 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) */ /* Re-initialise the scheduler - ToDo: do I need this? */ - initScheduler(); - /* ToDo: don't really initScheduler every time. fix */ + /* 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(); */ + + /* 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 = rts_eval_(closureOfVar(v),10000,&result); + HaskellObj result; /* ignored */ + SchedulerStatus status; + Bool doRevertCAFs = TRUE; /* do not change -- comment above */ + 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: - case AllBlocked: /* I don't understand the distinction - ADR */ - printf("{Deadlock}"); - RevertCAFs(); + printf("{Deadlock or Blackhole}"); fflush(stdout); break; case Interrupted: printf("{Interrupted}"); - RevertCAFs(); break; case Killed: - printf("{Killed}"); - RevertCAFs(); + printf("{Interrupted or Killed}"); break; case Success: - /* Nothing to do */ break; default: internal("evalExp: Unrecognised SchedulerStatus"); } + + /* 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); } } -static List local addStgVar( List binds, Pair bind ); /* todo */ - -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("Compiling",t); + 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)) { @@ -1589,12 +1583,9 @@ Void compileDefns() { /* compile script definitions */ soFar(i++); } - /* binds=revOnto(binds,NIL); *//* ToDo: maintain compilation order?? */ - binds = addGlobals(binds); -#if USE_HUGS_OPTIMIZER - mapProc(optimiseBind,binds); -#endif - stgCGBinds(binds); + done(); + setGoal("Generating code",t); + cgModule ( currentModule ); done(); } @@ -1634,32 +1625,6 @@ Pair p; { /* Should be merged with genDefns, */ } -#if 0 -I think this is 98-specific. -static Void local newGlobalFunction(n,arity,fvs,co,e) -Name n; -Int arity; -List fvs; -Int co; -Cell e; { -#ifdef DEBUG_SHOWSC - extern Void printSc Args((FILE*, Text, Int, Cell)); -#endif - extraVars = fvs; - numExtraVars = length(extraVars); - localOffset = co; - localArity = arity; - name(n).arity = arity+numExtraVars; - e = preComp(e); -#ifdef DEBUG_SHOWSC - if (debugCode) { - printSc(stdout,name(n).text,name(n).arity,e); - } -#endif - name(n).code = codeGen(n,name(n).arity,e); -} -#endif - /* -------------------------------------------------------------------------- * Compiler control: * ------------------------------------------------------------------------*/ @@ -1667,20 +1632,18 @@ Cell e; { Void compiler(what) Int what; { switch (what) { - case INSTALL : + case PREPREL : case RESET : freeVars = NIL; freeFuns = NIL; + lineNumber = 0; freeBegin = mkOffset(0); - //extraVars = NIL; - //numExtraVars = 0; - //localOffset = 0; - //localArity = 0; break; case MARK : mark(freeVars); mark(freeFuns); - //mark(extraVars); break; + + case POSTPREL: break; } }