X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Finterpreter%2Fcompiler.c;h=4ab3144f807139337ff8033e08116cb8a8e62a45;hb=6f531423b6927191dac4958ed11086def74cb3b3;hp=7591e78031772a7495b6f8b310bf277bb7d4fa2d;hpb=9da01c710daee2cd5038afb8fad761cdaf343033;p=ghc-hetmet.git diff --git a/ghc/interpreter/compiler.c b/ghc/interpreter/compiler.c index 7591e78..4ab3144 100644 --- a/ghc/interpreter/compiler.c +++ b/ghc/interpreter/compiler.c @@ -4,83 +4,80 @@ * `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.5 $ - * $Date: 1999/03/09 14:51:05 $ + * $Revision: 1.25 $ + * $Date: 2000/03/24 14:32:03 $ * ------------------------------------------------------------------------*/ -#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 - - /* -------------------------------------------------------------------------- * 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 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 @@ -90,6 +87,9 @@ static Name local compileSelFunction Args((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); @@ -99,29 +99,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; @@ -142,8 +147,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)); @@ -189,7 +197,8 @@ Cell e; { nv)); } - default : internal("translate"); + default : fprintf(stderr, "stuff=%d\n",whatIs(e)); + internal("translate"); } return e; } @@ -209,6 +218,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)); } @@ -222,7 +234,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); } @@ -244,7 +264,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; + } } } @@ -608,9 +635,7 @@ Cell pat; { /* test with pat. */ case STRCELL : case CHARCELL : -#if NPLUSK case ADDPAT : -#endif case TUPLE : case NAME : return pat; @@ -626,10 +651,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)); @@ -697,10 +720,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)); @@ -800,14 +821,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); @@ -927,14 +946,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 @@ -942,6 +954,7 @@ Cell e; { /* e = expr to transform */ case NAME : case CHARCELL : case INTCELL : + case BIGCELL : case FLOATCELL: case STRCELL : break; @@ -1302,11 +1315,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; @@ -1339,10 +1353,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)); @@ -1383,18 +1395,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"); @@ -1403,18 +1409,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,7 +1452,7 @@ List binds; { static List addGlobals( List binds ) { - /* stgGlobals = pieces of code generated for selectors, tuples, etc */ + /* stgGlobals = list of top-level STG binds */ for(;nonNull(stgGlobals);stgGlobals=tl(stgGlobals)) { StgVar bind = snd(hd(stgGlobals)); if (nonNull(stgVarBody(bind))) { @@ -1463,7 +1463,7 @@ static List addGlobals( List binds ) } -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. */ @@ -1473,50 +1473,67 @@ Void evalExp() { /* compile and run input expression */ name(n).stgVar = v; compiler(RESET); e = pmcTerm(0,NIL,translate(inputExpr)); - stgDefn(n,0,e); //ppStg(name(n).stgVar); + stgDefn(n,0,e); inputExpr = NIL; stgCGBinds(addGlobals(singleton(v))); /* 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(); */ +# ifdef CRUDE_PROFILING + cp_init(); +# endif + { - 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 ); + status = rts_eval_(closureOfVar(v),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}"); + if (doRevertCAFs) RevertCAFs(); break; case Interrupted: printf("{Interrupted}"); - RevertCAFs(); + if (doRevertCAFs) RevertCAFs(); break; case Killed: - printf("{Killed}"); - RevertCAFs(); + printf("{Interrupted or Killed}"); + if (doRevertCAFs) RevertCAFs(); break; case Success: + if (doRevertCAFs) RevertCAFs(); break; default: internal("evalExp: Unrecognised SchedulerStatus"); } + deleteAllThreads(); fflush(stdout); fflush(stderr); } +#ifdef CRUDE_PROFILING + cp_show(); +#endif + } -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); - //printf ( "addStgVar %s\n", textToStr(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*/ @@ -1531,14 +1548,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; @@ -1561,7 +1570,7 @@ Void compileDefns() { /* compile script definitions */ } } - setGoal("Compiling",t); + setGoal("Translating",t); /* do valDefns before everything else so that all stgVar's get added. */ for (; nonNull(valDefns); valDefns=tl(valDefns)) { hd(valDefns) = transBinds(hd(valDefns)); @@ -1578,13 +1587,9 @@ Void compileDefns() { /* compile script definitions */ soFar(i++); } - /* binds=revOnto(binds,NIL); *//* ToDo: maintain compilation order?? */ binds = addGlobals(binds); -#if USE_HUGS_OPTIMIZER -#error optimiser - if (lastModule() != modulePrelude) - mapProc(optimiseTopBind,binds); -#endif + done(); + setGoal("Generating code",t); stgCGBinds(binds); done(); @@ -1596,20 +1601,6 @@ Pair bind; { List defs = snd(bind); Int arity = length(fst(hd(defs))); assert(isName(n)); - - //{ Cell cc; - // printf ( "compileGlobalFunction %s\n", textToStr(name(n).text)); - // cc = defs; - // while (nonNull(cc)) { - // printExp(stdout, fst(hd(cc))); - // printf ( "\n = " ); - // printExp(stdout, snd(hd(cc))); - // printf( "\n" ); - // cc = tl(cc); - // } - // printf ( "\n\n\n" ); - //} - compiler(RESET); stgDefn(n,arity,match(arity,altsMatch(1,arity,NIL,defs))); } @@ -1618,20 +1609,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))); - - //{ Cell cc; - // printf ( "compileGenFunction %s\n", textToStr(name(n).text)); - // cc = defs; - // while (nonNull(cc)) { - // printExp(stdout, fst(hd(cc))); - // printf ( "\n = " ); - // printExp(stdout, snd(hd(cc))); - // printf( "\n" ); - // cc = tl(cc); - // } - // printf ( "\n\n\n" ); - //} - +#if 0 + printf ( "compGenFn: " );print(defs,100);printf("\n"); +#endif compiler(RESET); currentName = n; mapProc(transAlt,defs); @@ -1659,20 +1639,18 @@ Pair p; { /* Should be merged with genDefns, */ 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; } }