From f0901617344ad6cb35b10eeaf7093f0e4f23dce9 Mon Sep 17 00:00:00 2001 From: sewardj Date: Thu, 27 Apr 2000 16:35:30 +0000 Subject: [PATCH] [project @ 2000-04-27 16:35:29 by sewardj] 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. * Added this comment to the top of codegen.c. 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. * Zap various #if 0's in codegen.c/Assembler.c. * Zap CRUDE_PROFILING. --- ghc/includes/Assembler.h | 123 +++++-- ghc/interpreter/codegen.c | 576 ++++++++++++++++++++------------- ghc/interpreter/compiler.c | 107 ++---- ghc/interpreter/connect.h | 13 +- ghc/interpreter/derive.c | 52 +-- ghc/interpreter/free.c | 5 +- ghc/interpreter/hugs.c | 8 +- ghc/interpreter/interface.c | 199 ++++++------ ghc/interpreter/lift.c | 60 ++-- ghc/interpreter/link.c | 65 ++-- ghc/interpreter/object.c | 4 +- ghc/interpreter/stg.c | 25 +- ghc/interpreter/storage.c | 158 +++++++-- ghc/interpreter/storage.h | 47 ++- ghc/interpreter/translate.c | 60 ++-- ghc/interpreter/type.c | 5 +- ghc/rts/Assembler.c | 752 ++++++++++++++++++++++++------------------- ghc/rts/Evaluator.c | 20 +- ghc/rts/ForeignCall.c | 6 +- 19 files changed, 1328 insertions(+), 957 deletions(-) diff --git a/ghc/includes/Assembler.h b/ghc/includes/Assembler.h index 1d5c7db..7ac7d9c 100644 --- a/ghc/includes/Assembler.h +++ b/ghc/includes/Assembler.h @@ -1,6 +1,6 @@ /* ----------------------------------------------------------------------------- - * $Id: Assembler.h,v 1.12 1999/11/29 18:59:23 sewardj Exp $ + * $Id: Assembler.h,v 1.13 2000/04/27 16:35:29 sewardj Exp $ * * (c) The GHC Team 1994-1998. * @@ -37,33 +37,81 @@ typedef float AsmFloat; /* ToDo: not on Alphas! */ typedef double AsmDouble; typedef char* AsmString; +typedef int AsmSp; /* stack offset */ +typedef int AsmPc; /* program counter */ +typedef AsmSp AsmVar; /* offset of a Var on the stack */ + /* I want to #include this file into the file that defines the * functions but I don't want to expose the structures that * these types point to. * This hack is the best I could think of. Surely there's a better way? */ #ifdef INSIDE_ASSEMBLER_C -typedef struct AsmObject_ *AsmObject; -typedef struct AsmBCO_ *AsmBCO; -typedef struct AsmCAF_ *AsmCAF; -typedef struct AsmCon_ *AsmCon; -typedef StgInfoTable *AsmInfo; -typedef StgClosure *AsmClosure; -typedef Instr AsmInstr; +/* these types are defined in Assembler.c */ +typedef + enum { + Asm_RefNoOp, /* Pointer which needs no further messing with */ + Asm_RefObject, /* Reference to malloc'd AsmCAF/AsmBCO/AsmCon */ + Asm_RefHugs, /* Reference to Hugs name or tycon table */ + + Asm_NonPtrWord, /* A non-pointer word */ + Asm_Insn8, /* One BCO insn byte */ + } + Asm_Kind; + +typedef + struct { + Asm_Kind kind; + StgWord val; /* StgWord is allegedly big enough to also hold + a pointer, on all platforms */ + } + Asm_Entity; + + + struct AsmObject_ { + unsigned int magic; + struct AsmObject_* next; + enum { Asm_BCO, Asm_CAF, Asm_Con } kind; + int sizeEntities; + int usedEntities; + Asm_Entity* entities; + StgClosure* closure; + + int n_refs; /* number of ptr words */ + int n_words; /* number of words */ + int n_insns; /* number of insn BYTES */ + + /* AsmCon specifics */ + StgInfoTable* itbl; + + /* AsmBCO specifics */ + int /*StgExpr*/ stgexpr; /* stg tree for debugging */ + AsmSp sp; /* simulated sp */ + AsmSp max_sp; /* high-tide of sp */ + Instr lastOpc; /* last opcode, for peephole opt */ + }; + /* AsmObject_ is only mentioned in Assembler.c; clients use + AsmObject/AsmBCO/AsmCAF/AsmCon. + */ + +typedef StgInfoTable* AsmInfo; +typedef struct AsmObject_* AsmBCO; +typedef struct AsmObject_* AsmCAF; +typedef struct AsmObject_* AsmCon; +typedef struct AsmObject_* AsmObject; +typedef Instr AsmInstr; #else /* the types we export are totally opaque */ -typedef void *AsmObject; -typedef void *AsmBCO; -typedef void *AsmCAF; -typedef void *AsmCon; -typedef void *AsmInfo; -typedef void *AsmClosure; -typedef unsigned int AsmInstr; +typedef void* AsmObject; +typedef void* AsmBCO; +typedef void* AsmCAF; +typedef void* AsmCon; +typedef void* AsmInfo; +typedef void* AsmClosure; +typedef unsigned int AsmInstr; #endif -typedef int AsmSp; /* stack offset */ -typedef int AsmPc; /* program counter */ -typedef AsmSp AsmVar; /* offset of a Var on the stack */ + /* -------------------------------------------------------------------------- * "Types" used within the assembler @@ -120,6 +168,17 @@ typedef enum { } AsmRep; /* -------------------------------------------------------------------------- + * Top-level control of the BCO generation + linking mechanism + * ------------------------------------------------------------------------*/ + +extern void asmInitialise ( void ); +extern void asmAllocateHeapSpace ( void ); +extern void asmCopyAndLink ( void ); +extern void asmShutdown ( void ); + +extern void* /* StgClosure* */ asmGetClosureOfObject ( AsmObject ); + +/* -------------------------------------------------------------------------- * Allocating (top level) heap objects * ------------------------------------------------------------------------*/ @@ -129,10 +188,8 @@ extern void asmEndBCO ( AsmBCO bco ); extern AsmBCO asmBeginContinuation ( AsmSp sp, int /*List*/ alts ); extern void asmEndContinuation ( AsmBCO bco ); -extern AsmObject asmMkObject ( AsmClosure c ); - extern AsmCAF asmBeginCAF ( void ); -extern void asmEndCAF ( AsmCAF caf, AsmBCO body ); +extern void asmEndCAF ( AsmCAF caf ); extern AsmInfo asmMkInfo ( AsmNat tag, AsmNat ptrs ); extern AsmCon asmBeginCon ( AsmInfo info ); @@ -143,11 +200,6 @@ extern void asmEndCon ( AsmCon con ); * in right to left order. */ extern void asmAddPtr ( AsmObject obj, AsmObject arg ); - -extern int asmObjectHasClosure( AsmObject obj ); -extern AsmClosure asmClosureOfObject ( AsmObject obj ); -extern void asmMarkObject ( AsmObject obj ); - extern int asmRepSizeW ( AsmRep rep ); /* -------------------------------------------------------------------------- @@ -212,23 +264,28 @@ extern void asmEndPrim ( AsmBCO bco, const AsmPrim* prim, AsmSp base ); extern char* asmGetPrimopName ( AsmPrim* p ); -extern AsmBCO asm_BCO_catch ( void ); -extern AsmBCO asm_BCO_raise ( void ); -extern AsmBCO asm_BCO_seq ( void ); -extern AsmBCO asm_BCO_takeMVar ( void ); +extern void* /* StgBCO* */ asm_BCO_catch ( void ); +extern void* /* StgBCO* */ asm_BCO_raise ( void ); +extern void* /* StgBCO* */ asm_BCO_seq ( void ); +extern void* /* StgBCO* */ asm_BCO_takeMVar ( void ); /* -------------------------------------------------------------------------- * Heap manipulation * ------------------------------------------------------------------------*/ -extern AsmVar asmClosure ( AsmBCO bco, AsmObject p ); -extern AsmVar asmGHCClosure ( AsmBCO bco, AsmObject p ); +extern AsmVar asmPushRefHugs ( AsmBCO bco, int /*Name*/ n ); +extern AsmVar asmPushRefObject ( AsmBCO bco, AsmObject p ); +extern AsmVar asmPushRefNoOp ( AsmBCO bco, StgPtr p ); + +extern void asmAddRefObject ( AsmObject obj, AsmObject p ); +extern void asmAddRefNoOp ( AsmObject obj, StgPtr p ); extern AsmVar asmAllocCONSTR ( AsmBCO bco, AsmInfo info ); extern AsmSp asmBeginPack ( AsmBCO bco ); -extern void asmEndPack ( AsmBCO bco, AsmVar v, AsmSp start, AsmInfo info ); +extern void asmEndPack ( AsmBCO bco, AsmVar v, AsmSp start, + AsmInfo info ); extern void asmBeginUnpack ( AsmBCO bco ); extern void asmEndUnpack ( AsmBCO bco ); diff --git a/ghc/interpreter/codegen.c b/ghc/interpreter/codegen.c index ef12398..31a09a8 100644 --- a/ghc/interpreter/codegen.c +++ b/ghc/interpreter/codegen.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: codegen.c,v $ - * $Revision: 1.22 $ - * $Date: 2000/04/12 09:37:19 $ + * $Revision: 1.23 $ + * $Date: 2000/04/27 16:35:29 $ * ------------------------------------------------------------------------*/ #include "hugsbasictypes.h" @@ -18,36 +18,133 @@ #include "connect.h" #include "errors.h" +#include "Rts.h" /* to make StgPtr visible in Assembler.h */ #include "Assembler.h" -#include "Rts.h" /* IF_DEBUG */ #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 + sloweed down. + +* Make setCurrentModule ignore name table entries created by the + lambda-lifter. + +* Zap various #if 0 in codegen.c/Assembler.c. + +* Zap CRUDE_PROFILING. +*/ + + /* -------------------------------------------------------------------------- * 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 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; @@ -55,7 +152,7 @@ static StgVar currentTop; * * ------------------------------------------------------------------------*/ -static Cell cptrFromName ( Name n ) +static void* /* StgClosure*/ cptrFromName ( Name n ) { char buf[1000]; void* p; @@ -70,18 +167,7 @@ static Cell cptrFromName ( Name n ) 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 ) @@ -91,15 +177,11 @@ char* lookupHugsName( void* closure ) for( nm = NAME_BASE_ADDR; nm < NAME_BASE_ADDR+tabNameSz; ++nm ) if (tabName[nm-NAME_BASE_ADDR].inUse) { - StgVar v = name(nm).stgVar; - if (isStgVar(v) - && isPtr(stgVarInfo(v)) - && varHasClosure(v) - && closureOfVar(v) == closure) { + Cell cl = name(nm).closure; + if (isCPtr(cl) && cptrOf(cl) == closure) return textToStr(name(nm).text); - } } - return 0; + return NULL; } static void cgBindRep( AsmBCO bco, StgVar v, AsmRep rep ) @@ -112,77 +194,119 @@ static void cgBind( AsmBCO bco, StgVar v ) cgBindRep(bco,v,repOf(v)); } -static Void pushVar( AsmBCO bco, StgVar v ) +static void cgAddPtrToObject ( AsmObject obj, Cell ptrish ) { - Cell info; -#if 0 -printf ( "pushVar: %d ", v ); fflush(stdout); -print(v,10);printf("\n"); -#endif - assert(isStgVar(v) || isCPtr(v)); - - if (isCPtr(v)) { - asmGHCClosure(bco, cptrOf(v)); - } else { - info = stgVarInfo(v); - if (isPtr(info)) { - asmClosure(bco,ptrOf(info)); - } else if (isInt(info)) { - asmVar(bco,intOf(info),repOf(v)); - } else { - internal("pushVar"); - } - } + switch (whatIs(ptrish)) { + case CPTRCELL: + asmAddRefNoOp ( obj, (StgPtr)cptrOf(ptrish) ); break; + case MPTRCELL: + asmAddRefObject ( obj, mptrOf(ptrish) ); break; + default: + internal("cgAddPtrToObject"); + } } -static Void pushAtom( AsmBCO bco, StgAtom e ) -{ #if 0 -printf ( "pushAtom: %d ", e ); fflush(stdout); -print(e,10);printf("\n"); +static void cgPushRef ( AsmBCO bco, Cell c ) +{ + switch (whatIs(c)) { + case CPTRCELL: + asmPushRefNoOp(bco,(StgPtr)cptrOf(c)); break; + case PTRCELL: + asmPushRefObject(bco,ptrOf(c)); break; + case NAME: + case TUPLE: + asmPushRefHugs(bco,c); break; + default: + internal("cgPushRef"); + } +} #endif + +/* Get a pointer to atom e onto the stack. */ +static Void pushAtom ( AsmBCO bco, StgAtom e ) +{ + Cell info; + Cell cl; +# if 0 + printf ( "pushAtom: %d ", e ); fflush(stdout); + print(e,10);printf("\n"); +# endif switch (whatIs(e)) { - case STGVAR: - pushVar(bco,e); - break; - case NAME: - if (nonNull(name(e).stgVar)) { - pushVar(bco,name(e).stgVar); - } else { - Cell /*CPtr*/ addr = cptrFromName(e); + case STGVAR: + info = stgVarInfo(e); + if (isInt(info)) { + asmVar(bco,intOf(info),repOf(e)); + } + else + if (isCPtr(info)) { + asmPushRefNoOp(bco,cptrOf(info)); + } + else + if (isMPtr(info)) { + asmPushRefObject(bco,mptrOf(info)); + } + else { + internal("pushAtom: STGVAR"); + } + break; + case NAME: + case TUPLE: + cl = getNameOrTupleClosure(e); + if (isStgVar(cl)) { + /* a stg tree which hasn't yet been translated */ + asmPushRefHugs(bco,e); + } + else + if (isCPtr(cl)) { + /* a pointer to something in the heap */ + asmPushRefNoOp(bco,(StgPtr)cptrOf(cl)); + } + else + if (isMPtr(cl)) { + /* a pointer to an AsmBCO/AsmCAF/AsmCon object */ + asmPushRefObject(bco,mptrOf(cl)); + } + else { + StgClosure* addr; + ASSERT(isNull(cl)); + addr = cptrFromName(e); # if DEBUG_CODEGEN fprintf ( stderr, "nativeAtom: name %s\n", - nameFromOPtr(cptrOf(addr)) ); + nameFromOPtr(addr) ); # endif - pushVar(bco,addr); + asmPushRefNoOp(bco,(StgPtr)addr); } break; - case CHARCELL: + case CHARCELL: asmConstChar(bco,charOf(e)); break; - case INTCELL: + case INTCELL: asmConstInt(bco,intOf(e)); break; - case BIGCELL: + case ADDRCELL: + asmConstAddr(bco,addrOf(e)); + break; + case BIGCELL: asmConstInteger(bco,bignumToString(e)); break; - case FLOATCELL: + case FLOATCELL: asmConstDouble(bco,floatOf(e)); break; - case STRCELL: -#if USE_ADDR_FOR_STRINGS + case STRCELL: +# if USE_ADDR_FOR_STRINGS asmConstAddr(bco,textToStr(textOf(e))); -#else +# else asmClosure(bco,asmStringObj(textToStr(textOf(e)))); -#endif +# endif break; - case CPTRCELL: - asmGHCClosure(bco,cptrOf(e)); + case CPTRCELL: + asmPushRefNoOp(bco,cptrOf(e)); break; - case PTRCELL: - asmConstAddr(bco,ptrOf(e)); + case MPTRCELL: + asmPushRefObject(bco,mptrOf(e)); break; - default: + default: fprintf(stderr,"\nYoiks1: "); printExp(stderr,e); internal("pushAtom"); } @@ -324,7 +448,7 @@ static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e ) case LAMBDA: { AsmSp begin = asmBeginEnter(bco); - asmClosure(bco,cgLambda(e)); + asmPushRefObject(bco,cgLambda(e)); asmEndEnter(bco,begin,root); break; } @@ -366,7 +490,7 @@ static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e ) /* only part different from primop code... todo */ AsmSp beginCase = asmBeginCase(bco); - pushVar(bco,scrut); + pushAtom /*pushVar*/ (bco,scrut); asmEndAlt(bco,beginCase); /* hack, hack - */ for(; nonNull(alts); alts=tl(alts)) { @@ -398,6 +522,7 @@ static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e ) asmEndEnter(bco,env,root); break; } + case TUPLE: case NAME: /* Tail call (with no args) */ { AsmSp env = asmBeginEnter(bco); @@ -413,7 +538,7 @@ static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e ) case BETA_REP: { AsmSp env = asmBeginEnter(bco); - pushVar(bco,e); + pushAtom /*pushVar*/ (bco,e); asmEndEnter(bco,env,root); break; } @@ -510,11 +635,26 @@ static Void build( AsmBCO bco, StgVar v ) { Bool itsaPAP; StgVar fun = stgAppFun(rhs); - StgVar fun0 = fun; List args = stgAppArgs(rhs); + + if (isName(fun)) { + itsaPAP = name(fun).arity > length(args); + } else + if (isStgVar(fun)) { + itsaPAP = FALSE; + if (nonNull(stgVarBody(fun)) + && whatIs(stgVarBody(fun)) == LAMBDA + && length(stgLambdaArgs(stgVarBody(fun))) > length(args) + ) + itsaPAP = TRUE; + } + else + internal("build: STGAPP"); +#if 0 +Looks like a hack to me. if (isName(fun)) { - if (nonNull(name(fun).stgVar)) - fun = name(fun).stgVar; else + if (nonNull(name(fun).closure)) + fun = name(fun).closure; else fun = cptrFromName(fun); } @@ -534,6 +674,7 @@ static Void build( AsmBCO bco, StgVar v ) ) itsaPAP = TRUE; } +#endif if (itsaPAP) { AsmSp start = asmBeginMkPAP(bco); @@ -561,10 +702,6 @@ static Void build( AsmBCO bco, StgVar v ) * of this except "let x = x in ..." */ case NAME: - if (nonNull(name(rhs).stgVar)) - rhs = name(rhs).stgVar; else - rhs = cptrFromName(rhs); - /* fall thru */ case STGVAR: { AsmSp start = asmBeginMkAP(bco); @@ -575,7 +712,7 @@ static Void build( AsmBCO bco, StgVar v ) default: { AsmSp start = asmBeginMkAP(bco); /* make it updateable! */ - asmClosure(bco,cgRhs(rhs)); + asmPushRefObject(bco,cgRhs(rhs)); asmEndMkAP(bco,getPos(v),start); return; } @@ -589,18 +726,6 @@ 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)) { - 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 */ @@ -611,146 +736,159 @@ 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: +# ifdef CRUDE_PROFILING + setObj(v,asmBeginBCO(currentTop)); +# else + setObj(v,asmBeginBCO(rhs)); +# endif + 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++) { - /* printStg( stdout, hd(b) ); printf( "\n\n"); */ - 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++) { - /* printStg( stdout, hd(b) ); printf( "\n\n"); */ - 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(); -/* Called by the evaluator's GC to tell Hugs to mark stuff in the - run-time heap. -*/ -void markHugsObjects( void ) -{ - extern Name nameHw; - Name nm; - for ( nm = NAME_BASE_ADDR; - nm < NAME_BASE_ADDR+tabNameSz; ++nm ) - if (tabName[nm-NAME_BASE_ADDR].inUse) { - StgVar v = name(nm).stgVar; - if (isStgVar(v) && isPtr(stgVarInfo(v))) { - asmMarkObject(ptrOf(stgVarInfo(v))); - } - } + /* Free up the malloc'd memory. */ + asmShutdown(); } + /* -------------------------------------------------------------------------- * Code Generator control: * ------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/compiler.c b/ghc/interpreter/compiler.c index 75b9270..00d7679 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.29 $ - * $Date: 2000/04/21 18:09:30 $ + * $Revision: 1.30 $ + * $Date: 2000/04/27 16:35:29 $ * ------------------------------------------------------------------------*/ #include "hugsbasictypes.h" @@ -1439,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) */ @@ -1522,13 +1495,13 @@ Void evalExp ( void ) { /* compile and run input expression */ Bool doRevertCAFs = TRUE; /* do not change -- comment above */ HugsBreakAction brkOld = setBreakAction ( HugsRtsInterrupt ); nukeModule_needs_major_gc = TRUE; - status = rts_eval_(closureOfVar(v),10000,&result); + status = rts_eval_(cptrOf(name(n).closure),10000,&result); setBreakAction ( brkOld ); fflush (stderr); fflush (stdout); switch (status) { case Deadlock: - printf("{Deadlock or Blackhole}"); + printf("{Deadlock or Blackhole}"); fflush(stdout); break; case Interrupted: printf("{Interrupted}"); @@ -1571,44 +1544,26 @@ Void evalExp ( void ) { /* compile and run input expression */ } -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 ); } } } @@ -1616,9 +1571,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)) { @@ -1630,10 +1592,9 @@ Void compileDefns() { /* compile script definitions */ soFar(i++); } - binds = addGlobals(binds); done(); setGoal("Generating code",t); - stgCGBinds(binds); + cgModule ( currentModule ); done(); } @@ -1652,9 +1613,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); diff --git a/ghc/interpreter/connect.h b/ghc/interpreter/connect.h index 3fe4658..127a236 100644 --- a/ghc/interpreter/connect.h +++ b/ghc/interpreter/connect.h @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: connect.h,v $ - * $Revision: 1.39 $ - * $Date: 2000/04/25 17:43:49 $ + * $Revision: 1.40 $ + * $Date: 2000/04/27 16:35:29 $ * ------------------------------------------------------------------------*/ /* -------------------------------------------------------------------------- @@ -788,7 +788,6 @@ extern Command readCommand ( struct cmd *, Char, Char ); * Freevar analysis: list of free vars after * Lambda lifting: freevar list or UNIT on input, discarded after * Code generation: unused - * Optimisation: number of uses (sort-of) of let-bound variable * ------------------------------------------------------------------------*/ typedef Cell StgRhs; @@ -886,16 +885,12 @@ extern Name implementRecShw ( Text ); extern Name implementRecEq ( Text ); #endif -/* Association list storing globals assigned to dictionaries, tuples, etc */ -extern List stgGlobals; - -extern List liftBinds ( List binds ); +extern void liftModule ( Module ); extern StgExpr substExpr ( List sub, StgExpr e ); extern List freeVarsBind ( List, StgVar ); -extern Void cgBinds ( StgRhs ); -extern void* closureOfVar ( StgVar ); +extern Void cgModule ( Module ); extern char* lookupHugsName ( void* ); diff --git a/ghc/interpreter/derive.c b/ghc/interpreter/derive.c index cd83f89..fccff4f 100644 --- a/ghc/interpreter/derive.c +++ b/ghc/interpreter/derive.c @@ -9,14 +9,16 @@ * included in the distribution. * * $RCSfile: derive.c,v $ - * $Revision: 1.14 $ - * $Date: 2000/03/23 14:54:20 $ + * $Revision: 1.15 $ + * $Date: 2000/04/27 16:35:29 $ * ------------------------------------------------------------------------*/ #include "hugsbasictypes.h" #include "storage.h" #include "connect.h" #include "errors.h" + +#include "Rts.h" /* to make StgPtr visible in Assembler.h */ #include "Assembler.h" List cfunSfuns; /* List of (Cfun,[SelectorVar]) */ @@ -910,14 +912,13 @@ Tycon t; { alts = cons(mkStgCaseAlt(c,vs,tag),alts); } - name(nm).line = tycon(t).line; - name(nm).type = conToTagType(t); - name(nm).arity = 1; - name(nm).stgVar = mkStgVar(mkStgLambda(singleton(v),mkStgCase(v,alts)), - NIL); + name(nm).line = tycon(t).line; + name(nm).type = conToTagType(t); + name(nm).arity = 1; + name(nm).closure = mkStgVar(mkStgLambda(singleton(v),mkStgCase(v,alts)), + NIL); tycon(t).conToTag = nm; - /* hack to make it print out */ - stgGlobals = cons(pair(nm,name(nm).stgVar),stgGlobals); + addToCodeList ( currentModule, nm ); } } @@ -979,24 +980,23 @@ Tycon t; { alts = cons(mkStgPrimAlt(singleton(pat),c),alts); } - name(nm).line = tycon(t).line; - name(nm).type = tagToConType(t); - name(nm).arity = 1; - name(nm).stgVar = mkStgVar( - mkStgLambda( - singleton(v1), - mkStgCase( - v1, - singleton( - mkStgCaseAlt( - nameMkI, - singleton(v2), - mkStgPrimCase(v2,alts))))), - NIL - ); + name(nm).line = tycon(t).line; + name(nm).type = tagToConType(t); + name(nm).arity = 1; + name(nm).closure = mkStgVar( + mkStgLambda( + singleton(v1), + mkStgCase( + v1, + singleton( + mkStgCaseAlt( + nameMkI, + singleton(v2), + mkStgPrimCase(v2,alts))))), + NIL + ); tycon(t).tagToCon = nm; - /* hack to make it print out */ - stgGlobals = cons(pair(nm,name(nm).stgVar),stgGlobals); + addToCodeList ( currentModule, nm ); } } diff --git a/ghc/interpreter/free.c b/ghc/interpreter/free.c index 9c85523..08d0a33 100644 --- a/ghc/interpreter/free.c +++ b/ghc/interpreter/free.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: free.c,v $ - * $Revision: 1.11 $ - * $Date: 2000/03/23 14:54:21 $ + * $Revision: 1.12 $ + * $Date: 2000/04/27 16:35:29 $ * ------------------------------------------------------------------------*/ #include "hugsbasictypes.h" @@ -118,6 +118,7 @@ static List freeVarsExpr( List acc, StgExpr e ) case STGVAR: return freeVarsVar(acc, e); case NAME: + case TUPLE: return acc; /* Names are never free vars */ default: printf("\n"); diff --git a/ghc/interpreter/hugs.c b/ghc/interpreter/hugs.c index 13776b5..2cef783 100644 --- a/ghc/interpreter/hugs.c +++ b/ghc/interpreter/hugs.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: hugs.c,v $ - * $Revision: 1.68 $ - * $Date: 2000/04/25 17:43:49 $ + * $Revision: 1.69 $ + * $Date: 2000/04/27 16:35:29 $ * ------------------------------------------------------------------------*/ #include @@ -1783,8 +1783,8 @@ static Void local evaluator() { /* evaluate expr and print value */ } else { Cell d = provePred(ks,NIL,ap(classShow,bd)); if (isNull(d)) { - clearCurrentFile(); - printing = FALSE; + clearCurrentFile(); + printing = FALSE; ERRMSG(0) "Cannot find \"show\" function for:" ETHEN ERRTEXT "\n*** expression : " ETHEN ERREXPR(inputExpr); ERRTEXT "\n*** of type : " ETHEN ERRTYPE(type); diff --git a/ghc/interpreter/interface.c b/ghc/interpreter/interface.c index 31d8d37..13a83e7 100644 --- a/ghc/interpreter/interface.c +++ b/ghc/interpreter/interface.c @@ -7,8 +7,8 @@ * Hugs version 1.4, December 1997 * * $RCSfile: interface.c,v $ - * $Revision: 1.56 $ - * $Date: 2000/04/25 17:43:49 $ + * $Revision: 1.57 $ + * $Date: 2000/04/27 16:35:29 $ * ------------------------------------------------------------------------*/ #include "hugsbasictypes.h" @@ -17,6 +17,7 @@ #include "errors.h" #include "object.h" +#include "Rts.h" /* to make StgPtr visible in Assembler.h */ #include "Assembler.h" /* for wrapping GHC objects */ /*#define DEBUG_IFACE*/ @@ -2485,7 +2486,7 @@ Type type; { * ------------------------------------------------------------------------*/ #define EXTERN_SYMS_ALLPLATFORMS \ - Sym(MainRegTable) \ + SymX(MainRegTable) \ Sym(stg_gc_enter_1) \ Sym(stg_gc_noregs) \ Sym(stg_gc_seq_1) \ @@ -2494,107 +2495,107 @@ Type type; { Sym(stg_chk_0) \ Sym(stg_chk_1) \ Sym(stg_gen_chk) \ - Sym(stg_exit) \ - Sym(stg_update_PAP) \ - Sym(stg_error_entry) \ - Sym(__ap_2_upd_info) \ - Sym(__ap_3_upd_info) \ - Sym(__ap_4_upd_info) \ - Sym(__ap_5_upd_info) \ - Sym(__ap_6_upd_info) \ - Sym(__ap_7_upd_info) \ - Sym(__ap_8_upd_info) \ - Sym(__sel_0_upd_info) \ - Sym(__sel_1_upd_info) \ - Sym(__sel_2_upd_info) \ - Sym(__sel_3_upd_info) \ - Sym(__sel_4_upd_info) \ - Sym(__sel_5_upd_info) \ - Sym(__sel_6_upd_info) \ - Sym(__sel_7_upd_info) \ - Sym(__sel_8_upd_info) \ - Sym(__sel_9_upd_info) \ - Sym(__sel_10_upd_info) \ - Sym(__sel_11_upd_info) \ - Sym(__sel_12_upd_info) \ - Sym(Upd_frame_info) \ - Sym(seq_frame_info) \ - Sym(CAF_BLACKHOLE_info) \ - Sym(IND_STATIC_info) \ - Sym(EMPTY_MVAR_info) \ - Sym(MUT_ARR_PTRS_FROZEN_info) \ - Sym(newCAF) \ - Sym(putMVarzh_fast) \ - Sym(newMVarzh_fast) \ - Sym(takeMVarzh_fast) \ - Sym(takeMaybeMVarzh_fast) \ - Sym(catchzh_fast) \ - Sym(raisezh_fast) \ - Sym(delayzh_fast) \ - Sym(yieldzh_fast) \ - Sym(killThreadzh_fast) \ - Sym(waitReadzh_fast) \ - Sym(waitWritezh_fast) \ - Sym(CHARLIKE_closure) \ - Sym(INTLIKE_closure) \ - Sym(suspendThread) \ - Sym(resumeThread) \ + SymX(stg_exit) \ + SymX(stg_update_PAP) \ + SymX(stg_error_entry) \ + SymX(__ap_2_upd_info) \ + SymX(__ap_3_upd_info) \ + SymX(__ap_4_upd_info) \ + SymX(__ap_5_upd_info) \ + SymX(__ap_6_upd_info) \ + SymX(__ap_7_upd_info) \ + SymX(__ap_8_upd_info) \ + SymX(__sel_0_upd_info) \ + SymX(__sel_1_upd_info) \ + SymX(__sel_2_upd_info) \ + SymX(__sel_3_upd_info) \ + SymX(__sel_4_upd_info) \ + SymX(__sel_5_upd_info) \ + SymX(__sel_6_upd_info) \ + SymX(__sel_7_upd_info) \ + SymX(__sel_8_upd_info) \ + SymX(__sel_9_upd_info) \ + SymX(__sel_10_upd_info) \ + SymX(__sel_11_upd_info) \ + SymX(__sel_12_upd_info) \ + SymX(Upd_frame_info) \ + SymX(seq_frame_info) \ + SymX(CAF_BLACKHOLE_info) \ + SymX(IND_STATIC_info) \ + SymX(EMPTY_MVAR_info) \ + SymX(MUT_ARR_PTRS_FROZEN_info) \ + SymX(newCAF) \ + SymX(putMVarzh_fast) \ + SymX(newMVarzh_fast) \ + SymX(takeMVarzh_fast) \ + SymX(takeMaybeMVarzh_fast) \ + SymX(catchzh_fast) \ + SymX(raisezh_fast) \ + SymX(delayzh_fast) \ + SymX(yieldzh_fast) \ + SymX(killThreadzh_fast) \ + SymX(waitReadzh_fast) \ + SymX(waitWritezh_fast) \ + SymX(CHARLIKE_closure) \ + SymX(INTLIKE_closure) \ + SymX(suspendThread) \ + SymX(resumeThread) \ Sym(stackOverflow) \ - Sym(int2Integerzh_fast) \ + SymX(int2Integerzh_fast) \ Sym(stg_gc_unbx_r1) \ - Sym(ErrorHdrHook) \ - Sym(mkForeignObjzh_fast) \ - Sym(__encodeDouble) \ - Sym(decodeDoublezh_fast) \ - Sym(isDoubleNaN) \ - Sym(isDoubleInfinite) \ - Sym(isDoubleDenormalized) \ - Sym(isDoubleNegativeZero) \ - Sym(__encodeFloat) \ - Sym(decodeFloatzh_fast) \ - Sym(isFloatNaN) \ - Sym(isFloatInfinite) \ - Sym(isFloatDenormalized) \ - Sym(isFloatNegativeZero) \ - Sym(__int_encodeFloat) \ - Sym(__int_encodeDouble) \ - Sym(mpz_cmp_si) \ - Sym(mpz_cmp) \ - Sym(__mpn_gcd_1) \ - Sym(gcdIntegerzh_fast) \ - Sym(newArrayzh_fast) \ - Sym(unsafeThawArrayzh_fast) \ - Sym(newDoubleArrayzh_fast) \ - Sym(newFloatArrayzh_fast) \ - Sym(newAddrArrayzh_fast) \ - Sym(newWordArrayzh_fast) \ - Sym(newIntArrayzh_fast) \ - Sym(newCharArrayzh_fast) \ - Sym(newMutVarzh_fast) \ - Sym(quotRemIntegerzh_fast) \ - Sym(quotIntegerzh_fast) \ - Sym(remIntegerzh_fast) \ - Sym(divExactIntegerzh_fast) \ - Sym(divModIntegerzh_fast) \ - Sym(timesIntegerzh_fast) \ - Sym(minusIntegerzh_fast) \ - Sym(plusIntegerzh_fast) \ - Sym(addr2Integerzh_fast) \ - Sym(mkWeakzh_fast) \ - Sym(prog_argv) \ - Sym(prog_argc) \ + SymX(ErrorHdrHook) \ + SymX(mkForeignObjzh_fast) \ + SymX(__encodeDouble) \ + SymX(decodeDoublezh_fast) \ + SymX(isDoubleNaN) \ + SymX(isDoubleInfinite) \ + SymX(isDoubleDenormalized) \ + SymX(isDoubleNegativeZero) \ + SymX(__encodeFloat) \ + SymX(decodeFloatzh_fast) \ + SymX(isFloatNaN) \ + SymX(isFloatInfinite) \ + SymX(isFloatDenormalized) \ + SymX(isFloatNegativeZero) \ + SymX(__int_encodeFloat) \ + SymX(__int_encodeDouble) \ + SymX(mpz_cmp_si) \ + SymX(mpz_cmp) \ + SymX(__mpn_gcd_1) \ + SymX(gcdIntegerzh_fast) \ + SymX(newArrayzh_fast) \ + SymX(unsafeThawArrayzh_fast) \ + SymX(newDoubleArrayzh_fast) \ + SymX(newFloatArrayzh_fast) \ + SymX(newAddrArrayzh_fast) \ + SymX(newWordArrayzh_fast) \ + SymX(newIntArrayzh_fast) \ + SymX(newCharArrayzh_fast) \ + SymX(newMutVarzh_fast) \ + SymX(quotRemIntegerzh_fast) \ + SymX(quotIntegerzh_fast) \ + SymX(remIntegerzh_fast) \ + SymX(divExactIntegerzh_fast) \ + SymX(divModIntegerzh_fast) \ + SymX(timesIntegerzh_fast) \ + SymX(minusIntegerzh_fast) \ + SymX(plusIntegerzh_fast) \ + SymX(addr2Integerzh_fast) \ + SymX(mkWeakzh_fast) \ + SymX(prog_argv) \ + SymX(prog_argc) \ Sym(resetNonBlockingFd) \ - Sym(getStablePtr) \ - Sym(stable_ptr_table) \ + SymX(getStablePtr) \ + SymX(stable_ptr_table) \ Sym(createAdjThunk) \ - Sym(shutdownHaskellAndExit) \ + SymX(shutdownHaskellAndExit) \ Sym(stg_enterStackTop) \ - Sym(CAF_UNENTERED_entry) \ + SymX(CAF_UNENTERED_entry) \ Sym(stg_yield_to_Hugs) \ Sym(StgReturn) \ Sym(init_stack) \ - Sym(blockAsyncExceptionszh_fast) \ - Sym(unblockAsyncExceptionszh_fast) \ + SymX(blockAsyncExceptionszh_fast) \ + SymX(unblockAsyncExceptionszh_fast) \ \ /* needed by libHS_cbits */ \ SymX(malloc) \ @@ -2667,7 +2668,7 @@ Type type; { #define EXTERN_SYMS_linux \ - Sym(__errno_location) \ + SymX(__errno_location) \ Sym(__xstat) \ Sym(__fxstat) \ Sym(__lxstat) \ @@ -2713,9 +2714,9 @@ EXTERN_SYMS_THISPLATFORM #define Sym(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \ - &(vvv) }, + (void*)(&(vvv)) }, #define SymX(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \ - &(vvv) }, + (void*)(&(vvv)) }, OSym rtsTab[] = { EXTERN_SYMS_ALLPLATFORMS diff --git a/ghc/interpreter/lift.c b/ghc/interpreter/lift.c index b41d1f5..a71e6ac 100644 --- a/ghc/interpreter/lift.c +++ b/ghc/interpreter/lift.c @@ -12,8 +12,8 @@ * included in the distribution. * * $RCSfile: lift.c,v $ - * $Revision: 1.13 $ - * $Date: 2000/03/23 14:54:21 $ + * $Revision: 1.14 $ + * $Date: 2000/04/27 16:35:29 $ * ------------------------------------------------------------------------*/ #include "hugsbasictypes.h" @@ -27,16 +27,14 @@ * ------------------------------------------------------------------------*/ static List liftedBinds = NIL; -static Bool makeInlineable = FALSE; -static Int inlineCounter = 0; -static StgExpr abstractExpr ( List vars, StgExpr e ); -static inline Bool isTopLevel( StgVar v ); -static List filterFreeVars( List vs ); -static List liftLetBinds ( List binds, Bool topLevel ); -static void liftAlt ( StgCaseAlt alt ); -static void liftPrimAlt ( StgPrimAlt alt ); -static void liftExpr ( StgExpr e ); +static StgExpr abstractExpr ( List vars, StgExpr e ); +static Bool isTopLevel ( StgVar v ); +static List filterFreeVars ( List vs ); +static List liftLetBinds ( List binds, Bool topLevel ); +static void liftAlt ( StgCaseAlt alt ); +static void liftPrimAlt ( StgPrimAlt alt ); +static void liftExpr ( StgExpr e ); /* -------------------------------------------------------------------------- * Lambda lifter @@ -59,7 +57,7 @@ static StgExpr abstractExpr( List vars, StgExpr e ) /* ToDo: should be conservative estimate but isn't */ /* Will a variable be floated out to top level - conservative estimate? */ -static inline Bool isTopLevel( StgVar v ) +static Bool isTopLevel( StgVar v ) { if (isNull(stgVarBody(v))) { return FALSE; /* only let bound vars can be floated */ @@ -86,9 +84,11 @@ static List filterFreeVars( List vs ) } } +static Int nameCounter; + static List liftLetBinds( List binds, Bool topLevel ) { - List bs = NIL; + List bs = NIL; for(; nonNull(binds); binds=tl(binds)) { StgVar bind = hd(binds); StgRhs rhs = stgVarBody(bind); @@ -105,16 +105,14 @@ static List liftLetBinds( List binds, Bool topLevel ) liftExpr(rhs); if (nonNull(fvs)) { StgVar v = mkStgVar(abstractExpr(fvs,rhs),NONE); - liftedBinds = cons(v,liftedBinds); - if (makeInlineable) { + { Name n; char s[16]; - sprintf(s,"lam%d",inlineCounter++); + sprintf(s,"(lift%d)",nameCounter++); n = newName(findText(s),NIL); - name(n).stgVar = v; + name(n).closure = v; stgVarBody(bind) = makeStgApp(n, fvs); - } else { - stgVarBody(bind) = makeStgApp(v, fvs); + liftedBinds = cons(n,liftedBinds); } } bs = cons(bind,bs); @@ -160,36 +158,40 @@ static void liftExpr( StgExpr e ) break; case STGVAR: case NAME: + case TUPLE: break; default: internal("liftExpr"); } } -/* Lift a list of top-level binds. */ -List liftBinds( List binds ) +/* Lift the list of top-level binds for a module. */ +void liftModule ( Module mod ) { - List bs; - - for(bs=binds; nonNull(bs); bs=tl(bs)) { - StgVar bind = hd(bs); - + List binds = NIL; + List cl; + + nameCounter = 0; + for (cl = module(mod).codeList; nonNull(cl); cl = tl(cl)) { + StgVar bind = getNameOrTupleClosure(hd(cl)); + if (isCPtr(bind)) continue; + assert(nonNull(bind)); if (debugSC) { if (currentModule != modulePrelude) { fprintf(stderr, "\n"); - ppStg(hd(bs)); + ppStg(bind); fprintf(stderr, "\n"); } } freeVarsBind(NIL,bind); stgVarInfo(bind) = NONE; /* mark as top level */ + binds = cons(bind,binds); } liftedBinds = NIL; binds = liftLetBinds(binds,TRUE); - binds = revOnto(liftedBinds,binds); + module(mod).codeList = revOnto(liftedBinds, module(mod).codeList); liftedBinds = NIL; - return binds; } /* -------------------------------------------------------------------------- diff --git a/ghc/interpreter/link.c b/ghc/interpreter/link.c index 39b2c8f..7e405d0 100644 --- a/ghc/interpreter/link.c +++ b/ghc/interpreter/link.c @@ -9,16 +9,16 @@ * included in the distribution. * * $RCSfile: link.c,v $ - * $Revision: 1.59 $ - * $Date: 2000/04/17 13:28:17 $ + * $Revision: 1.60 $ + * $Date: 2000/04/27 16:35:29 $ * ------------------------------------------------------------------------*/ #include "hugsbasictypes.h" #include "storage.h" #include "connect.h" #include "errors.h" -#include "Assembler.h" /* for asmPrimOps and AsmReps */ #include "Rts.h" /* to make Prelude.h palatable */ +#include "Assembler.h" /* for asmPrimOps and AsmReps */ #include "Prelude.h" /* for fixupRTStoPreludeRefs */ @@ -773,46 +773,36 @@ assert(nonNull(namePMFail)); pFun(namePrimRaise, "primRaise"); pFun(namePrimTakeMVar, "primTakeMVar"); { - StgVar vv = mkStgVar(NIL,NIL); - Name n = namePrimSeq; - name(n).line = 0; - name(n).arity = 1; - name(n).type = NIL; - vv = mkStgVar(NIL,NIL); - stgVarInfo(vv) = mkPtr ( asm_BCO_seq() ); - name(n).stgVar = vv; - stgGlobals=cons(pair(n,vv),stgGlobals); - namePrimSeq = n; + Name n = namePrimSeq; + name(n).line = 0; + name(n).arity = 1; + name(n).type = NIL; + name(n).closure = mkCPtr ( asm_BCO_seq() ); + addToCodeList ( modulePrelPrim, n ); } { - StgVar vv = mkStgVar(NIL,NIL); - Name n = namePrimCatch; - name(n).line = 0; - name(n).arity = 2; - name(n).type = NIL; - stgVarInfo(vv) = mkPtr ( asm_BCO_catch() ); - name(n).stgVar = vv; - stgGlobals=cons(pair(n,vv),stgGlobals); + Name n = namePrimCatch; + name(n).line = 0; + name(n).arity = 2; + name(n).type = NIL; + name(n).closure = mkCPtr ( asm_BCO_catch() ); + addToCodeList ( modulePrelPrim, n ); } { - StgVar vv = mkStgVar(NIL,NIL); - Name n = namePrimRaise; - name(n).line = 0; - name(n).arity = 1; - name(n).type = NIL; - stgVarInfo(vv) = mkPtr ( asm_BCO_raise() ); - name(n).stgVar = vv; - stgGlobals=cons(pair(n,vv),stgGlobals); + Name n = namePrimRaise; + name(n).line = 0; + name(n).arity = 1; + name(n).type = NIL; + name(n).closure = mkCPtr ( asm_BCO_raise() ); + addToCodeList ( modulePrelPrim, n ); } { - StgVar vv = mkStgVar(NIL,NIL); - Name n = namePrimTakeMVar; - name(n).line = 0; - name(n).arity = 2; - name(n).type = NIL; - stgVarInfo(vv) = mkPtr ( asm_BCO_takeMVar() ); - name(n).stgVar = vv; - stgGlobals=cons(pair(n,vv),stgGlobals); + Name n = namePrimTakeMVar; + name(n).line = 0; + name(n).arity = 2; + name(n).type = NIL; + name(n).closure = mkCPtr ( asm_BCO_takeMVar() ); + addToCodeList ( modulePrelPrim, n ); } } break; @@ -820,5 +810,4 @@ assert(nonNull(namePMFail)); } #undef pFun -//#include "fooble.c" /*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/object.c b/ghc/interpreter/object.c index 762b382..e676f59 100644 --- a/ghc/interpreter/object.c +++ b/ghc/interpreter/object.c @@ -81,7 +81,9 @@ ObjectCode* ocNew ( void (*errMsg)(char*), oc->sizesectionTab = 0; oc->usedsectionTab = 0; oc->next = NULL; - +fprintf ( stderr, "ocNew: loading into %10p .. %10p (%d)\n", + ((char*)(oc->oImage)), + ((char*)(oc->oImage)) + objFileSize - 1, objFileSize ); return oc; } diff --git a/ghc/interpreter/stg.c b/ghc/interpreter/stg.c index 0fd6df1..08defee 100644 --- a/ghc/interpreter/stg.c +++ b/ghc/interpreter/stg.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: stg.c,v $ - * $Revision: 1.15 $ - * $Date: 2000/03/23 14:54:21 $ + * $Revision: 1.16 $ + * $Date: 2000/04/27 16:35:29 $ * ------------------------------------------------------------------------*/ #include "hugsbasictypes.h" @@ -18,6 +18,7 @@ #include "connect.h" #include "errors.h" +#include "Rts.h" /* to make StgPtr visible in Assembler.h */ #include "Assembler.h" /* for AsmRep and primops */ /* -------------------------------------------------------------------------- @@ -137,7 +138,7 @@ StgRhs e; { case BIGCELL: case FLOATCELL: case STRCELL: - case PTRCELL: + case ADDRCELL: return TRUE; default: return FALSE; @@ -192,6 +193,10 @@ static Void putStgAlts ( Int left, List alts ); static Void local putStgVar(StgVar v) { + if (isTuple(v)) { + putStr("Tuple"); + putInt(tupleOf(v)); + } else if (isName(v)) { unlexVar(name(v).text); } else { @@ -242,8 +247,8 @@ static Void local putStgAtom( StgAtom a ) case STRCELL: unlexStrConst(textOf(a)); break; - case PTRCELL: - putPtr(ptrOf(a)); + case ADDRCELL: + putPtr(addrOf(a)); putChr('#'); break; case LETREC: case LAMBDA: case CASE: case PRIMCASE: @@ -403,7 +408,10 @@ static Void putStgPrimAlts( Int left, List alts ) Void putStgExpr( StgExpr e ) /* pretty print expr */ { - if (isNull(e)) putStr("(putStgExpr:NIL)");else + if (isNull(e)) { + putStr("(putStgExpr:NIL)"); + return; + } switch (whatIs(e)) { case LETREC: @@ -472,6 +480,7 @@ Void putStgExpr( StgExpr e ) /* pretty print expr */ break; case STGVAR: case NAME: + case TUPLE: putStgVar(e); break; case CHARCELL: @@ -479,7 +488,7 @@ Void putStgExpr( StgExpr e ) /* pretty print expr */ case BIGCELL: case FLOATCELL: case STRCELL: - case PTRCELL: + case ADDRCELL: putStgAtom(e); break; case AP: @@ -542,7 +551,7 @@ StgVar b; { Name n; beginStgPP(fp); - n = nameFromStgVar(b); + n = NIL; /* nameFromStgVar(b); */ if (nonNull(n)) { putStr(textToStr(name(n).text)); } else { diff --git a/ghc/interpreter/storage.c b/ghc/interpreter/storage.c index 2bd85a2..6995b10 100644 --- a/ghc/interpreter/storage.c +++ b/ghc/interpreter/storage.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: storage.c,v $ - * $Revision: 1.72 $ - * $Date: 2000/04/25 17:43:50 $ + * $Revision: 1.73 $ + * $Date: 2000/04/27 16:35:29 $ * ------------------------------------------------------------------------*/ #include "hugsbasictypes.h" @@ -660,6 +660,7 @@ Tycon newTycon ( Text t ) /* add new tycon to tycon table */ tycon(tc).tagToCon = NIL; tycon(tc).itbl = NULL; tycon(tc).arity = 0; + tycon(tc).closure = NIL; module(currentModule).tycons = cons(tc,module(currentModule).tycons); tycon(tc).nextTyconHash = tyconHash[RC_T(h)]; tyconHash[RC_T(h)] = tc; @@ -876,14 +877,14 @@ Name newName ( Text t, Cell parent ) /* Add new name to name table */ name(nm).number = EXECNAME; name(nm).defn = NIL; name(nm).hasStrict = FALSE; - name(nm).stgVar = NIL; name(nm).callconv = NIL; name(nm).type = NIL; name(nm).primop = NULL; name(nm).itbl = NULL; + name(nm).closure = NIL; module(currentModule).names = cons(nm,module(currentModule).names); name(nm).nextNameHash = nameHash[RC_N(h)]; - nameHash[RC_N(h)] = nm; + nameHash[RC_N(h)] = nm; return nm; } @@ -964,33 +965,21 @@ Cell id; { /* in name table */ } -Name nameFromStgVar ( StgVar v ) +void* /* StgClosure* */ getHugs_BCO_cptr_for ( char* s ) { - Int n; - for (n = NAME_BASE_ADDR; - n < NAME_BASE_ADDR+tabNameSz; n++) - if (tabName[n-NAME_BASE_ADDR].inUse) - if (name(n).stgVar == v) return n; - return NIL; -} - -void* getHugs_AsmObject_for ( char* s ) -{ - StgVar v; Text t = findText(s); Name n = NIL; for (n = NAME_BASE_ADDR; n < NAME_BASE_ADDR+tabNameSz; n++) - if (tabName[n-NAME_BASE_ADDR].inUse) - if (name(n).text == t) break; + if (tabName[n-NAME_BASE_ADDR].inUse && name(n).text == t) + break; if (n == NAME_BASE_ADDR+tabNameSz) { fprintf ( stderr, "can't find `%s' in ...\n", s ); - internal("getHugs_AsmObject_for(1)"); + internal("getHugs_BCO_cptr_for(1)"); } - v = name(n).stgVar; - if (!isStgVar(v) || !isPtr(stgVarInfo(v))) - internal("getHugs_AsmObject_for(2)"); - return ptrOf(stgVarInfo(v)); + if (!isCPtr(name(n).closure)) + internal("getHugs_BCO_cptr_for(2)"); + return cptrOf(name(n).closure); } /* -------------------------------------------------------------------------- @@ -1331,6 +1320,7 @@ Inst newInst() { /* Add new instance to table */ inst(in).kinds = NIL; inst(in).head = NIL; inst(in).specifics = NIL; + inst(in).numSpecifics = 0; inst(in).implements = NIL; inst(in).builder = NIL; return in; @@ -1610,6 +1600,7 @@ Module newModule ( Text t ) /* add new module to module table */ module(mod).classes = NIL; module(mod).exports = NIL; module(mod).qualImports = NIL; + module(mod).codeList = NIL; module(mod).fake = FALSE; module(mod).tree = NIL; @@ -1669,7 +1660,8 @@ void nukeModule ( Module m ) module(name(i).mod).mode == FM_SOURCE) { free(name(i).itbl); } - name(i).itbl = NULL; + name(i).itbl = NULL; + name(i).closure = NIL; freeName(i); } @@ -1784,6 +1776,47 @@ Module m; { hashSanity(); } +void addToCodeList ( Module m, Cell c ) +{ + assert(isName(c) || isTuple(c)); + if (nonNull(getNameOrTupleClosure(c))) + module(m).codeList = cons ( c, module(m).codeList ); + /* fprintf ( stderr, "addToCodeList %s %s\n", + textToStr(module(m).text), + textToStr( isTuple(c) ? tycon(c).text : name(c).text ) ); + */ +} + +Cell getNameOrTupleClosure ( Cell c ) +{ + if (isName(c)) return name(c).closure; + else if (isTuple(c)) return tycon(c).closure; + else internal("getNameOrTupleClosure"); +} + +void setNameOrTupleClosure ( Cell c, Cell closure ) +{ + if (isName(c)) name(c).closure = closure; + else if (isTuple(c)) tycon(c).closure = closure; + else internal("setNameOrTupleClosure"); +} + +/* This function is used in ghc/rts/Assembler.c. */ +void* /* StgClosure* */ getNameOrTupleClosureCPtr ( Cell c ) +{ + return cptrOf(getNameOrTupleClosure(c)); +} + +/* used in codegen.c */ +void setNameOrTupleClosureCPtr ( Cell c, void* /* StgClosure* */ cptr ) +{ + if (isName(c)) name(c).closure = mkCPtr(cptr); + else if (isTuple(c)) tycon(c).closure = mkCPtr(cptr); + else internal("setNameOrTupleClosureCPtr"); +} + + + Name jrsFindQualName ( Text mn, Text sn ) { Module m; @@ -1900,6 +1933,39 @@ OSectionKind lookupSection ( void* ad ) } +/* Called by the evaluator's GC to tell Hugs to mark stuff in the + run-time heap. +*/ +void markHugsObjects( void ) +{ + Name nm; + Tycon tc; + + for ( nm = NAME_BASE_ADDR; + nm < NAME_BASE_ADDR+tabNameSz; ++nm ) { + if (tabName[nm-NAME_BASE_ADDR].inUse) { + Cell cl = name(nm).closure; + if (nonNull(cl)) { + assert(isCPtr(cl)); + snd(cl) = MarkRoot ( snd(cl) ); + } + } + } + + for ( tc = TYCON_BASE_ADDR; + tc < TYCON_BASE_ADDR+tabTyconSz; ++tc ) { + if (tabTycon[tc-TYCON_BASE_ADDR].inUse) { + Cell cl = tycon(tc).closure; + if (nonNull(cl)) { + assert(isCPtr(cl)); + snd(cl) = MarkRoot ( snd(cl) ); + } + } + } + +} + + /* -------------------------------------------------------------------------- * Heap storage: * @@ -2281,8 +2347,17 @@ Void print ( Cell c, Int depth ) case CHARCELL: Printf("char('%c')", charOf(c)); break; - case PTRCELL: - Printf("ptr(%p)",ptrOf(c)); + case STRCELL: + Printf("strcell(\"%s\")",textToStr(snd(c))); + break; + case MPTRCELL: + Printf("mptr(%p)",mptrOf(c)); + break; + case CPTRCELL: + Printf("cptr(%p)",cptrOf(c)); + break; + case ADDRCELL: + Printf("addr(%p)",addrOf(c)); break; case CLASS: Printf("class(%d)", c-CCLASS_BASE_ADDR); @@ -2567,19 +2642,36 @@ Int n; { typedef union {Int i; Ptr p;} IntOrPtr; -Cell mkPtr(p) +Cell mkAddr(p) Ptr p; { IntOrPtr x; x.p = p; - return pair(PTRCELL,x.i); + return pair(ADDRCELL,x.i); } -Ptr ptrOf(c) +Ptr addrOf(c) Cell c; { IntOrPtr x; - assert(fst(c) == PTRCELL); + assert(fst(c) == ADDRCELL); + x.i = snd(c); + return x.p; +} + +Cell mkMPtr(p) +Ptr p; +{ + IntOrPtr x; + x.p = p; + return pair(MPTRCELL,x.i); +} + +Ptr mptrOf(c) +Cell c; +{ + IntOrPtr x; + assert(fst(c) == MPTRCELL); x.i = snd(c); return x.p; } @@ -3106,10 +3198,10 @@ void dumpName ( Int n ) printf ( " number: %d\n", name(n).number ); printf ( " type: "); print100(name(n).type); printf ( " defn: %d\n", name(n).defn ); - printf ( " stgVar: "); print100(name(n).stgVar); printf ( " cconv: %d\n", name(n).callconv ); printf ( " primop: %p\n", name(n).primop ); printf ( " itbl: %p\n", name(n).itbl ); + printf ( " closure: %d\n", name(n).closure ); printf ( " nextNH: %d\n", name(n).nextNameHash ); printf ( "}\n" ); } @@ -3200,7 +3292,7 @@ Int what; { mark(name(i).parent); mark(name(i).type); mark(name(i).defn); - mark(name(i).stgVar); + mark(name(i).closure); } } end("Names", nameHw-NAMEMIN); @@ -3214,6 +3306,7 @@ Int what; { mark(module(i).classes); mark(module(i).exports); mark(module(i).qualImports); + mark(module(i).codeList); mark(module(i).tree); mark(module(i).uses); mark(module(i).objectExtraNames); @@ -3231,6 +3324,7 @@ Int what; { mark(tycon(i).kind); mark(tycon(i).what); mark(tycon(i).defn); + mark(tycon(i).closure); } } end("Type constructors", tyconHw-TYCMIN); diff --git a/ghc/interpreter/storage.h b/ghc/interpreter/storage.h index 069d730..0cbf7df 100644 --- a/ghc/interpreter/storage.h +++ b/ghc/interpreter/storage.h @@ -10,8 +10,8 @@ * included in the distribution. * * $RCSfile: storage.h,v $ - * $Revision: 1.44 $ - * $Date: 2000/04/25 17:43:50 $ + * $Revision: 1.45 $ + * $Date: 2000/04/27 16:35:29 $ * ------------------------------------------------------------------------*/ #define DEBUG_STORAGE /* a moderate level of sanity checking */ @@ -60,7 +60,7 @@ typedef Cell ConVarId; * -heapSize .. -1 cells in the heap * 0 NIL * - * TAG_NONPTR_MIN(100) .. TAG_NONPTR_MAX(115) non pointer tags + * TAG_NONPTR_MIN(100) .. TAG_NONPTR_MAX(116) non pointer tags * TAG_PTR_MIN(200) .. TAG_PTR_MAX(298) pointer tags * TAG_SPEC_MIN(400) .. TAG_SPEC_MAX(431) special tags * OFF_MIN(1,000) .. OFF_MAX(1,999) offsets @@ -196,7 +196,7 @@ extern Cell whatIs ( Cell ); * ------------------------------------------------------------------------*/ #define TAG_NONPTR_MIN 100 -#define TAG_NONPTR_MAX 115 +#define TAG_NONPTR_MAX 116 #define FREECELL 100 /* Free list cell: snd :: Cell */ #define VARIDCELL 101 /* Identifier variable: snd :: Text */ @@ -209,16 +209,17 @@ extern Cell whatIs ( Cell ); #define ADDPAT 108 /* (_+k) pattern discr: snd :: Int */ #define FLOATCELL 109 /* Floating Pt literal: snd :: Text */ #define BIGCELL 110 /* Integer literal: snd :: Text */ -#define PTRCELL 111 /* C Heap Pointer snd :: Ptr */ -#define CPTRCELL 112 /* Native code pointer snd :: Ptr */ +#define ADDRCELL 111 /* Address literal snd :: Ptr */ +#define MPTRCELL 112 /* C (malloc) Heap Pointer snd :: Ptr */ +#define CPTRCELL 113 /* Closure pointer snd :: Ptr */ #if IPARAM -#define IPCELL 113 /* Imp Param Cell: snd :: Text */ -#define IPVAR 114 /* ?x: snd :: Text */ +#define IPCELL 114 /* Imp Param Cell: snd :: Text */ +#define IPVAR 115 /* ?x: snd :: Text */ #endif #if TREX -#define EXTCOPY 115 /* Copy of an Ext: snd :: Text */ +#define EXTCOPY 116 /* Copy of an Ext: snd :: Text */ #endif #define qmodOf(c) (textOf(fst(snd(c)))) /* c :: QUALIDENT */ @@ -266,12 +267,15 @@ extern Text textOf ( Cell ); #define stringToBignum(s) pair(BIGCELL,findText(s)) #define bignumToString(b) textToStr(snd(b)) -#define isPtr(c) (isPair(c) && fst(c)==PTRCELL) -extern Cell mkPtr ( Ptr ); -extern Ptr ptrOf ( Cell ); +#define isMPtr(c) (isPair(c) && fst(c)==MPTRCELL) +extern Cell mkMPtr ( Ptr ); +extern Ptr mptrOf ( Cell ); #define isCPtr(c) (isPair(c) && fst(c)==CPTRCELL) extern Cell mkCPtr ( Ptr ); extern Ptr cptrOf ( Cell ); +#define isAddr(c) (isPair(c) && fst(c)==ADDRCELL) +extern Cell mkAddr ( Ptr ); +extern Ptr addrOf ( Cell ); /* -------------------------------------------------------------------------- * Tags for pointer cells. @@ -594,6 +598,9 @@ struct strModule { List qualImports; /* Qualified imports. */ + List codeList; /* [ Name | StgTree ] before code generation, + [ Name | CPtr ] afterwards */ + Bool fake; /* TRUE if module exists only via GHC primop */ /* defn; usually FALSE */ @@ -628,6 +635,12 @@ extern Void nukeModule ( Module ); extern Module findModule ( Text ); extern Module findModid ( Cell ); extern Void setCurrModule ( Module ); +extern void addToCodeList ( Module, Cell ); +extern void setNameOrTupleClosure ( Cell c, Cell closure ); +extern Cell getNameOrTupleClosure ( Cell c ); +extern void setNameOrTupleClosureCPtr ( Cell c, + void* /* StgClosure* */ cptr ); + extern void addOTabName ( Module,char*,void* ); extern void* lookupOTabName ( Module,char* ); @@ -684,6 +697,11 @@ struct strTycon { Name conToTag; /* used in derived code */ Name tagToCon; void* itbl; /* For tuples, the info tbl pointer */ + Cell closure; /* Either StgTree, or (later) CPtr, which is the + address in the evaluator's heap. Only Tuples + use the closure field; all other tycons which + require actual code have associated name table + entries. */ Tycon nextTyconHash; }; @@ -743,10 +761,12 @@ struct strName { Cell type; Cell defn; Bool hasStrict; /* does constructor have strict components? */ - Cell stgVar; /* really StgVar */ Text callconv; /* for foreign import/export */ void* primop; /* really StgPrim* */ void* itbl; /* For constructors, the info tbl pointer */ + Cell closure; /* Either StgTree, or (later) Ptr, an AsmBCO/ + AsmCAF/AsmCon thing, or CPtr, which is the + address in the evaluator's heap */ Name nextNameHash; }; @@ -791,7 +811,6 @@ extern Name findQualName ( Cell ); extern Name addPrimCfun ( Text,Int,Int,Cell ); extern Name addPrimCfunREP ( Text,Int,Int,Int ); extern Int sfunPos ( Name,Name ); -extern Name nameFromStgVar ( Cell ); extern Name jrsFindQualName ( Text,Text ); extern Name findQualNameWithoutConsultingExportList ( QualId q ); diff --git a/ghc/interpreter/translate.c b/ghc/interpreter/translate.c index d20fd7b..0ccd6eb 100644 --- a/ghc/interpreter/translate.c +++ b/ghc/interpreter/translate.c @@ -10,8 +10,8 @@ * included in the distribution. * * $RCSfile: translate.c,v $ - * $Revision: 1.33 $ - * $Date: 2000/04/06 15:05:30 $ + * $Revision: 1.34 $ + * $Date: 2000/04/27 16:35:29 $ * ------------------------------------------------------------------------*/ #include "hugsbasictypes.h" @@ -19,6 +19,7 @@ #include "connect.h" #include "errors.h" +#include "Rts.h" /* to make StgPtr visible in Assembler.h */ #include "Assembler.h" @@ -32,10 +33,7 @@ static StgExpr local stgExpr ( Cell,Int,List,StgExpr ); /* ---------------------------------------------------------------- */ -/* Association list storing globals assigned to */ -/* dictionaries, tuples, etc */ -List stgGlobals = NIL; - +#if 0 static StgVar local getSTGTupleVar ( Cell d ) { Pair p = cellAssoc(d,stgGlobals); @@ -47,6 +45,7 @@ static StgVar local getSTGTupleVar ( Cell d ) assert(nonNull(p)); return snd(p); } +#endif /* ---------------------------------------------------------------- */ @@ -86,7 +85,8 @@ StgExpr failExpr; { case VAROPCELL: return stgText(textOf(e),sc); case TUPLE: - return getSTGTupleVar(e); + /* return getSTGTupleVar(e); */ + return e; case NAME: return e; /* Literals */ @@ -448,7 +448,7 @@ Void stgDefn( Name n, Int arity, Cell e ) vs = cons(nv,vs); sc = cons(pair(mkOffset(i),nv),sc); } - stgVarBody(name(n).stgVar) + stgVarBody(name(n).closure) = makeStgLambda(vs,stgExpr(e,arity,sc,namePMFail)); } @@ -476,13 +476,13 @@ List scs; { /* in incr order of strict fields. */ binds = rev(binds); e1 = mkStgLet(binds,vcurr); v = mkStgVar(mkStgLambda(dupOnto(argsd,args),e1),NIL); - name(c).stgVar = v; + name(c).closure = v; } else { StgVar v = mkStgVar(mkStgCon(c,NIL),NIL); - name(c).stgVar = v; + name(c).closure = v; } - stgGlobals = cons(pair(c,name(c).stgVar),stgGlobals); - /* printStg(stderr, name(c).stgVar); fprintf(stderr,"\n\n"); */ + addToCodeList ( currentModule, c ); + /* printStg(stderr, name(c).closure); fprintf(stderr,"\n\n"); */ } /* -------------------------------------------------------------------------- @@ -745,8 +745,8 @@ Name n; { const AsmPrim* p = name(n).primop; StgRhs rhs = makeStgPrim(n,p->monad!=MONAD_Id,NIL,p->args,p->results); StgVar v = mkStgVar(rhs,NIL); - name(n).stgVar = v; - stgGlobals=cons(pair(n,v),stgGlobals); /* so it will get codegened */ + name(n).closure = v; + addToCodeList ( currentModule, n ); } /* Generate wrapper code from (in,out) type lists. @@ -847,7 +847,7 @@ Void implementForeignImport ( Name n ) if (dynamic) { funPtr = NULL; - extra_args = singleton(mkPtr(descriptor)); + extra_args = singleton(mkAddr(descriptor)); /* and we know that the first arg will be the function pointer */ } else { extName = name(n).defn; @@ -861,7 +861,7 @@ Void implementForeignImport ( Name n ) textToStr(textOf(fst(extName))) EEND; } - extra_args = doubleton(mkPtr(descriptor),mkPtr(funPtr)); + extra_args = doubleton(mkAddr(descriptor),mkAddr(funPtr)); } rhs = makeStgPrim(n,addState,extra_args, @@ -869,11 +869,11 @@ Void implementForeignImport ( Name n ) descriptor->result_tys); v = mkStgVar(rhs,NIL); name(n).defn = NIL; - name(n).stgVar = v; - stgGlobals = cons(pair(n,v),stgGlobals); + name(n).closure = v; + addToCodeList ( currentModule, n ); } - /* At this point the descriptor contains a tags for all args, + /* At this point the descriptor contains a tag for each arg, because that makes makeStgPrim generate the correct unwrap code. From now on, the descriptor is only used at the time the actual ccall is made. So we need to zap the leading @@ -987,23 +987,23 @@ Void implementForeignExport ( Name n ) v = mkStgVar(fun,NIL); name(n).defn = NIL; - name(n).stgVar = v; - stgGlobals = cons(pair(n,v),stgGlobals); + name(n).closure = v; + addToCodeList ( currentModule, n ); } } Void implementTuple(size) Int size; { if (size > 0) { - Cell t = mkTuple(size); - List args = makeArgs(size); - StgVar tv = mkStgVar(mkStgCon(t,args),NIL); - StgExpr e = mkStgLet(singleton(tv),tv); - StgVar v = mkStgVar(mkStgLambda(args,e),NIL); - stgGlobals = cons(pair(t,v),stgGlobals); /* so we can see it */ + Tycon t = mkTuple(size); + List args = makeArgs(size); + StgVar tv = mkStgVar(mkStgCon(t,args),NIL); + StgExpr e = mkStgLet(singleton(tv),tv); + StgVar v = mkStgVar(mkStgLambda(args,e),NIL); + tycon(t).closure = v; + addToCodeList ( currentModule, t ); } else { - StgVar tv = mkStgVar(mkStgCon(nameUnit,NIL),NIL); - stgGlobals = cons(pair(nameUnit,tv),stgGlobals); /* ditto */ + addToCodeList ( currentModule, nameUnit ); } } @@ -1017,10 +1017,8 @@ Int what; { case POSTPREL: break; case PREPREL: case RESET: - stgGlobals=NIL; break; case MARK: - mark(stgGlobals); break; } } diff --git a/ghc/interpreter/type.c b/ghc/interpreter/type.c index eb2d2d9..05501a6 100644 --- a/ghc/interpreter/type.c +++ b/ghc/interpreter/type.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: type.c,v $ - * $Revision: 1.34 $ - * $Date: 2000/04/06 14:23:55 $ + * $Revision: 1.35 $ + * $Date: 2000/04/27 16:35:30 $ * ------------------------------------------------------------------------*/ #include "hugsbasictypes.h" @@ -18,6 +18,7 @@ #include "connect.h" #include "errors.h" +#include "Rts.h" /* to make StgPtr visible in Assembler.h */ #include "Assembler.h" /* for AsmCTypes */ /*#define DEBUG_TYPES*/ diff --git a/ghc/rts/Assembler.c b/ghc/rts/Assembler.c index a382920..2418d84 100644 --- a/ghc/rts/Assembler.c +++ b/ghc/rts/Assembler.c @@ -5,8 +5,8 @@ * Copyright (c) 1994-1998. * * $RCSfile: Assembler.c,v $ - * $Revision: 1.26 $ - * $Date: 2000/04/14 15:18:06 $ + * $Revision: 1.27 $ + * $Date: 2000/04/27 16:35:30 $ * * This module provides functions to construct BCOs and other closures * required by the bytecode compiler. @@ -58,206 +58,320 @@ #include "Assembler.h" #undef INSIDE_ASSEMBLER_C -/* -------------------------------------------------------------------------- - * References between BCOs - * - * These are necessary because there can be circular references between - * BCOs so we have to keep track of all the references to each object - * and fill in all the references once we're done. - * - * ToDo: generalise to allow references between any objects - * ------------------------------------------------------------------------*/ +static StgClosure* asmAlloc ( nat size ); +extern void* getNameOrTupleClosureCPtr ( int /*Cell*/ c ); -typedef struct { - AsmObject ref; /* who refers to it */ - AsmNat i; /* index into some table held by referer */ -} AsmRef; /* -------------------------------------------------------------------------- - * Queues (of instructions, ptrs, nonptrs) + * Initialising and managing objects and entities * ------------------------------------------------------------------------*/ -#define Queue Instrs -#define Type StgWord8 -#define MAKE_findIn 0 -#include "QueueTemplate.h" -#undef MAKE_findIn -#undef Type -#undef Queue - -#define Queue Ptrs -#define Type AsmObject -#define MAKE_findIn 0 -#include "QueueTemplate.h" -#undef MAKE_findIn -#undef Type -#undef Queue - -#define Queue Refs -#define Type AsmRef -#define MAKE_findIn 0 -#include "QueueTemplate.h" -#undef MAKE_findIn -#undef Type -#undef Queue - -#define Queue NonPtrs -#define Type StgWord -#define MAKE_findIn 1 -#include "QueueTemplate.h" -#undef MAKE_findIn -#undef Type -#undef Queue - -/* -------------------------------------------------------------------------- - * AsmObjects are used to build heap objects. - * - * AsmObjects can contain circular references to each other - * so we have to keep track of all the references which can't be filled - * in yet. - * - * When we finish building an AsmObject, we allocate an actual heap object and - * fill in all the references to the asmObject with pointers to the heap object. - * - * We obtain a limited form of polymorphism through inheritance by putting - * the AsmObject first in every structure (as in C++ implementations). - * We use the closure type of the allocated object to figure out - * where the payload lives in the closure. - * ------------------------------------------------------------------------*/ -/* ToDo: clean up terminology: is Closure right or should it be object or ... */ - -struct AsmObject_ { - Refs refs; - Ptrs ptrs; - AsmNat num_unresolved; /* number of unfilled references */ - StgClosure* closure; /* where object was allocated */ -}; - -struct AsmCon_ { - struct AsmObject_ object; /* must be first in struct */ - - AsmInfo info; -}; - -struct AsmCAF_ { - struct AsmObject_ object; /* must be first in struct */ -}; +static struct AsmObject_* objects; + +#define INITIALISE_TABLE(Type,table,size,used) \ + size = used = 0; \ + table = NULL; + +#define ENSURE_SPACE_IN_TABLE(Type,table,size,used) \ + if (used == size) { \ + Type* new; \ + size = (size ? 2*size : 1); \ + new = malloc ( size * sizeof(Type)); \ + if (!new) \ + barf("bytecode assembler: can't expand table of type " \ + #Type); \ + memcpy ( new, table, used * sizeof(Type) ); \ + if (table) free(table); \ + table = new; \ + } -struct AsmBCO_ { - struct AsmObject_ object; /* must be first in struct */ +void asmInitialise ( void ) +{ + objects = NULL; +} - Instrs is; - NonPtrs nps; - int /*StgExpr*/ stgexpr; +AsmObject asmNewObject ( void ) +{ + AsmObject obj = malloc(sizeof(struct AsmObject_)); + if (!obj) + barf("bytecode assembler: can't malloc in asmNewObject"); + obj->next = objects; + objects = obj; + obj->n_refs = obj->n_words = obj->n_insns = 0; + obj->closure = NULL; + obj->magic = 0x31415927; + INITIALISE_TABLE(AsmEntity,obj->entities, + obj->sizeEntities, + obj->usedEntities); + return obj; +} - /* abstract machine ("executed" during compilation) */ - AsmSp sp; /* stack ptr */ - AsmSp max_sp; - Instr lastOpc; -}; -static void asmResolveRef( AsmObject obj, AsmNat i, AsmClosure reference ) +void asmAddEntity ( AsmObject obj, + Asm_Kind kind, + StgWord val ) { - ASSERT(obj->closure); - switch (get_itbl(obj->closure)->type) { - case BCO: - { - StgBCO* bco = stgCast(StgBCO*,obj->closure); - ASSERT(i < bco->n_ptrs && bcoConstPtr(bco,i) == NULL); - bcoConstCPtr(bco,i) = reference; - break; - } - case CAF_UNENTERED: - { - StgCAF* caf = stgCast(StgCAF*,obj->closure); - ASSERT(i == 0 && caf->body == NULL); - caf->body = reference; - break; - } - case CONSTR: - { - StgClosure* con = stgCast(StgClosure*,obj->closure); - ASSERT(i < get_itbl(con)->layout.payload.nptrs && con->payload[i] == NULL); - con->payload[i] = reference; - break; - } - case AP_UPD: - { - StgAP_UPD* ap = stgCast(StgAP_UPD*,obj->closure); - ASSERT(i < 1+ap->n_args); - if (i==0) { - ASSERT(ap->fun == NULL); - ap->fun = reference; - } else { - ASSERT(ap->payload[i-1] == NULL); - ap->payload[i-1] = (StgPtr)reference; - } - break; - } - default: - barf("asmResolveRef"); - } - obj->num_unresolved -= 1; + ENSURE_SPACE_IN_TABLE( + Asm_Entity,obj->entities, + obj->sizeEntities,obj->usedEntities); + obj->entities[obj->usedEntities].kind = kind; + obj->entities[obj->usedEntities].val = val; + obj->usedEntities++; + switch (kind) { + case Asm_RefNoOp: case Asm_RefObject: case Asm_RefHugs: + obj->n_refs++; break; + case Asm_NonPtrWord: + obj->n_words++; break; + case Asm_Insn8: + obj->n_insns++; break; + default: + barf("asmAddEntity"); + } } -static void asmAddRef( AsmObject referent, AsmObject referer, AsmNat i ) +static int asmFindInNonPtrs ( AsmBCO bco, StgWord w ) { - if (referent->closure) { - asmResolveRef(referer,i,(AsmClosure)referent->closure); - } else { - insertRefs(&(referent->refs),(AsmRef){referer,i}); - } + int i, j = 0; + for (i = 0; i < bco->usedEntities; i++) { + if (bco->entities[i].kind == Asm_NonPtrWord) { + if (bco->entities[i].val == w) return j; + j++; + } + } + return -1; } -void asmAddPtr( AsmObject obj, AsmObject arg ) +static void setInstrs ( AsmBCO bco, int instr_no, StgWord new_instr_byte ) { - ASSERT(obj->closure == 0); /* can't extend an object once it's allocated */ - insertPtrs( &obj->ptrs, arg ); + int i, j = 0; + for (i = 0; i < bco->usedEntities; i++) { + if (bco->entities[i].kind == Asm_Insn8) { + if (j == instr_no) { + bco->entities[i].val = new_instr_byte; + return; + } + j++; + } + } + barf("setInstrs"); } -static void asmBeginObject( AsmObject obj ) +void* asmGetClosureOfObject ( AsmObject obj ) { - obj->closure = NULL; - obj->num_unresolved = 0; - initRefs(&obj->refs); - initPtrs(&obj->ptrs); + return obj->closure; } -static void asmEndObject( AsmObject obj, StgClosure* c ) -{ - obj->num_unresolved = obj->ptrs.len; - obj->closure = c; - mapQueue(Ptrs, AsmObject, obj->ptrs, asmAddRef(x,obj,i)); - mapQueue(Refs, AsmRef, obj->refs, asmResolveRef(x.ref,x.i,c)); - if (obj->num_unresolved == 0) { - freePtrs(&obj->ptrs); - freeRefs(&obj->refs); - /* we don't print until all ptrs are resolved */ - IF_DEBUG(codegen,printObj(obj->closure)); - } +/* -------------------------------------------------------------------------- + * Top level assembler/BCO linker functions + * ------------------------------------------------------------------------*/ + +int asmCalcHeapSizeW ( AsmObject obj ) +{ + int p, np, is, ws; + switch (obj->kind) { + case Asm_BCO: + p = obj->n_refs; + np = obj->n_words; + is = obj->n_insns + (obj->max_sp <= 255 ? 2 : 3); + ws = BCO_sizeW ( p, np, is ); + break; + case Asm_CAF: + ws = CAF_sizeW(); + break; + case Asm_Con: + p = obj->n_refs; + np = obj->n_words; + ws = CONSTR_sizeW ( p, np ); + break; + default: + barf("asmCalcHeapSizeW"); + } + if (ws - sizeofW(StgHeader) < MIN_NONUPD_SIZE) + ws = sizeofW(StgHeader) + MIN_NONUPD_SIZE; + return ws; } -int asmObjectHasClosure ( AsmObject obj ) + +void asmAllocateHeapSpace ( void ) { - return (obj->num_unresolved == 0 && obj->closure); + AsmObject obj; + for (obj = objects; obj; obj = obj->next) { + StgClosure* c = asmAlloc ( asmCalcHeapSizeW ( obj ) ); + obj->closure = c; + } } -AsmClosure asmClosureOfObject ( AsmObject obj ) +void asmShutdown ( void ) { - ASSERT(asmObjectHasClosure(obj)); - return obj->closure; + AsmObject obj; + AsmObject next = NULL; + for (obj = objects; obj; obj = next) { + next = obj->next; + obj->magic = 0x27180828; + if ( /*paranoia*/ obj->entities) + free(obj->entities); + free(obj); + } + objects = NULL; +} + +StgClosure* asmDerefEntity ( Asm_Entity entity ) +{ + switch (entity.kind) { + case Asm_RefNoOp: + return (StgClosure*)entity.val; + case Asm_RefObject: + ASSERT(entity.val); + ASSERT( ((AsmObject)(entity.val))->magic == 0x31415927 ); + return ((AsmObject)(entity.val))->closure; + case Asm_RefHugs: + return getNameOrTupleClosureCPtr(entity.val); + default: + barf("asmDerefEntity"); + } + return NULL; /*notreached*/ +} + +void asmCopyAndLink ( void ) +{ + int j, k; + AsmObject obj; + + for (obj = objects; obj; obj = obj->next) { + StgClosure** p = (StgClosure**)(obj->closure); + ASSERT(p); + + switch (obj->kind) { + + case Asm_BCO: { + AsmBCO abco = (AsmBCO)obj; + StgBCO* bco = (StgBCO*)p; + SET_HDR(bco,&BCO_info,??); + bco->n_ptrs = abco->n_refs; + bco->n_words = abco->n_words; + bco->n_instrs = abco->n_insns + (obj->max_sp <= 255 ? 2 : 3); + bco->stgexpr = abco->stgexpr; + + /* First copy in the ptrs. */ + k = 0; + for (j = 0; j < obj->usedEntities; j++) { + switch (obj->entities[j].kind) { + case Asm_RefNoOp: + case Asm_RefObject: + case Asm_RefHugs: + bcoConstCPtr(bco,k++) + = (StgClosure*)asmDerefEntity(obj->entities[j]); break; + default: + break; + } + } + + /* Now the non-ptrs. */ + k = 0; + for (j = 0; j < obj->usedEntities; j++) { + switch (obj->entities[j].kind) { + case Asm_NonPtrWord: + bcoConstWord(bco,k++) = obj->entities[j].val; break; + default: + break; + } + } + + /* Finally the insns, adding a stack check at the start. */ + k = 0; + abco->max_sp = stg_max(abco->sp,abco->max_sp); + + ASSERT(abco->max_sp <= 65535); + if (abco->max_sp <= 255) { + bcoInstr(bco,k++) = i_STK_CHECK; + bcoInstr(bco,k++) = abco->max_sp; + } else { + bcoInstr(bco,k++) = i_STK_CHECK_big; + bcoInstr(bco,k++) = abco->max_sp / 256; + bcoInstr(bco,k++) = abco->max_sp % 256; + } + for (j = 0; j < obj->usedEntities; j++) { + switch (obj->entities[j].kind) { + case Asm_Insn8: + bcoInstr(bco,k++) = obj->entities[j].val; break; + case Asm_RefNoOp: + case Asm_RefObject: + case Asm_RefHugs: + case Asm_NonPtrWord: + break; + default: + barf("asmCopyAndLink: strange stuff in AsmBCO"); + } + } + + ASSERT(k == bco->n_instrs); + break; + } + + case Asm_CAF: { + StgCAF* caf = (StgCAF*)p; + SET_HDR(caf,&CAF_UNENTERED_info,??); + caf->link = NULL; + caf->mut_link = NULL; + caf->value = (StgClosure*)0xdeadbeef; + ASSERT(obj->usedEntities == 1); + switch (obj->entities[0].kind) { + case Asm_RefNoOp: + case Asm_RefObject: + case Asm_RefHugs: + caf->body = (StgClosure*)asmDerefEntity(obj->entities[0]); + break; + default: + barf("asmCopyAndLink: strange stuff in AsmCAF"); + } + p += CAF_sizeW(); + break; + } + + case Asm_Con: { + SET_HDR((StgClosure*)p,obj->itbl,??); + p++; + /* First put in the pointers, then the non-pointers. */ + for (j = 0; j < obj->usedEntities; j++) { + switch (obj->entities[j].kind) { + case Asm_RefNoOp: + case Asm_RefObject: + case Asm_RefHugs: + *p++ = asmDerefEntity(obj->entities[j]); break; + default: + break; + } + } + for (j = 0; j < obj->usedEntities; j++) { + switch (obj->entities[j].kind) { + case Asm_NonPtrWord: + *p++ = (StgClosure*)(obj->entities[j].val); break; + default: + barf("asmCopyAndLink: strange stuff in AsmCon"); + } + } + break; + } + + default: + barf("asmCopyAndLink"); + } + } } + +#if 0 void asmMarkObject ( AsmObject obj ) { ASSERT(obj->num_unresolved == 0 && obj->closure); obj->closure = MarkRoot(obj->closure); } +#endif /* -------------------------------------------------------------------------- - * Heap allocation + * Keeping track of the simulated stack pointer * ------------------------------------------------------------------------*/ static StgClosure* asmAlloc( nat size ) @@ -293,126 +407,81 @@ static void decSp ( AsmBCO bco, int sp_delta ) * * ------------------------------------------------------------------------*/ -AsmObject asmMkObject( AsmClosure c ) -{ - AsmObject obj = malloc(sizeof(struct AsmObject_)); - if (obj == NULL) { - barf("Can't allocate AsmObject"); - } - asmBeginObject(obj); - asmEndObject(obj,c); - return obj; -} - AsmCon asmBeginCon( AsmInfo info ) { - AsmCon con = malloc(sizeof(struct AsmCon_)); - if (con == NULL) { - barf("Can't allocate AsmCon"); - } - asmBeginObject(&con->object); - con->info = info; - return con; + AsmCon con = asmNewObject(); + con->kind = Asm_Con; + con->itbl = info; + return con; } void asmEndCon( AsmCon con ) { - nat p = con->object.ptrs.len; - nat np = stg_max(0,MIN_NONUPD_SIZE-p); - - StgClosure* c = asmAlloc(CONSTR_sizeW(p,np)); - StgClosure* o = stgCast(StgClosure*,c); - SET_HDR(o,con->info,??); - mapQueue(Ptrs, AsmObject, con->object.ptrs, o->payload[i] = NULL); - { nat i; for( i=0; ipayload[p+i] = (StgClosure *)0xdeadbeef; }} - asmEndObject(&con->object,c); } AsmCAF asmBeginCAF( void ) { - AsmCAF caf = malloc(sizeof(struct AsmCAF_)); - if (caf == NULL) { - barf("Can't allocate AsmCAF"); - } - asmBeginObject(&caf->object); - return caf; + AsmCAF caf = asmNewObject(); + caf->kind = Asm_CAF; + return caf; } -void asmEndCAF( AsmCAF caf, AsmBCO body ) +void asmEndCAF( AsmCAF caf ) { - StgClosure* c = asmAlloc(CAF_sizeW()); - StgCAF* o = stgCast(StgCAF*,c); - SET_HDR(o,&CAF_UNENTERED_info,??); - o->body = NULL; - o->value = stgCast(StgClosure*,0xdeadbeef); - o->link = stgCast(StgCAF*,0xdeadbeef); - o->mut_link = NULL; - asmAddPtr(&caf->object,&body->object); - asmEndObject(&caf->object,c); } AsmBCO asmBeginBCO( int /*StgExpr*/ e ) { - AsmBCO bco = malloc(sizeof(struct AsmBCO_)); - if (bco == NULL) { - barf("Can't allocate AsmBCO"); - } - asmBeginObject(&bco->object); - initInstrs(&bco->is); - initNonPtrs(&bco->nps); - - bco->stgexpr = e; - bco->max_sp = bco->sp = 0; - bco->lastOpc = i_INTERNAL_ERROR; - return bco; + AsmBCO bco = asmNewObject(); + bco->kind = Asm_BCO; + bco->stgexpr = e; + bco->sp = 0; + bco->max_sp = 0; + bco->lastOpc = i_INTERNAL_ERROR; + return bco; } void asmEndBCO( AsmBCO bco ) { - nat p = bco->object.ptrs.len; - nat np = bco->nps.len; - nat is = bco->is.len + (bco->max_sp <= 255 ? 2 : 3); /* 2 or 3 for stack check */ - - StgClosure* c = asmAlloc(BCO_sizeW(p,np,is)); - StgBCO* o = stgCast(StgBCO*,c); - SET_HDR(o,&BCO_info,??); - o->n_ptrs = p; - o->n_words = np; - o->n_instrs = is; - o->stgexpr = bco->stgexpr; - mapQueue(Ptrs, AsmObject, bco->object.ptrs, bcoConstCPtr(o,i) = NULL); - mapQueue(NonPtrs, StgWord, bco->nps, bcoConstWord(o,i) = x); - { - nat j = 0; - bco->max_sp = stg_max(bco->sp,bco->max_sp); - - ASSERT(bco->max_sp <= 65535); - if (bco->max_sp <= 255) { - bcoInstr(o,j++) = i_STK_CHECK; - bcoInstr(o,j++) = bco->max_sp; - } else { - bcoInstr(o,j++) = i_STK_CHECK_big; - bcoInstr(o,j++) = bco->max_sp / 256; - bcoInstr(o,j++) = bco->max_sp % 256; - } - - mapQueue(Instrs, StgWord8, bco->is, bcoInstr(o,j++) = x); - ASSERT(j == is); - } - freeInstrs(&bco->is); - freeNonPtrs(&bco->nps); - asmEndObject(&bco->object,c); } /* -------------------------------------------------------------------------- * * ------------------------------------------------------------------------*/ +static void asmAddInstr ( AsmBCO bco, StgWord i ) +{ + asmAddEntity ( bco, Asm_Insn8, i ); +} + +static void asmAddNonPtrWord ( AsmObject obj, StgWord i ) +{ + asmAddEntity ( obj, Asm_NonPtrWord, i ); +} + +void asmAddRefHugs ( AsmObject obj,int /*Name*/ n ) +{ + asmAddEntity ( obj, Asm_RefHugs, n ); +} + +void asmAddRefObject ( AsmObject obj, AsmObject p ) +{ + ASSERT(p->magic == 0x31415927); + asmAddEntity ( obj, Asm_RefObject, (StgWord)p ); +} + +void asmAddRefNoOp ( AsmObject obj, StgPtr p ) +{ + asmAddEntity ( obj, Asm_RefNoOp, (StgWord)p ); +} + + + static void asmInstrOp ( AsmBCO bco, StgWord i ) { ASSERT(i <= BIGGEST_OPCODE); /* must be a valid opcode */ bco->lastOpc = i; - insertInstrs(&(bco->is),i); + asmAddInstr(bco,i); } static void asmInstr8 ( AsmBCO bco, StgWord i ) @@ -420,16 +489,17 @@ static void asmInstr8 ( AsmBCO bco, StgWord i ) if (i >= 256) { ASSERT(i < 256); /* must be a byte */ } - insertInstrs(&(bco->is),i); + asmAddInstr(bco,i); } static void asmInstr16 ( AsmBCO bco, StgWord i ) { ASSERT(i < 65536); /* must be a short */ - insertInstrs(&(bco->is),i / 256); - insertInstrs(&(bco->is),i % 256); + asmAddInstr(bco,i / 256); + asmAddInstr(bco,i % 256); } +#if 0 static Instr asmInstrBack ( AsmBCO bco, StgWord n ) { return bco->is.elems[bco->is.len - n]; @@ -440,30 +510,16 @@ static void asmInstrRecede ( AsmBCO bco, StgWord n ) if (bco->is.len < n) barf("asmInstrRecede"); bco->is.len -= n; } +#endif -static void asmPtr( AsmBCO bco, AsmObject x ) -{ - insertPtrs( &bco->object.ptrs, x ); -} - -static void asmWord( AsmBCO bco, StgWord i ) -{ - insertNonPtrs( &bco->nps, i ); -} - -static int asmFindInNonPtrs ( AsmBCO bco, StgWord i ) -{ - return findInNonPtrs ( &bco->nps, i ); -} - -#define asmWords(bco,ty,x) \ +#define asmAddNonPtrWords(bco,ty,x) \ { \ union { ty a; AsmWord b[sizeofW(ty)]; } p; \ nat i; \ if (sizeof(ty) < sizeof(AsmWord)) p.b[0]=0; \ p.a = x; \ for( i = 0; i < sizeofW(ty); i++ ) { \ - asmWord(bco,p.b[i]); \ + asmAddNonPtrWord(bco,p.b[i]); \ } \ } @@ -489,8 +545,8 @@ static StgWord repSizeW( AsmRep rep ) case FOREIGN_REP: #endif case ALPHA_REP: /* a */ - case BETA_REP: /* b */ - case GAMMA_REP: /* c */ + case BETA_REP: /* b */ + case GAMMA_REP: /* c */ case DELTA_REP: /* d */ case HANDLER_REP: /* IOError -> IO a */ case ERROR_REP: /* IOError */ @@ -521,6 +577,7 @@ int asmRepSizeW ( AsmRep rep ) static void emiti_ ( AsmBCO bco, Instr opcode ) { +#if 0 StgInt x, y; if (bco->lastOpc == i_SLIDE && opcode == i_ENTER) { /* SLIDE x y ; ENTER ===> SE x y */ @@ -542,10 +599,14 @@ static void emiti_ ( AsmBCO bco, Instr opcode ) else { asmInstrOp(bco,opcode); } +#else + asmInstrOp(bco,opcode); +#endif } static void emiti_8 ( AsmBCO bco, Instr opcode, int arg1 ) { +#if 0 StgInt x; if (bco->lastOpc == i_VAR && opcode == i_VAR) { /* VAR x ; VAR y ===> VV x y */ @@ -564,6 +625,10 @@ static void emiti_8 ( AsmBCO bco, Instr opcode, int arg1 ) asmInstrOp(bco,opcode); asmInstr8(bco,arg1); } +#else + asmInstrOp(bco,opcode); + asmInstr8(bco,arg1); +#endif } static void emiti_16 ( AsmBCO bco, Instr opcode, int arg1 ) @@ -761,7 +826,6 @@ static void emit_i_ALLOC_CONSTR ( AsmBCO bco, int arg1 ) emiti_16(bco,i_ALLOC_CONSTR_big,arg1); } - /* -------------------------------------------------------------------------- * Arg checks. * ------------------------------------------------------------------------*/ @@ -959,50 +1023,50 @@ AsmVar asmUnbox( AsmBCO bco, AsmRep rep ) void asmConstInt( AsmBCO bco, AsmInt x ) { - emit_i_CONST_INT(bco,bco->nps.len); - asmWords(bco,AsmInt,x); + emit_i_CONST_INT(bco,bco->n_words); + asmAddNonPtrWords(bco,AsmInt,x); incSp(bco, repSizeW(INT_REP)); } void asmConstInteger( AsmBCO bco, AsmString x ) { - emit_i_CONST_INTEGER(bco,bco->nps.len); - asmWords(bco,AsmString,x); + emit_i_CONST_INTEGER(bco,bco->n_words); + asmAddNonPtrWords(bco,AsmString,x); incSp(bco, repSizeW(INTEGER_REP)); } void asmConstAddr( AsmBCO bco, AsmAddr x ) { - emit_i_CONST_ADDR(bco,bco->nps.len); - asmWords(bco,AsmAddr,x); + emit_i_CONST_ADDR(bco,bco->n_words); + asmAddNonPtrWords(bco,AsmAddr,x); incSp(bco, repSizeW(ADDR_REP)); } void asmConstWord( AsmBCO bco, AsmWord x ) { - emit_i_CONST_INT(bco,bco->nps.len); - asmWords(bco,AsmWord,(AsmInt)x); + emit_i_CONST_INT(bco,bco->n_words); + asmAddNonPtrWords(bco,AsmWord,(AsmInt)x); incSp(bco, repSizeW(WORD_REP)); } void asmConstChar( AsmBCO bco, AsmChar x ) { - emit_i_CONST_CHAR(bco,bco->nps.len); - asmWords(bco,AsmChar,x); + emit_i_CONST_CHAR(bco,bco->n_words); + asmAddNonPtrWords(bco,AsmChar,x); incSp(bco, repSizeW(CHAR_REP)); } void asmConstFloat( AsmBCO bco, AsmFloat x ) { - emit_i_CONST_FLOAT(bco,bco->nps.len); - asmWords(bco,AsmFloat,x); + emit_i_CONST_FLOAT(bco,bco->n_words); + asmAddNonPtrWords(bco,AsmFloat,x); incSp(bco, repSizeW(FLOAT_REP)); } void asmConstDouble( AsmBCO bco, AsmDouble x ) { - emit_i_CONST_DOUBLE(bco,bco->nps.len); - asmWords(bco,AsmDouble,x); + emit_i_CONST_DOUBLE(bco,bco->n_words); + asmAddNonPtrWords(bco,AsmDouble,x); incSp(bco, repSizeW(DOUBLE_REP)); } @@ -1022,8 +1086,8 @@ void asmEndCase( AsmBCO bco ) AsmSp asmContinuation( AsmBCO bco, AsmBCO ret_addr ) { - emit_i_RETADDR(bco,bco->object.ptrs.len); - asmPtr(bco,&(ret_addr->object)); + emit_i_RETADDR(bco,bco->n_refs); + asmAddRefObject(bco,ret_addr); incSp(bco, 2 * sizeofW(StgPtr)); return bco->sp; } @@ -1058,25 +1122,25 @@ void asmEndAlt( AsmBCO bco, AsmSp sp ) AsmPc asmTest( AsmBCO bco, AsmWord tag ) { emiti_8_16(bco,i_TEST,tag,0); - return bco->is.len; + return bco->n_insns; } -AsmPc asmTestInt( AsmBCO bco, AsmVar v, AsmInt x ) +AsmPc asmTestInt ( AsmBCO bco, AsmVar v, AsmInt x ) { asmVar(bco,v,INT_REP); asmConstInt(bco,x); emiti_16(bco,i_TEST_INT,0); decSp(bco, 2*repSizeW(INT_REP)); - return bco->is.len; + return bco->n_insns; } -void asmFixBranch( AsmBCO bco, AsmPc from ) +void asmFixBranch ( AsmBCO bco, AsmPc from ) { - int distance = bco->is.len - from; + int distance = bco->n_insns - from; ASSERT(distance >= 0); ASSERT(distance < 65536); - setInstrs(&(bco->is),from-2,distance/256); - setInstrs(&(bco->is),from-1,distance%256); + setInstrs(bco,from-2,distance/256); + setInstrs(bco,from-1,distance%256); } void asmPanic( AsmBCO bco ) @@ -1468,31 +1532,51 @@ AsmPrim* asmFindPrimop( AsmInstr prefix, AsmInstr op ) * Handwritten primops * ------------------------------------------------------------------------*/ -AsmBCO asm_BCO_catch ( void ) +void* /* StgBCO* */ asm_BCO_catch ( void ) { - AsmBCO bco = asmBeginBCO(0 /*NIL*/); + AsmBCO bco; + StgBCO* closure; + asmInitialise(); + + bco = asmBeginBCO(0 /*NIL*/); emiti_8(bco,i_ARG_CHECK,2); emiti_8(bco,i_PRIMOP1,i_pushcatchframe); incSp(bco, (1-2)*sizeofW(StgPtr) + sizeofW(StgCatchFrame)); emiti_(bco,i_ENTER); decSp(bco, sizeofW(StgPtr)); asmEndBCO(bco); - return bco; + + asmAllocateHeapSpace(); + asmCopyAndLink(); + closure = (StgBCO*)(bco->closure); + asmShutdown(); + return closure; } -AsmBCO asm_BCO_raise ( void ) +void* /* StgBCO* */ asm_BCO_raise ( void ) { - AsmBCO bco = asmBeginBCO(0 /*NIL*/); + AsmBCO bco; + StgBCO* closure; + asmInitialise(); + + bco = asmBeginBCO(0 /*NIL*/); emiti_8(bco,i_ARG_CHECK,1); emiti_8(bco,i_PRIMOP2,i_raise); decSp(bco,sizeofW(StgPtr)); asmEndBCO(bco); - return bco; + + asmAllocateHeapSpace(); + asmCopyAndLink(); + closure = (StgBCO*)(bco->closure); + asmShutdown(); + return closure; } -AsmBCO asm_BCO_seq ( void ) +void* /* StgBCO* */ asm_BCO_seq ( void ) { AsmBCO eval, cont; + StgBCO* closure; + asmInitialise(); cont = asmBeginBCO(0 /*NIL*/); emiti_8(cont,i_ARG_CHECK,2); /* should never fail */ @@ -1504,8 +1588,8 @@ AsmBCO asm_BCO_seq ( void ) eval = asmBeginBCO(0 /*NIL*/); emiti_8(eval,i_ARG_CHECK,2); - emit_i_RETADDR(eval,eval->object.ptrs.len); - asmPtr(eval,&(cont->object)); + emit_i_RETADDR(eval,eval->n_refs); + asmAddRefObject(eval,cont); emit_i_VAR(eval,2); emit_i_SLIDE(eval,3,1); emiti_8(eval,i_PRIMOP1,i_pushseqframe); @@ -1513,12 +1597,18 @@ AsmBCO asm_BCO_seq ( void ) incSp(eval, sizeofW(StgSeqFrame) + 4*sizeofW(StgPtr)); asmEndBCO(eval); - return eval; + asmAllocateHeapSpace(); + asmCopyAndLink(); + closure = (StgBCO*)(eval->closure); + asmShutdown(); + return closure; } -AsmBCO asm_BCO_takeMVar ( void ) +void* /* StgBCO* */ asm_BCO_takeMVar ( void ) { AsmBCO kase, casecont, take; + StgBCO* closure; + asmInitialise(); take = asmBeginBCO(0 /*NIL*/); emit_i_VAR(take,0); @@ -1536,8 +1626,8 @@ AsmBCO asm_BCO_takeMVar ( void ) emit_i_VAR(casecont,4); emit_i_VAR(casecont,4); emit_i_VAR(casecont,2); - emit_i_CONST(casecont,casecont->object.ptrs.len); - asmPtr(casecont,&(take->object)); + emit_i_CONST(casecont,casecont->n_refs); + asmAddRefObject(casecont,take); emit_i_SLIDE(casecont,4,5); emiti_(casecont,i_ENTER); incSp(casecont,20); @@ -1545,14 +1635,18 @@ AsmBCO asm_BCO_takeMVar ( void ) kase = asmBeginBCO(0 /*NIL*/); emiti_8(kase,i_ARG_CHECK,3); - emit_i_RETADDR(kase,kase->object.ptrs.len); - asmPtr(kase,&(casecont->object)); + emit_i_RETADDR(kase,kase->n_refs); + asmAddRefObject(kase,casecont); emit_i_VAR(kase,2); emiti_(kase,i_ENTER); incSp(kase,20); asmEndBCO(kase); - return kase; + asmAllocateHeapSpace(); + asmCopyAndLink(); + closure = (StgBCO*)(kase->closure); + asmShutdown(); + return closure; } @@ -1570,8 +1664,8 @@ AsmVar asmAllocCONSTR ( AsmBCO bco, AsmInfo info ) i = asmFindInNonPtrs ( bco, (StgWord)info ); if (i == -1) { - emit_i_ALLOC_CONSTR(bco,bco->nps.len); - asmWords(bco,AsmInfo,info); + emit_i_ALLOC_CONSTR(bco,bco->n_words); + asmAddNonPtrWords(bco,AsmInfo,info); } else { emit_i_ALLOC_CONSTR(bco,i); } @@ -1644,20 +1738,27 @@ void asmEndMkPAP( AsmBCO bco, AsmVar v, AsmSp start ) setSp(bco, start); } -AsmVar asmClosure( AsmBCO bco, AsmObject p ) +AsmVar asmPushRefHugs ( AsmBCO bco, int /*Name*/ n ) +{ + emit_i_CONST(bco,bco->n_refs); + asmAddRefHugs(bco,n); + incSp(bco, sizeofW(StgPtr)); + return bco->sp; +} + +AsmVar asmPushRefObject ( AsmBCO bco, AsmObject p ) { - emit_i_CONST(bco,bco->object.ptrs.len); - asmPtr(bco,p); + emit_i_CONST(bco,bco->n_refs); + asmAddRefObject(bco,p); incSp(bco, sizeofW(StgPtr)); return bco->sp; } -AsmVar asmGHCClosure( AsmBCO bco, AsmObject p ) +AsmVar asmPushRefNoOp ( AsmBCO bco, StgPtr p ) { - // A complete hack. Pushes the address as a tagged int - // and then uses SLIDE to get rid of the tag. Appalling. - asmConstInt(bco, (AsmInt)p); - emit_i_SLIDE(bco,0,1); decSp(bco,1); + emit_i_CONST(bco,bco->n_refs); + asmAddRefNoOp(bco,p); + incSp(bco, sizeofW(StgPtr)); return bco->sp; } @@ -1691,4 +1792,3 @@ AsmInfo asmMkInfo( AsmNat tag, AsmNat ptrs ) /*-------------------------------------------------------------------------*/ #endif /* INTERPRETER */ - diff --git a/ghc/rts/Evaluator.c b/ghc/rts/Evaluator.c index a51c1aa..e0a6558 100644 --- a/ghc/rts/Evaluator.c +++ b/ghc/rts/Evaluator.c @@ -5,8 +5,8 @@ * Copyright (c) 1994-1998. * * $RCSfile: Evaluator.c,v $ - * $Revision: 1.49 $ - * $Date: 2000/04/25 17:47:42 $ + * $Revision: 1.50 $ + * $Date: 2000/04/27 16:35:30 $ * ---------------------------------------------------------------------------*/ #include "Rts.h" @@ -71,8 +71,8 @@ /* Make it possible for the evaluator to get hold of bytecode for a given function by name. Useful but a hack. Sigh. */ -extern void* getHugs_AsmObject_for ( char* s ); -extern int /*Bool*/ combined; +extern void* /* StgClosure* */ getHugs_BCO_cptr_for ( char* s ); +extern int /* Bool */ combined; /* -------------------------------------------------------------------------- * Crude profiling stuff (mainly to assess effect of optimiser) @@ -690,8 +690,12 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) xPopUpdateFrame(obj); break; case STOP_FRAME: + barf("STOP frame during pap update"); +#if 0 + cap->rCurrentTSO->what_next = ThreadComplete; SSS; PopStopFrame(obj); LLL; RETURN(ThreadFinished); +#endif case SEQ_FRAME: SSS; PopSeqFrame(); LLL; ASSERT(xSp != (P_)xSu); @@ -1478,7 +1482,9 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) + cap->rCurrentTSO->stack_size,xSu); LLL; ); + cap->rCurrentTSO->what_next = ThreadComplete; SSS; PopStopFrame(obj); LLL; + xPushPtr((P_)obj); RETURN(ThreadFinished); } case RET_BCO: @@ -1787,7 +1793,7 @@ static inline StgClosure* raiseAnError ( StgClosure* exception ) * thunks which are currently under evaluation. */ HaskellObj primRaiseClosure - = asmClosureOfObject(getHugs_AsmObject_for("primRaise")); + = getHugs_BCO_cptr_for("primRaise"); HaskellObj reraiseClosure = rts_apply ( primRaiseClosure, exception ); @@ -1828,9 +1834,9 @@ static StgClosure* makeErrorCall ( const char* msg ) (thinks: probably not so, but anyway ...) */ HaskellObj error - = asmClosureOfObject(getHugs_AsmObject_for("error")); + = getHugs_BCO_cptr_for("error"); HaskellObj unpack - = asmClosureOfObject(getHugs_AsmObject_for("hugsprimUnpackString")); + = getHugs_BCO_cptr_for("hugsprimUnpackString"); HaskellObj thunk = rts_apply ( unpack, rts_mkAddr ( (void*)msg ) ); thunk diff --git a/ghc/rts/ForeignCall.c b/ghc/rts/ForeignCall.c index 38158ce..080742c 100644 --- a/ghc/rts/ForeignCall.c +++ b/ghc/rts/ForeignCall.c @@ -1,6 +1,6 @@ /* ----------------------------------------------------------------------------- - * $Id: ForeignCall.c,v 1.14 2000/04/11 16:49:20 sewardj Exp $ + * $Id: ForeignCall.c,v 1.15 2000/04/27 16:35:30 sewardj Exp $ * * (c) The GHC Team 1994-1999. * @@ -385,7 +385,7 @@ int ccall ( CFunDescriptor* d, /* Make it possible for the evaluator to get hold of bytecode for a given function by name. Useful but a hack. Sigh. */ -extern void* getHugs_AsmObject_for ( char* s ); +extern void* /* StgClosure* */ getHugs_BCO_cptr_for ( char* s ); extern int /*Bool*/ combined; /* ----------------------------------------------------------------* @@ -469,7 +469,7 @@ unpackArgsAndCallHaskell_x86_nocallconv_wrk ( StgStablePtr stableptr, sstat = rts_evalIO ( node, &nodeOut ); } else { node = rts_apply ( - asmClosureOfObject(getHugs_AsmObject_for("primRunST")), + getHugs_BCO_cptr_for("primRunST"), node ); sstat = rts_eval ( node, &nodeOut ); } -- 1.7.10.4