/* -----------------------------------------------------------------------------
- * $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.
*
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
} 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
* ------------------------------------------------------------------------*/
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 );
* 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 );
/* --------------------------------------------------------------------------
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 );
* 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"
#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;
*
* ------------------------------------------------------------------------*/
-static Cell cptrFromName ( Name n )
+static void* /* StgClosure*/ cptrFromName ( Name n )
{
char buf[1000];
void* p;
ERRMSG(0) "Can't find object symbol %s", buf
EEND;
}
- return mkCPtr(p);
-}
-
-static Bool varHasClosure( StgVar v )
-{
- return asmObjectHasClosure((AsmClosure*)ptrOf(stgVarInfo(v)));
-}
-
-/* should be AsmClosure* */
-void* closureOfVar( StgVar v )
-{
- return asmClosureOfObject((AsmClosure*)ptrOf(stgVarInfo(v)));
+ return p;
}
char* lookupHugsName( void* closure )
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 )
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");
}
case LAMBDA:
{
AsmSp begin = asmBeginEnter(bco);
- asmClosure(bco,cgLambda(e));
+ asmPushRefObject(bco,cgLambda(e));
asmEndEnter(bco,begin,root);
break;
}
/* 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)) {
asmEndEnter(bco,env,root);
break;
}
+ case TUPLE:
case NAME: /* Tail call (with no args) */
{
AsmSp env = asmBeginEnter(bco);
case BETA_REP:
{
AsmSp env = asmBeginEnter(bco);
- pushVar(bco,e);
+ pushAtom /*pushVar*/ (bco,e);
asmEndEnter(bco,env,root);
break;
}
{
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);
}
)
itsaPAP = TRUE;
}
+#endif
if (itsaPAP) {
AsmSp start = asmBeginMkPAP(bco);
* 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);
default:
{
AsmSp start = asmBeginMkAP(bco); /* make it updateable! */
- asmClosure(bco,cgRhs(rhs));
+ asmPushRefObject(bco,cgRhs(rhs));
asmEndMkAP(bco,getPos(v),start);
return;
}
* 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
*/
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:
* ------------------------------------------------------------------------*/
* 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"
/*-------------------------------------------------------------------------*/
-
-
-/* --------------------------------------------------------------------------
- * 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) */
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}");
}
-static List local addStgVar( List binds, Pair bind )
-{
- StgVar nv = mkStgVar(NIL,NIL);
- Text t = textOf(fst(bind));
- Name n = findName(t);
-
- if (isNull(n)) { /* Lookup global name - the only way*/
- n = newName(t,NIL); /* this (should be able to happen) */
- } /* is with new global var introduced*/
- /* after type check; e.g. remPat1 */
- name(n).stgVar = nv;
- return cons(nv,binds);
-}
-
-
Void compileDefns() { /* compile script definitions */
Target t = length(valDefns) + length(genDefns) + length(selDefns);
Target i = 0;
- List binds = NIL;
{
List vss;
List vs;
- for(vs=genDefns; nonNull(vs); vs=tl(vs)) {
- Name n = hd(vs);
- StgVar nv = mkStgVar(NIL,NIL);
- assert(isName(n));
- name(n).stgVar = nv;
- binds = cons(nv,binds);
+ for (vs = genDefns; nonNull(vs); vs = tl(vs)) {
+ Name n = hd(vs);
+ StgVar nv = mkStgVar(NIL,NIL);
+ name(n).closure = nv;
+ addToCodeList ( currentModule, n );
}
- for(vss=selDefns; nonNull(vss); vss=tl(vss)) {
- for(vs=hd(vss); nonNull(vs); vs=tl(vs)) {
- Pair p = hd(vs);
- Name n = fst(p);
- StgVar nv = mkStgVar(NIL,NIL);
- assert(isName(n));
- name(n).stgVar = nv;
- binds = cons(nv,binds);
+ for (vss = selDefns; nonNull(vss); vss = tl(vss)) {
+ for (vs = hd(vss); nonNull(vs); vs = tl(vs)) {
+ Pair p = hd(vs);
+ Name n = fst(p);
+ StgVar nv = mkStgVar(NIL,NIL);
+ name(n).closure = nv;
+ addToCodeList ( currentModule, n );
}
}
}
setGoal("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)) {
soFar(i++);
}
- binds = addGlobals(binds);
done();
setGoal("Generating code",t);
- stgCGBinds(binds);
+ cgModule ( currentModule );
done();
}
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);
* 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 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
* 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;
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* );
* 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]) */
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 );
}
}
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 );
}
}
* 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"
case STGVAR:
return freeVarsVar(acc, e);
case NAME:
+ case TUPLE:
return acc; /* Names are never free vars */
default:
printf("\n");
* 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 <setjmp.h>
} 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);
* 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"
#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*/
* ------------------------------------------------------------------------*/
#define EXTERN_SYMS_ALLPLATFORMS \
- Sym(MainRegTable) \
+ SymX(MainRegTable) \
Sym(stg_gc_enter_1) \
Sym(stg_gc_noregs) \
Sym(stg_gc_seq_1) \
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) \
#define EXTERN_SYMS_linux \
- Sym(__errno_location) \
+ SymX(__errno_location) \
Sym(__xstat) \
Sym(__fxstat) \
Sym(__lxstat) \
#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
* 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"
* ------------------------------------------------------------------------*/
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
/* 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 */
}
}
+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);
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);
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;
}
/* --------------------------------------------------------------------------
* 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 */
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;
}
#undef pFun
-//#include "fooble.c"
/*-------------------------------------------------------------------------*/
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;
}
* 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"
#include "connect.h"
#include "errors.h"
+#include "Rts.h" /* to make StgPtr visible in Assembler.h */
#include "Assembler.h" /* for AsmRep and primops */
/* --------------------------------------------------------------------------
case BIGCELL:
case FLOATCELL:
case STRCELL:
- case PTRCELL:
+ case ADDRCELL:
return TRUE;
default:
return FALSE;
static Void local putStgVar(StgVar v)
{
+ if (isTuple(v)) {
+ putStr("Tuple");
+ putInt(tupleOf(v));
+ } else
if (isName(v)) {
unlexVar(name(v).text);
} else {
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:
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:
break;
case STGVAR:
case NAME:
+ case TUPLE:
putStgVar(e);
break;
case CHARCELL:
case BIGCELL:
case FLOATCELL:
case STRCELL:
- case PTRCELL:
+ case ADDRCELL:
putStgAtom(e);
break;
case AP:
{
Name n;
beginStgPP(fp);
- n = nameFromStgVar(b);
+ n = NIL; /* nameFromStgVar(b); */
if (nonNull(n)) {
putStr(textToStr(name(n).text));
} else {
* 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"
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;
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;
}
}
-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);
}
/* --------------------------------------------------------------------------
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;
module(mod).classes = NIL;
module(mod).exports = NIL;
module(mod).qualImports = NIL;
+ module(mod).codeList = NIL;
module(mod).fake = FALSE;
module(mod).tree = NIL;
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);
}
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;
}
+/* 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:
*
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);
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;
}
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" );
}
mark(name(i).parent);
mark(name(i).type);
mark(name(i).defn);
- mark(name(i).stgVar);
+ mark(name(i).closure);
}
}
end("Names", nameHw-NAMEMIN);
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);
mark(tycon(i).kind);
mark(tycon(i).what);
mark(tycon(i).defn);
+ mark(tycon(i).closure);
}
}
end("Type constructors", tyconHw-TYCMIN);
* 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 */
* -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
* ------------------------------------------------------------------------*/
#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 */
#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 */
#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.
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 */
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* );
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;
};
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;
};
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 );
* 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"
#include "connect.h"
#include "errors.h"
+#include "Rts.h" /* to make StgPtr visible in Assembler.h */
#include "Assembler.h"
/* ---------------------------------------------------------------- */
-/* 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);
assert(nonNull(p));
return snd(p);
}
+#endif
/* ---------------------------------------------------------------- */
case VAROPCELL:
return stgText(textOf(e),sc);
case TUPLE:
- return getSTGTupleVar(e);
+ /* return getSTGTupleVar(e); */
+ return e;
case NAME:
return e;
/* Literals */
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));
}
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"); */
}
/* --------------------------------------------------------------------------
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.
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;
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,
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
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 );
}
}
case POSTPREL: break;
case PREPREL:
case RESET:
- stgGlobals=NIL;
break;
case MARK:
- mark(stgGlobals);
break;
}
}
* 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"
#include "connect.h"
#include "errors.h"
+#include "Rts.h" /* to make StgPtr visible in Assembler.h */
#include "Assembler.h" /* for AsmCTypes */
/*#define DEBUG_TYPES*/
* 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.
#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 )
*
* ------------------------------------------------------------------------*/
-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; i<np; ++i ) { o->payload[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 )
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];
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]); \
} \
}
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 */
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 */
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 */
asmInstrOp(bco,opcode);
asmInstr8(bco,arg1);
}
+#else
+ asmInstrOp(bco,opcode);
+ asmInstr8(bco,arg1);
+#endif
}
static void emiti_16 ( AsmBCO bco, Instr opcode, int arg1 )
emiti_16(bco,i_ALLOC_CONSTR_big,arg1);
}
-
/* --------------------------------------------------------------------------
* Arg checks.
* ------------------------------------------------------------------------*/
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));
}
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;
}
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 )
* 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 */
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);
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);
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);
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;
}
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);
}
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;
}
/*-------------------------------------------------------------------------*/
#endif /* INTERPRETER */
-
* 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"
/* 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)
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);
+ cap->rCurrentTSO->stack_size,xSu);
LLL;
);
+ cap->rCurrentTSO->what_next = ThreadComplete;
SSS; PopStopFrame(obj); LLL;
+ xPushPtr((P_)obj);
RETURN(ThreadFinished);
}
case RET_BCO:
* thunks which are currently under evaluation.
*/
HaskellObj primRaiseClosure
- = asmClosureOfObject(getHugs_AsmObject_for("primRaise"));
+ = getHugs_BCO_cptr_for("primRaise");
HaskellObj reraiseClosure
= rts_apply ( primRaiseClosure, exception );
(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
/* -----------------------------------------------------------------------------
- * $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.
*
/* 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;
/* ----------------------------------------------------------------*
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 );
}
projects / ghc-hetmet.git / commitdiff