* included in the distribution.
*
* $RCSfile: stg.c,v $
- * $Revision: 1.8 $
- * $Date: 1999/11/12 17:32:45 $
+ * $Revision: 1.16 $
+ * $Date: 2000/04/27 16:35:29 $
* ------------------------------------------------------------------------*/
-#include "prelude.h"
+#include "hugsbasictypes.h"
#include "storage.h"
-#include "backend.h"
#include "connect.h"
#include "errors.h"
-#include "link.h" /* for nameTrue/False */
+
+#include "Rts.h" /* to make StgPtr visible in Assembler.h */
#include "Assembler.h" /* for AsmRep and primops */
/* --------------------------------------------------------------------------
* Utility functions
* ------------------------------------------------------------------------*/
-void* stgConInfo( StgDiscr d )
+/* Make an info table for a constructor or tuple. */
+void* stgConInfo ( StgDiscr d )
{
+ int tag;
switch (whatIs(d)) {
- case NAME:
- return asmMkInfo(cfunOf(d),name(d).arity);
- case TUPLE:
- return asmMkInfo(0,tupleOf(d));
- default:
- internal("stgConInfo");
+ case NAME: {
+ tag = cfunOf(d);
+ if (tag > 0) tag--;
+ if (!name(d).itbl)
+ name(d).itbl = asmMkInfo(tag,name(d).arity);
+ return name(d).itbl;
+ }
+ case TUPLE: {
+ tag = 0;
+ if (!tycon(d).itbl)
+ tycon(d).itbl = asmMkInfo(tag,tupleOf(d));
+ return tycon(d).itbl;
+ }
+ default:
+ internal("stgConInfo");
}
}
-int stgDiscrTag( StgDiscr d )
+/* Return the tag for a constructor or tuple, starting at zero. */
+int stgDiscrTag ( StgDiscr d )
{
+ int tag;
switch (whatIs(d)) {
- case NAME:
- return cfunOf(d);
- case TUPLE:
- return 0;
- default:
- internal("stgDiscrTag");
+ case NAME: tag = cfunOf(d); break;
+ case TUPLE: tag = 0;
+ default: internal("stgDiscrTag");
}
+ if (tag > 0) tag--;
+ return tag;
}
/* --------------------------------------------------------------------------
case BIGCELL:
case FLOATCELL:
case STRCELL:
- case PTRCELL:
+ case ADDRCELL:
return TRUE;
default:
return FALSE;
* Local functions
* ------------------------------------------------------------------------*/
-static Void local pIndent Args((Int));
-
-static Void local putStgVar Args((StgVar));
-static Void local putStgVars Args((List));
-static Void local putStgAtom Args((StgAtom a));
-static Void local putStgAtoms Args((List as));
-static Void local putStgBinds Args((List));
-static Void local putStgExpr Args((StgExpr));
-static Void local putStgRhs Args((StgRhs));
-static Void local putStgPat Args((StgCaseAlt));
-static Void local putStgPrimPat Args((StgPrimAlt));
+static Void local pIndent ( Int );
+static Void local putStgVar ( StgVar );
+static Void local putStgVars ( List );
+static Void local putStgAtom ( StgAtom a );
+static Void local putStgAtoms ( List as );
+static Void local putStgBinds ( List );
+static Void local putStgExpr ( StgExpr );
+static Void local putStgRhs ( StgRhs );
+static Void local putStgPat ( StgCaseAlt );
+static Void local putStgPrimPat ( StgPrimAlt );
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:
case STGPRIM:
{
Cell op = stgPrimOp(e);
- unlexVar(name(op).text);
+ unlexVarStr(asmGetPrimopName(name(op).primop));
putStgAtoms(stgPrimArgs(e));
break;
}
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 {
endStgPP(fp);
}
-#if 1 /*DEBUG_PRINTER*/
Void ppStg( StgVar v )
{
printStg(stdout,v);
printf("\n");
endStgPP(stdout);
}
-#endif
/*-------------------------------------------------------------------------*/