X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Finterpreter%2Fcodegen.c;h=83985cd91b67e880fcf5693946551b7291526892;hb=22bc4dd169cc1e4d22bf8bcacebb95dc621ef808;hp=2ffd55a2ab70949868cd9923b54f3107f756a5b7;hpb=b3c8ae4e104c93354738d3992fcf0e60e9646490;p=ghc-hetmet.git diff --git a/ghc/interpreter/codegen.c b/ghc/interpreter/codegen.c index 2ffd55a..83985cd 100644 --- a/ghc/interpreter/codegen.c +++ b/ghc/interpreter/codegen.c @@ -9,46 +9,138 @@ * included in the distribution. * * $RCSfile: codegen.c,v $ - * $Revision: 1.12 $ - * $Date: 1999/11/29 18:59:25 $ + * $Revision: 1.24 $ + * $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 "Assembler.h" -#include "link.h" -#include "Rts.h" /* IF_DEBUG */ +#include "Rts.h" /* to make StgPtr visible in Assembler.h */ +#include "Assembler.h" #include "RtsFlags.h" +/*#define DEBUG_CODEGEN*/ + +/* (JRS, 27 Apr 2000): + +A total rewrite of the BCO assembler/linker, and rationalisation of +the code management and code generation phases of Hugs. + +Problems with the old linker: + +* Didn't have a clean way to insert a pointer to GHC code into a BCO. + This meant CAF GC didn't work properly in combined mode. + +* Leaked memory. Each BCO, caf and constructor generated by Hugs had + a corresponding malloc'd record used in its construction. These + records existed forever. Pointers from the Hugs symbol tables into + the runtime heap always went via these intermediates, for no apparent + reason. + +* A global variable holding a list of top-level stg trees was used + during code generation. It was hard to associate trees in this + list with entries in the name/tycon tables. Just too many + mechanisms. + +The New World Order is as follows: + +* The global code list (stgGlobals) is gone. + +* Each name in the name table has a .closure field. This points + to the top-level code for that name. Before bytecode generation + this points to a STG tree. During bytecode generation but before + bytecode linking it is a MPtr pointing to a malloc'd intermediate + structure (an AsmObject). After linking, it is a real live pointer + into the execution heap (CPtr) which is treated as a root during GC. + + Because tuples do not have name table entries, tycons which are + tuples also have a .closure field, which is treated identically + to those of name table entries. + +* Each module has a code list -- a list of names and tuples. If you + are a name or tuple and you have something (code, CAF or Con) which + needs to wind up in the execution heap, you MUST be on your module's + code list. Otherwise you won't get code generated. + +* Lambda lifting generates new name table entries, which of course + also wind up on the code list. + +* The initial phase of code generation for a module m traverses m's + code list. The stg trees referenced in the .closure fields are + code generated, creating AsmObject (AsmBCO, AsmCAF, AsmCon) in + mallocville. The .closure fields then point to these AsmObjects. + Since AsmObjects can be mutually recursive, they can contain + references to: + * Other AsmObjects Asm_RefObject + * Existing closures Asm_RefNoOp + * name/tycon table entries Asm_RefHugs + AsmObjects can also contain BCO insns and non-ptr words. + +* A second copy-and-link phase copies the AsmObjects into the + execution heap, resolves the Asm_Ref* items, and frees up + the malloc'd entities. + +* Minor cleanups in compile-time storage. There are now 3 kinds of + address-y things available: + CPtr/mkCPtr/cptrOf -- ptrs to Closures, probably in exec heap + ie anything which the exec GC knows about + MPtr/mkMPtr/mptrOf -- ptrs to mallocville, which the exec GC + knows nothing about + Addr/mkAddr/addrOf -- literal addresses (like literal ints) + +* Many hacky cases removed from codegen.c. Referencing code or + data during code generation is a lot simpler, since an entity + is either: + a CPtr, in which case use it as is + a MPtr -- stuff it into the AsmObject and the linker will fix it + a name or tycon + -- ditto + +* I've checked, using Purify that, at least in standalone mode, + no longer leaks mallocd memory. Prior to this it would leak at + the rate of about 300k per Prelude. + +Still to do: + +* Reinstate peephole optimisation for BCOs. + +* Nuke magic number headers in AsmObjects, used for debugging. + +* Profile and accelerate. Code generation is slower because linking + is slower. Evaluation GC is slower because markHugsObjects has + slowed down. + +* Make setCurrentModule ignore name table entries created by the + lambda-lifter. +*/ + + /* -------------------------------------------------------------------------- * Local function prototypes: * ------------------------------------------------------------------------*/ #define getPos(v) intOf(stgVarInfo(v)) #define setPos(v,sp) stgVarInfo(v) = mkInt(sp) -#define getObj(v) ptrOf(stgVarInfo(v)) -#define setObj(v,obj) stgVarInfo(v) = mkPtr(obj) +#define getObj(v) mptrOf(stgVarInfo(v)) +#define setObj(v,obj) stgVarInfo(v) = mkMPtr(obj) #define repOf(x) charOf(stgVarRep(x)) -static void cgBind ( AsmBCO bco, StgVar v ); -static Void pushVar ( AsmBCO bco, StgVar v ); -static Void pushAtom ( AsmBCO bco, StgAtom atom ); -static Void alloc ( AsmBCO bco, StgRhs rhs ); -static Void build ( AsmBCO bco, StgRhs rhs ); -static Void cgExpr ( AsmBCO bco, AsmSp root, StgExpr e ); +static void cgBind ( AsmBCO bco, StgVar v ); +static Void pushAtom ( AsmBCO bco, StgAtom atom ); +static Void alloc ( AsmBCO bco, StgRhs rhs ); +static Void build ( AsmBCO bco, StgRhs rhs ); +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 AsmBCO cgLambda ( StgExpr e ); -static AsmBCO cgRhs ( StgRhs rhs ); -static void beginTop ( StgVar v ); -static void endTop ( StgVar v ); +static AsmBCO cgAlts ( AsmSp root, AsmSp sp, List alts ); +static void testPrimPats ( AsmBCO bco, AsmSp root, List pats, StgExpr e ); +static AsmBCO cgLambda ( StgExpr e ); +static AsmBCO cgRhs ( StgRhs rhs ); +static void beginTop ( StgVar v ); +static AsmObject endTop ( StgVar v ); static StgVar currentTop; @@ -56,61 +148,36 @@ static StgVar currentTop; * * ------------------------------------------------------------------------*/ -static Cell cptrFromName ( Name n ) +static void* /* StgClosure*/ 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( enZcodeThenFindText ( textToStr (name(n).text) ) ) ); + sprintf(buf, MAYBE_LEADING_UNDERSCORE_STR("%s_%s_closure"), + textToStr(mt), + textToStr( enZcodeThenFindText ( + 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))); -} - -/* should be AsmClosure* */ -void* closureOfVar( StgVar v ) -{ - return asmClosureOfObject((AsmClosure*)ptrOf(stgVarInfo(v))); + return p; } char* lookupHugsName( void* closure ) { extern Name nameHw; Name nm; - for( nm=NAMEMIN; nm length(args); -fprintf ( stderr, "nativeCall: name %s, arity %d, args %d\n", - nameFromOPtr(cptrOf(fun)), name(fun0).arity, length(args) ); - } else { + if (isName(fun)) { + itsaPAP = name(fun).arity > length(args); + } else + if (isStgVar(fun)) { itsaPAP = FALSE; if (nonNull(stgVarBody(fun)) && whatIs(stgVarBody(fun)) == LAMBDA @@ -556,6 +623,8 @@ fprintf ( stderr, "nativeCall: name %s, arity %d, args %d\n", ) itsaPAP = TRUE; } + else + internal("build: STGAPP"); if (itsaPAP) { AsmSp start = asmBeginMkPAP(bco); @@ -583,7 +652,6 @@ fprintf ( stderr, "nativeCall: name %s, arity %d, args %d\n", * of this except "let x = x in ..." */ case NAME: - rhs = name(rhs).stgVar; case STGVAR: { AsmSp start = asmBeginMkAP(bco); @@ -594,7 +662,7 @@ fprintf ( stderr, "nativeCall: name %s, arity %d, args %d\n", default: { AsmSp start = asmBeginMkAP(bco); /* make it updateable! */ - asmClosure(bco,cgRhs(rhs)); + asmPushRefObject(bco,cgRhs(rhs)); asmEndMkAP(bco,getPos(v),start); return; } @@ -608,18 +676,6 @@ fprintf ( stderr, "nativeCall: name %s, arity %d, args %d\n", * 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)) { - v = name(v).stgVar; - } - assert(isStgVar(v)); - asmAddPtr(obj,getObj(v)); -} -#endif - - /* allocate AsmObject for top level variables * any change requires a corresponding change in endTop */ @@ -630,128 +686,155 @@ static void beginTop( StgVar v ) currentTop = v; rhs = stgVarBody(v); switch (whatIs(rhs)) { - case STGCON: - { - //List as = stgConArgs(rhs); - setObj(v,asmBeginCon(stgConInfo(stgConCon(rhs)))); - break; - } - case LAMBDA: -#ifdef CRUDE_PROFILING - setObj(v,asmBeginBCO(currentTop)); -#else - setObj(v,asmBeginBCO(rhs)); -#endif - break; - default: - setObj(v,asmBeginCAF()); - break; + case STGCON: + setObj(v,asmBeginCon(stgConInfo(stgConCon(rhs)))); + break; + case LAMBDA: + setObj(v,asmBeginBCO(rhs)); + break; + default: + setObj(v,asmBeginCAF()); + break; } } -static void endTop( StgVar v ) +static AsmObject endTop( StgVar v ) { StgRhs rhs = stgVarBody(v); currentTop = v; switch (whatIs(rhs)) { - case STGCON: - { - List as = stgConArgs(rhs); - AsmCon con = (AsmCon)getObj(v); - for( ; nonNull(as); as=tl(as)) { - StgAtom a = hd(as); - switch (whatIs(a)) { + case STGCON: { + List as = stgConArgs(rhs); + AsmCon con = (AsmCon)getObj(v); + for ( ; nonNull(as); as=tl(as)) { + StgAtom a = hd(as); + switch (whatIs(a)) { case STGVAR: - /* should be a delayed combinator! */ - asmAddPtr(con,(AsmObject)getObj(a)); - break; - case NAME: - { - StgVar var = name(a).stgVar; - assert(var); - asmAddPtr(con,(AsmObject)getObj(a)); - break; - } -#if !USE_ADDR_FOR_STRINGS + /* should be a delayed combinator! */ + asmAddRefObject(con,(AsmObject)getObj(a)); + break; + case NAME: { + StgVar var = name(a).closure; + cgAddPtrToObject(con,var); + break; + } +# if !USE_ADDR_FOR_STRINGS case STRCELL: - asmAddPtr(con,asmStringObj(textToStr(textOf(a)))); - break; -#endif + asmAddPtr(con,asmStringObj(textToStr(textOf(a)))); + break; +# endif default: - /* asmAddPtr(con,??); */ - assert(0); - break; - } - } - asmEndCon(con); - break; - } - case LAMBDA: /* optimisation */ - { - /* ToDo: merge this code with cgLambda */ - AsmBCO bco = (AsmBCO)getObj(v); - AsmSp root = asmBeginArgCheck(bco); - map1Proc(cgBind,bco,reverse(stgLambdaArgs(rhs))); - asmEndArgCheck(bco,root); - - cgExpr(bco,root,stgLambdaBody(rhs)); + /* asmAddPtr(con,??); */ + assert(0); + break; + } + } + asmEndCon(con); + return con; + } + case LAMBDA: { /* optimisation */ + /* ToDo: merge this code with cgLambda */ + AsmBCO bco = (AsmBCO)getObj(v); + AsmSp root = asmBeginArgCheck(bco); + map1Proc(cgBind,bco,reverse(stgLambdaArgs(rhs))); + asmEndArgCheck(bco,root); - asmEndBCO(bco); - break; - } - default: /* updateable caf */ - { - AsmCAF caf = (AsmCAF)getObj(v); - asmEndCAF(caf,cgRhs(rhs)); - break; - } + cgExpr(bco,root,stgLambdaBody(rhs)); + + asmEndBCO(bco); + return bco; + } + default: { /* updateable caf */ + AsmCAF caf = (AsmCAF)getObj(v); + asmAddRefObject ( caf, cgRhs(rhs) ); + asmEndCAF(caf); + return caf; + } } } -static void zap( StgVar v ) -{ - // ToDo: reinstate - // stgVarBody(v) = NIL; -} -/* external entry point */ -Void cgBinds( List binds ) +/* -------------------------------------------------------------------------- + * The external entry points for the code generator. + * ------------------------------------------------------------------------*/ + +Void cgModule ( Module mod ) { - List b; + List cl; + Cell c; 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"); - } + /* Lambda-lift, by traversing the code list of this module. + This creates more name-table entries, which are duly added + to the module's code list. + */ + liftModule ( mod ); + + /* Initialise the BCO linker subsystem. */ + asmInitialise(); + + /* Generate BCOs, CAFs and Constructors into mallocville. + At this point, the .closure values of the names/tycons on + the codelist contain StgVars, ie trees. The call to beginTop + converts them to MPtrs to AsmObjects. + */ + for (cl=module(mod).codeList; nonNull(cl); cl=tl(cl)) { + c = getNameOrTupleClosure(hd(cl)); + if (isCPtr(c)) continue; +# if 0 + if (isName(hd(cl))) { + printStg( stdout, name(hd(cl)).closure ); printf( "\n\n"); + } +# endif + beginTop ( c ); } -#endif - - binds = liftBinds(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"); - } + for (cl=module(mod).codeList; nonNull(cl); cl=tl(cl)) { + c = getNameOrTupleClosure(hd(cl)); + if (isCPtr(c)) continue; +# if 0 + if (isName(hd(cl))) { + printStg( stdout, name(hd(cl)).closure ); printf( "\n\n"); + } +# endif + setNameOrTupleClosure ( hd(cl), mkMPtr(endTop(c)) ); } -#endif - for (b=binds,i=0; nonNull(b); b=tl(b),i++) { - beginTop(hd(b)); + //fprintf ( stderr, "\nstarting sanity check\n" ); + for (cl = module(mod).codeList; nonNull(cl); cl=tl(cl)) { + Cell c = hd(cl); + ASSERT(isName(c) || isTuple(c)); + c = getNameOrTupleClosure(c); + ASSERT(isMPtr(c) || isCPtr(c)); } - - for (b=binds,i=0; nonNull(b); b=tl(b),i++) { - //printf("endTop %s\n", maybeName(hd(b))); - endTop(hd(b)); + //fprintf ( stderr, "completed sanity check\n" ); + + + /* Figure out how big each object will be in the evaluator's heap, + and allocate space to put each in, but don't copy yet. Record + the heap address in the object. Assumes that GC doesn't happen; + reasonable since we use allocate(). + */ + asmAllocateHeapSpace(); + + /* Update name/tycon table closure entries with these new heap addrs. */ + for (cl = module(mod).codeList; nonNull(cl); cl=tl(cl)) { + c = getNameOrTupleClosure(hd(cl)); + if (isMPtr(c)) + setNameOrTupleClosureCPtr ( + hd(cl), asmGetClosureOfObject(mptrOf(c)) ); } - //mapProc(zap,binds); + /* Copy out of mallocville into the heap, resolving references on + the way. + */ + asmCopyAndLink(); + + /* Free up the malloc'd memory. */ + asmShutdown(); } + /* -------------------------------------------------------------------------- * Code Generator control: * ------------------------------------------------------------------------*/ @@ -759,12 +842,11 @@ Void cgBinds( List binds ) Void codegen(what) Int what; { switch (what) { - case INSTALL: - /* deliberate fall though */ - case RESET: - break; - case MARK: - break; + case PREPREL: + case RESET: + case MARK: + case POSTPREL: + break; } liftControl(what); }