X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Finterpreter%2Fcodegen.c;h=2b87d57418f7f08b80f8b15a20097ca7705e29cf;hb=67fe852eb2e9b3a489b62cbf9259b5a868db5468;hp=9bc719e72e7b570014d4c93173d6bb5d9513b0a3;hpb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;p=ghc-hetmet.git diff --git a/ghc/interpreter/codegen.c b/ghc/interpreter/codegen.c index 9bc719e..2b87d57 100644 --- a/ghc/interpreter/codegen.c +++ b/ghc/interpreter/codegen.c @@ -1,4 +1,4 @@ -/* -*- mode: hugs-c; -*- */ + /* -------------------------------------------------------------------------- * Code generator * @@ -7,20 +7,20 @@ * Hugs version 1.4, December 1997 * * $RCSfile: codegen.c,v $ - * $Revision: 1.2 $ - * $Date: 1998/12/02 13:21:59 $ + * $Revision: 1.8 $ + * $Date: 1999/07/06 15:24:36 $ * ------------------------------------------------------------------------*/ #include "prelude.h" #include "storage.h" +#include "backend.h" #include "connect.h" #include "errors.h" -#include "stg.h" #include "Assembler.h" -#include "lift.h" #include "link.h" -#include "pp.h" -#include "codegen.h" + +#include "Rts.h" /* IF_DEBUG */ +#include "RtsFlags.h" /* -------------------------------------------------------------------------- * Local function prototypes: @@ -42,16 +42,34 @@ static Void cgExpr ( AsmBCO bco, AsmSp root, StgExpr e ); static AsmBCO cgAlts ( AsmSp root, AsmSp sp, List alts ); static void testPrimPats ( AsmBCO bco, AsmSp root, List pats, StgExpr e ); -static void cgPrimAlt ( AsmBCO bco, AsmSp root, List vs, StgExpr e ); +//static void cgPrimAlt ( AsmBCO bco, AsmSp root, List vs, StgExpr e ); static AsmBCO cgLambda ( StgExpr e ); static AsmBCO cgRhs ( StgRhs rhs ); static void beginTop ( StgVar v ); static void endTop ( StgVar v ); +static StgVar currentTop; + /* -------------------------------------------------------------------------- * * ------------------------------------------------------------------------*/ +static Cell cptrFromName ( Name n ) +{ + char buf[1000]; + void* p; + Module m = name(n).mod; + Text mt = module(m).text; + sprintf(buf,"%s_%s_closure", + textToStr(mt), textToStr(name(n).text) ); + p = lookupOTabName ( m, buf ); + if (!p) { + ERRMSG(0) "Can't find object symbol %s", buf + EEND; + } + return mkCPtr(p); +} + static Bool varHasClosure( StgVar v ) { return asmObjectHasClosure((AsmClosure*)ptrOf(stgVarInfo(v))); @@ -104,15 +122,24 @@ static void cgBind( AsmBCO bco, StgVar v ) static Void pushVar( AsmBCO bco, StgVar v ) { - Cell info = stgVarInfo(v); - assert(isStgVar(v)); - if (isPtr(info)) { - asmClosure(bco,ptrOf(info)); - } else if (isInt(info)) { - asmVar(bco,intOf(info),repOf(v)); + Cell info; + + if (!(isStgVar(v) || isCPtr(v))) { + assert(isStgVar(v) || isCPtr(v)); + } + + if (isCPtr(v)) { + asmGHCClosure(bco, cptrOf(v)); } else { - internal("pushVar"); - } + info = stgVarInfo(v); + if (isPtr(info)) { + asmClosure(bco,ptrOf(info)); + } else if (isInt(info)) { + asmVar(bco,intOf(info),repOf(v)); + } else { + internal("pushVar"); + } + } } static Void pushAtom( AsmBCO bco, StgAtom e ) @@ -122,7 +149,9 @@ static Void pushAtom( AsmBCO bco, StgAtom e ) pushVar(bco,e); break; case NAME: - pushVar(bco,name(e).stgVar); + if (nonNull(name(e).stgVar)) + pushVar(bco,name(e).stgVar); else + pushVar(bco,cptrFromName(e)); break; case CHARCELL: asmConstChar(bco,charOf(e)); @@ -130,17 +159,9 @@ static Void pushAtom( AsmBCO bco, StgAtom e ) case INTCELL: asmConstInt(bco,intOf(e)); break; -#if BIGNUM_IS_INTEGER case BIGCELL: asmConstInteger(bco,bignumToString(e)); break; -#elif BIGNUM_IS_INT64 - case BIGCELL: - asmConstInt64(bco,bignumOf(e)); - break; -#else -#warning What is BIGNUM? -#endif case FLOATCELL: #if 0 asmConstFloat(bco,e); /* ToDo: support both float and double! */ @@ -160,6 +181,9 @@ static Void pushAtom( AsmBCO bco, StgAtom e ) asmClosure(bco,asmStringObj(textToStr(textOf(e)))); #endif break; + case CPTRCELL: + asmGHCClosure(bco,cptrOf(e)); + break; case PTRCELL: asmConstAddr(bco,ptrOf(e)); break; @@ -171,24 +195,26 @@ static Void pushAtom( AsmBCO bco, StgAtom e ) static AsmBCO cgAlts( AsmSp root, AsmSp sp, List alts ) { - AsmBCO bco = asmBeginContinuation(sp); +#ifdef CRUDE_PROFILING + AsmBCO bco = asmBeginContinuation(sp, currentTop + 1000000000); +#else + AsmBCO bco = asmBeginContinuation(sp, alts); +#endif /* ppStgAlts(alts); */ for(; nonNull(alts); alts=tl(alts)) { StgCaseAlt alt = hd(alts); - StgPat pat = stgCaseAltPat(alt); - StgExpr body = stgCaseAltBody(alt); - if (isDefaultPat(pat)) { - AsmSp begin = asmBeginAlt(bco); - cgBind(bco,pat); - cgExpr(bco,root,body); + if (isDefaultAlt(alt)) { + cgBind(bco,stgDefaultVar(alt)); + cgExpr(bco,root,stgDefaultBody(alt)); asmEndContinuation(bco); return bco; /* ignore any further alternatives */ } else { - StgDiscr con = stgPatDiscr(pat); - List vs = stgPatVars(pat); + StgDiscr con = stgCaseAltCon(alt); + List vs = stgCaseAltVars(alt); AsmSp begin = asmBeginAlt(bco); - AsmPc fix = asmTest(bco,stgDiscrTag(con)); /* ToDo: omit in single constructor types! */ - cgBind(bco,pat); + AsmPc fix = asmTest(bco,stgDiscrTag(con)); + /* ToDo: omit in single constructor types! */ + asmBind(bco,PTR_REP); /* Adjust simulated sp to acct for return value */ if (isBoxingCon(con)) { setPos(hd(vs),asmUnbox(bco,boxingConRep(con))); } else { @@ -196,7 +222,7 @@ static AsmBCO cgAlts( AsmSp root, AsmSp sp, List alts ) map1Proc(cgBind,bco,reverse(vs)); asmEndUnpack(bco); } - cgExpr(bco,root,body); + cgExpr(bco,root,stgCaseAltBody(alt)); asmEndAlt(bco,begin); asmFixBranch(bco,fix); } @@ -212,7 +238,7 @@ static void testPrimPats( AsmBCO bco, AsmSp root, List pats, StgExpr e ) if (isNull(pats)) { cgExpr(bco,root,e); } else { - StgPrimPat pat = hd(pats); + StgVar pat = hd(pats); if (isInt(stgVarBody(pat))) { /* asmTestInt leaves stack unchanged - so no need to adjust it */ AsmPc tst = asmTestInt(bco,getPos(pat),intOf(stgVarBody(pat))); @@ -225,16 +251,19 @@ static void testPrimPats( AsmBCO bco, AsmSp root, List pats, StgExpr e ) } } +#if 0 /* appears to be unused */ static void cgPrimAlt( AsmBCO bco, AsmSp root, List vs, StgExpr e ) { assert(0); /* ToDo: test for patterns */ map1Proc(cgBind,bco,vs); /* ToDo: are these in right order? */ cgExpr(bco,root,e); } +#endif + static AsmBCO cgLambda( StgExpr e ) { - AsmBCO bco = asmBeginBCO(); + AsmBCO bco = asmBeginBCO(e); AsmSp root = asmBeginArgCheck(bco); map1Proc(cgBind,bco,reverse(stgLambdaArgs(e))); @@ -249,7 +278,7 @@ static AsmBCO cgLambda( StgExpr e ) static AsmBCO cgRhs( StgRhs rhs ) { - AsmBCO bco = asmBeginBCO( ); + AsmBCO bco = asmBeginBCO(rhs ); AsmSp root = asmBeginArgCheck(bco); asmEndArgCheck(bco,root); @@ -261,8 +290,10 @@ static AsmBCO cgRhs( StgRhs rhs ) return bco; } + static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e ) { + //printf("cgExpr:");ppStgExpr(e);printf("\n"); switch (whatIs(e)) { case LETREC: { @@ -301,7 +332,7 @@ static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e ) for(; nonNull(alts); alts=tl(alts)) { StgPrimAlt alt = hd(alts); - List pats = stgPrimAltPats(alt); + List pats = stgPrimAltVars(alt); StgExpr body = stgPrimAltBody(alt); AsmSp altBegin = asmBeginAlt(bco); map1Proc(cgBind,bco,reverse(pats)); @@ -322,7 +353,7 @@ static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e ) for(; nonNull(alts); alts=tl(alts)) { StgPrimAlt alt = hd(alts); - List pats = stgPrimAltPats(alt); + List pats = stgPrimAltVars(alt); StgExpr body = stgPrimAltBody(alt); AsmSp altBegin = asmBeginAlt(bco); map1Proc(cgBind,bco,pats); @@ -390,6 +421,11 @@ static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e ) } } +#define M_ITBLNAMES 35000 + +void* itblNames[M_ITBLNAMES]; +int nItblNames = 0; + /* allocate space for top level variable * any change requires a corresponding change in 'build'. */ @@ -406,13 +442,42 @@ static Void alloc( AsmBCO bco, StgVar v ) pushAtom(bco,hd(args)); setPos(v,asmBox(bco,boxingConRep(con))); } else { - setPos(v,asmAllocCONSTR(bco,stgConInfo(con))); + + void* vv = stgConInfo(con); + if (!(nItblNames < (M_ITBLNAMES-2))) + internal("alloc -- M_ITBLNAMES too small"); + if (isName(con)) { + itblNames[nItblNames++] = vv; + itblNames[nItblNames++] = textToStr(name(con).text); + } else + if (isTuple(con)) { + char* cc = malloc(10); + assert(cc); + sprintf(cc, "Tuple%d", tupleOf(con) ); + itblNames[nItblNames++] = vv; + itblNames[nItblNames++] = cc; + } else + assert ( /* cant identify constructor name */ 0 ); + + setPos(v,asmAllocCONSTR(bco, vv)); } break; } - case STGAPP: - setPos(v,asmAllocAP(bco,length(stgAppArgs(rhs)))); + case STGAPP: { + Int totSizeW = 0; + List bs = stgAppArgs(rhs); + for (; nonNull(bs); bs=tl(bs)) { + if (isName(hd(bs))) { + totSizeW += 1; + } else { + ASSERT(whatIs(hd(bs))==STGVAR); + totSizeW += asmRepSizeW( charOf(stgVarRep(hd(bs))) ); + } + } + setPos(v,asmAllocAP(bco,totSizeW)); + //ORIGINALLY:setPos(v,asmAllocAP(bco,length(stgAppArgs(rhs)))); break; + } case LAMBDA: /* optimisation */ setObj(v,cgLambda(rhs)); break; @@ -426,6 +491,7 @@ static Void build( AsmBCO bco, StgVar v ) { StgRhs rhs = stgVarBody(v); assert(isStgVar(v)); + switch (whatIs(rhs)) { case STGCON: { @@ -442,14 +508,31 @@ static Void build( AsmBCO bco, StgVar v ) } case STGAPP: { + Bool itsaPAP; StgVar fun = stgAppFun(rhs); + StgVar fun0 = fun; List args = stgAppArgs(rhs); if (isName(fun)) { - fun = name(fun).stgVar; + if (nonNull(name(fun).stgVar)) + fun = name(fun).stgVar; else + fun = cptrFromName(fun); + } + + if (isCPtr(fun)) { + assert(isName(fun0)); + itsaPAP = name(fun0).arity > length(args); +fprintf ( stderr, "nativeCall: name %s, arity %d, args %d\n", + nameFromOPtr(cptrOf(fun)), name(fun0).arity, length(args) ); + } else { + itsaPAP = FALSE; + if (nonNull(stgVarBody(fun)) + && whatIs(stgVarBody(fun)) == LAMBDA + && length(stgLambdaArgs(stgVarBody(fun))) > length(args) + ) + itsaPAP = TRUE; } - if (nonNull(stgVarBody(fun)) - && whatIs(stgVarBody(fun)) == LAMBDA - && length(stgLambdaArgs(stgVarBody(fun))) > length(args)) { + + if (itsaPAP) { AsmSp start = asmBeginMkPAP(bco); map1Proc(pushAtom,bco,reverse(args)); pushAtom(bco,fun); @@ -500,6 +583,7 @@ static Void build( AsmBCO bco, StgVar v ) * for each top level variable - this should be simpler! * ------------------------------------------------------------------------*/ +#if 0 /* appears to be unused */ static void cgAddVar( AsmObject obj, StgAtom v ) { if (isName(v)) { @@ -508,6 +592,8 @@ static void cgAddVar( AsmObject obj, StgAtom v ) assert(isStgVar(v)); asmAddPtr(obj,getObj(v)); } +#endif + /* allocate AsmObject for top level variables * any change requires a corresponding change in endTop @@ -516,16 +602,21 @@ static void beginTop( StgVar v ) { StgRhs rhs; assert(isStgVar(v)); + currentTop = v; rhs = stgVarBody(v); switch (whatIs(rhs)) { case STGCON: { - List as = stgConArgs(rhs); + //List as = stgConArgs(rhs); setObj(v,asmBeginCon(stgConInfo(stgConCon(rhs)))); break; } case LAMBDA: - setObj(v,asmBeginBCO()); +#ifdef CRUDE_PROFILING + setObj(v,asmBeginBCO(currentTop)); +#else + setObj(v,asmBeginBCO(rhs)); +#endif break; default: setObj(v,asmBeginCAF()); @@ -536,7 +627,7 @@ static void beginTop( StgVar v ) static void endTop( StgVar v ) { StgRhs rhs = stgVarBody(v); - ppStgRhs(rhs); + currentTop = v; switch (whatIs(rhs)) { case STGCON: { @@ -594,16 +685,46 @@ static void endTop( StgVar v ) static void zap( StgVar v ) { - stgVarBody(v) = NIL; + // ToDo: reinstate + // stgVarBody(v) = NIL; } /* external entry point */ Void cgBinds( List binds ) { + List b; + int i; + +#if 0 + if (lastModule() != modulePrelude) { + printf("\n\ncgBinds: before ll\n\n" ); + for (b=binds; nonNull(b); b=tl(b)) { + printStg ( stdout, hd(b) ); printf("\n\n"); + } + } +#endif + binds = liftBinds(binds); - mapProc(beginTop,binds); - mapProc(endTop,binds); - mapProc(zap,binds); + +#if 0 + if (lastModule() != modulePrelude) { + printf("\n\ncgBinds: after ll\n\n" ); + for (b=binds; nonNull(b); b=tl(b)) { + printStg ( stdout, hd(b) ); printf("\n\n"); + } + } +#endif + + for (b=binds,i=0; nonNull(b); b=tl(b),i++) { + beginTop(hd(b)); + } + + for (b=binds,i=0; nonNull(b); b=tl(b),i++) { + //printf("endTop %s\n", maybeName(hd(b))); + endTop(hd(b)); + } + + //mapProc(zap,binds); } /* --------------------------------------------------------------------------