* included in the distribution.
*
* $RCSfile: codegen.c,v $
- * $Revision: 1.14 $
- * $Date: 1999/12/10 15:59:41 $
+ * $Revision: 1.22 $
+ * $Date: 2000/04/12 09:37:19 $
* ------------------------------------------------------------------------*/
-#include "prelude.h"
+#include "hugsbasictypes.h"
#include "storage.h"
-#include "backend.h"
#include "connect.h"
#include "errors.h"
-#include "Assembler.h"
-#include "link.h"
+#include "Assembler.h"
#include "Rts.h" /* IF_DEBUG */
#include "RtsFlags.h"
+/*#define DEBUG_CODEGEN*/
+
/* --------------------------------------------------------------------------
* Local function prototypes:
* ------------------------------------------------------------------------*/
static AsmBCO cgAlts ( AsmSp root, AsmSp sp, List alts );
static void testPrimPats ( AsmBCO bco, AsmSp root, List pats, StgExpr e );
-//static void cgPrimAlt ( AsmBCO bco, AsmSp root, List vs, StgExpr e );
static AsmBCO cgLambda ( StgExpr e );
static AsmBCO cgRhs ( StgRhs rhs );
static void beginTop ( StgVar v );
void* p;
Module m = name(n).mod;
Text mt = module(m).text;
- sprintf(buf,"%s_%s_closure",
- textToStr(mt),
- textToStr( enZcodeThenFindText ( textToStr (name(n).text) ) ) );
+ sprintf(buf, MAYBE_LEADING_UNDERSCORE_STR("%s_%s_closure"),
+ textToStr(mt),
+ textToStr( enZcodeThenFindText (
+ textToStr (name(n).text) ) ) );
p = lookupOTabName ( m, buf );
if (!p) {
ERRMSG(0) "Can't find object symbol %s", buf
{
extern Name nameHw;
Name nm;
- for( nm=NAMEMIN; nm<nameHw; ++nm ) {
- StgVar v = name(nm).stgVar;
- if (isStgVar(v)
- && isPtr(stgVarInfo(v))
- && varHasClosure(v)
- && closureOfVar(v) == closure) {
- return textToStr(name(nm).text);
- }
+ 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) {
+ return textToStr(name(nm).text);
+ }
}
return 0;
}
-/* called at the start of GC */
-void markHugsObjects( void )
-{
- extern Name nameHw;
- Name nm;
- for( nm=NAMEMIN; nm<nameHw; ++nm ) {
- StgVar v = name(nm).stgVar;
- if (isStgVar(v) && isPtr(stgVarInfo(v))) {
- asmMarkObject((AsmClosure*)ptrOf(stgVarInfo(v)));
- }
- }
-}
-
static void cgBindRep( AsmBCO bco, StgVar v, AsmRep rep )
{
setPos(v,asmBind(bco,rep));
static Void pushVar( AsmBCO bco, StgVar v )
{
Cell info;
-
- if (!(isStgVar(v) || isCPtr(v))) {
+#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));
static Void pushAtom( AsmBCO bco, StgAtom e )
{
+#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
- pushVar(bco,cptrFromName(e));
+ if (nonNull(name(e).stgVar)) {
+ pushVar(bco,name(e).stgVar);
+ } else {
+ Cell /*CPtr*/ addr = cptrFromName(e);
+# if DEBUG_CODEGEN
+ fprintf ( stderr, "nativeAtom: name %s\n",
+ nameFromOPtr(cptrOf(addr)) );
+# endif
+ pushVar(bco,addr);
+ }
break;
case CHARCELL:
asmConstChar(bco,charOf(e));
asmConstAddr(bco,ptrOf(e));
break;
default:
- fprintf(stderr,"\nYoiks: "); printExp(stderr,e);
+ fprintf(stderr,"\nYoiks1: "); printExp(stderr,e);
internal("pushAtom");
}
}
con = stgCaseAltCon(hd(alts));
/* special case: dictionary constructors */
- if (strncmp(":D",textToStr(name(con).text),2)==0) {
+ if (isName(con) && strncmp(":D",textToStr(name(con).text),2)==0) {
omit_test = TRUE;
goto xyzzy;
}
}
}
-#if 0 /* appears to be unused */
-static void cgPrimAlt( AsmBCO bco, AsmSp root, List vs, StgExpr e )
-{
- assert(0); /* ToDo: test for patterns */
- map1Proc(cgBind,bco,vs); /* ToDo: are these in right order? */
- cgExpr(bco,root,e);
-}
-#endif
-
static AsmBCO cgLambda( StgExpr e )
{
static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e )
{
- //printf("cgExpr:");ppStgExpr(e);printf("\n");
+#if 0
+ printf("cgExpr:");ppStgExpr(e);printf("\n");
+#endif
switch (whatIs(e)) {
case LETREC:
{
case NAME: /* Tail call (with no args) */
{
AsmSp env = asmBeginEnter(bco);
- pushVar(bco,name(e).stgVar);
+ /* JRS 000112: next line used to be: pushVar(bco,name(e).stgVar); */
+ pushAtom(bco,e);
asmEndEnter(bco,env,root);
break;
}
break;
}
default:
- fprintf(stderr,"\nYoiks: "); printExp(stderr,e);
+ fprintf(stderr,"\nYoiks2: "); printExp(stderr,e);
internal("cgExpr");
}
}
-#define M_ITBLNAMES 35000
-
-void* itblNames[M_ITBLNAMES];
-int nItblNames = 0;
-
/* allocate space for top level variable
* any change requires a corresponding change in 'build'.
*/
{
StgRhs rhs = stgVarBody(v);
assert(isStgVar(v));
+#if 0
+ printf("alloc: ");ppStgExpr(v);
+#endif
switch (whatIs(rhs)) {
case STGCON:
{
pushAtom(bco,hd(args));
setPos(v,asmBox(bco,boxingConRep(con)));
} else {
-
- void* vv = stgConInfo(con);
- if (!(nItblNames < (M_ITBLNAMES-2)))
- internal("alloc -- M_ITBLNAMES too small");
- if (isName(con)) {
- itblNames[nItblNames++] = vv;
- itblNames[nItblNames++] = textToStr(name(con).text);
- } else
- if (isTuple(con)) {
- itblNames[nItblNames++] = vv;
- itblNames[nItblNames++] = textToStr(ghcTupleText(con));
- } else
- assert ( /* cant identify constructor name */ 0 );
- setPos(v,asmAllocCONSTR(bco, vv));
+ setPos(v,asmAllocCONSTR(bco,stgConInfo(con)));
}
break;
}
}
}
setPos(v,asmAllocAP(bco,totSizeW));
- //ORIGINALLY:setPos(v,asmAllocAP(bco,length(stgAppArgs(rhs))));
break;
}
case LAMBDA: /* optimisation */
{
StgRhs rhs = stgVarBody(v);
assert(isStgVar(v));
-
+ //ppStg(v);
switch (whatIs(rhs)) {
case STGCON:
{
if (isCPtr(fun)) {
assert(isName(fun0));
itsaPAP = name(fun0).arity > length(args);
-fprintf ( stderr, "nativeCall: name %s, arity %d, args %d\n",
- nameFromOPtr(cptrOf(fun)), name(fun0).arity, length(args) );
+# if DEBUG_CODEGEN
+ fprintf ( stderr, "nativeCall: name %s, arity %d, args %d\n",
+ nameFromOPtr(cptrOf(fun)), name(fun0).arity,
+ length(args) );
+# endif
} else {
itsaPAP = FALSE;
if (nonNull(stgVarBody(fun))
* of this except "let x = x in ..."
*/
case NAME:
- rhs = name(rhs).stgVar;
+ if (nonNull(name(rhs).stgVar))
+ rhs = name(rhs).stgVar; else
+ rhs = cptrFromName(rhs);
+ /* fall thru */
case STGVAR:
{
AsmSp start = asmBeginMkAP(bco);
#endif
for (b=binds,i=0; nonNull(b); b=tl(b),i++) {
+ /* printStg( stdout, hd(b) ); printf( "\n\n"); */
beginTop(hd(b));
}
for (b=binds,i=0; nonNull(b); b=tl(b),i++) {
- //printStg( stdout, hd(b) ); printf( "\n\n");
+ /* printStg( stdout, hd(b) ); printf( "\n\n"); */
endTop(hd(b));
}
- //mapProc(zap,binds);
+ /* mapProc(zap,binds); */
+}
+
+/* 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)));
+ }
+ }
}
/* --------------------------------------------------------------------------