-/* -*- mode: hugs-c; -*- */
+
/* --------------------------------------------------------------------------
* STG syntax
*
- * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
- * All rights reserved. See NOTICE for details and conditions of use etc...
- * Hugs version 1.4, December 1997
+ * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
+ * Yale Haskell Group, and the Oregon Graduate Institute of Science and
+ * Technology, 1994-1999, All rights reserved. It is distributed as
+ * free software under the license in the file "License", which is
+ * included in the distribution.
*
* $RCSfile: stg.c,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/02 13:22:38 $
+ * $Revision: 1.15 $
+ * $Date: 2000/03/23 14:54:21 $
* ------------------------------------------------------------------------*/
-#include "prelude.h"
+#include "hugsbasictypes.h"
#include "storage.h"
#include "connect.h"
#include "errors.h"
-#include "stg.h"
-#include "link.h" /* for nameTrue/False */
+
#include "Assembler.h" /* for AsmRep and primops */
/* --------------------------------------------------------------------------
* Utility functions
* ------------------------------------------------------------------------*/
-int stgConTag( StgDiscr d )
+/* Make an info table for a constructor or tuple. */
+void* stgConInfo ( StgDiscr d )
{
+ int tag;
switch (whatIs(d)) {
- case NAME:
- return cfunOf(d);
- case TUPLE:
- return 0;
- default:
- internal("stgConTag");
+ 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");
}
}
-void* stgConInfo( 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 asmMkInfo(cfunOf(d),name(d).arity);
- case TUPLE:
- return asmMkInfo(0,tupleOf(d));
- default:
- internal("stgConInfo");
- }
-}
-
-/* ToDo: identical to stgConTag */
-int stgDiscrTag( StgDiscr d )
-{
- 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;
}
/* --------------------------------------------------------------------------
return ap(STGVAR,triple(rhs,mkStgRep(PTR_REP),info));
}
+
+/* --------------------------------------------------------------------------
+ * STG pretty printer
+ * ------------------------------------------------------------------------*/
+
+/* --------------------------------------------------------------------------
+ * Local functions
+ * ------------------------------------------------------------------------*/
+
+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 );
+
+
+
+/* --------------------------------------------------------------------------
+ * Indentation and showing names/constants
+ * ------------------------------------------------------------------------*/
+
+static Void local pIndent(n) /* indent to particular position */
+Int n; {
+ outColumn = n;
+ while (0<n--) {
+ Putc(' ',outputStream);
+ }
+}
+
+
+/* --------------------------------------------------------------------------
+ * Pretty printer for stg code:
+ * ------------------------------------------------------------------------*/
+
+static Void putStgAlts ( Int left, List alts );
+
+static Void local putStgVar(StgVar v)
+{
+ if (isName(v)) {
+ unlexVar(name(v).text);
+ } else {
+ putStr("id");
+ putInt(-v);
+ putStr("<");
+ putChr(charOf(stgVarRep(v)));
+ putStr(">");
+ if (isInt(stgVarInfo(v))) {
+ putStr("(");
+ putInt(intOf(stgVarInfo(v)));
+ putStr(")");
+ }
+ }
+}
+
+static Void local putStgVars( List vs )
+{
+ for(; nonNull(vs); vs=tl(vs)) {
+ putStgVar(hd(vs));
+ putChr(' ');
+ }
+}
+
+static Void local putStgAtom( StgAtom a )
+{
+ switch (whatIs(a)) {
+ case STGVAR:
+ case NAME:
+ putStgVar(a);
+ break;
+ case CHARCELL:
+ unlexCharConst(charOf(a));
+ putChr('#');
+ break;
+ case INTCELL:
+ putInt(intOf(a));
+ putChr('#');
+ break;
+ case BIGCELL:
+ putStr(bignumToString(a));
+ putChr('#');
+ break;
+ case FLOATCELL:
+ putStr(floatToString(a));
+ putChr('#');
+ break;
+ case STRCELL:
+ unlexStrConst(textOf(a));
+ break;
+ case PTRCELL:
+ putPtr(ptrOf(a));
+ putChr('#');
+ break;
+ case LETREC: case LAMBDA: case CASE: case PRIMCASE:
+ case STGAPP: case STGPRIM: case STGCON:
+ putStgExpr(a);
+ break;
+ default:
+ fprintf(stderr,"\nYoiks: "); printExp(stderr,a);
+ internal("putStgAtom");
+ }
+}
+
+Void putStgAtoms( List as )
+{
+ putChr('{');
+ while (nonNull(as)) {
+ putStgAtom(hd(as));
+ as=tl(as);
+ if (nonNull(as)) {
+ putChr(',');
+ }
+ }
+ putChr('}');
+}
+
+Void putStgPat( StgCaseAlt alt )
+{
+ if (whatIs(alt)==DEEFALT) {
+ putStgVar(stgDefaultVar(alt));
+ }
+ else
+ if (whatIs(alt)==CASEALT) {
+ List vs = stgCaseAltVars(alt);
+ if (whatIs(stgCaseAltCon(alt))==TUPLE) {
+ putChr('(');
+ putStgVar(hd(vs));
+ vs=tl(vs);
+ while (nonNull(vs)) {
+ putChr(',');
+ putStgVar(hd(vs));
+ vs=tl(vs);
+ }
+ putChr(')');
+ }
+ else
+ if (whatIs(stgCaseAltCon(alt))==NAME) {
+ unlexVar(name(stgCaseAltCon(alt)).text);
+ for (; nonNull(vs); vs=tl(vs)) {
+ putChr(' ');
+ putStgVar(hd(vs));
+ }
+ }
+ else
+ internal("putStgPat(2)");
+ }
+ else
+ internal("putStgPat(1)");
+}
+
+Void putStgPrimPat( StgVar v )
+{
+ if (nonNull(stgVarBody(v))) {
+ StgExpr d = stgVarBody(v);
+ switch (whatIs(d)) {
+ case INTCELL:
+ {
+ putInt(intOf(d));
+ putChr('#');
+ break;
+ }
+ default:
+ fprintf(stderr,"\nYoiks: "); printExp(stderr,d);
+ internal("putStgPrimPat");
+ }
+ } else {
+ putStgVar(v);
+ }
+ putChr(' ');
+}
+
+Void putStgBinds(binds) /* pretty print locals */
+List binds; {
+ Int left = outColumn;
+
+ putStr("let { ");
+ while (nonNull(binds)) {
+ Cell bind = hd(binds);
+ putStgVar(bind);
+ putStr(" = ");
+ putStgRhs(stgVarBody(bind));
+ putStr("\n");
+ binds = tl(binds);
+ if (nonNull(binds))
+ pIndent(left+6);
+ }
+ pIndent(left);
+ putStr("} in ");
+}
+
+static Void putStgAlts( Int left, List alts )
+{
+ if (length(alts) == 1) {
+ StgCaseAlt alt = hd(alts);
+ putStr("{ ");
+ putStgPat(alt);
+ putStr(" ->\n");
+ pIndent(left);
+ if (isDefaultAlt(alt))
+ putStgExpr(stgDefaultBody(alt)); else
+ putStgExpr(stgCaseAltBody(alt));
+ putStr("}");
+ } else {
+ putStr("{\n");
+ for (; nonNull(alts); alts=tl(alts)) {
+ StgCaseAlt alt = hd(alts);
+ pIndent(left+2);
+ putStgPat(alt);
+
+ putStr(" ->\n");
+ pIndent(left+4);
+
+ if (isDefaultAlt(alt))
+ putStgExpr(stgDefaultBody(alt)); else
+ putStgExpr(stgCaseAltBody(alt));
+
+ putStr("\n");
+ }
+ pIndent(left);
+ putStr("}\n");
+ }
+}
+
+static Void putStgPrimAlts( Int left, List alts )
+{
+ if (length(alts) == 1) {
+ StgPrimAlt alt = hd(alts);
+ putStr("{ ");
+ mapProc(putStgPrimPat,stgPrimAltVars(alt));
+ putStr(" ->\n");
+ pIndent(left);
+ putStgExpr(stgPrimAltBody(alt));
+ putStr("}");
+ } else {
+ putStr("{\n");
+ for (; nonNull(alts); alts=tl(alts)) {
+ StgPrimAlt alt = hd(alts);
+ pIndent(left+2);
+ mapProc(putStgPrimPat,stgPrimAltVars(alt));
+ putStr(" -> ");
+ putStgExpr(stgPrimAltBody(alt));
+ putStr("\n");
+ }
+ pIndent(left);
+ putStr("}\n");
+ }
+}
+
+Void putStgExpr( StgExpr e ) /* pretty print expr */
+{
+ if (isNull(e)) putStr("(putStgExpr:NIL)");else
+
+ switch (whatIs(e)) {
+ case LETREC:
+ {
+ Int left = outColumn;
+ putStgBinds(stgLetBinds(e));
+ if (whatIs(stgLetBody(e))==LETREC) {
+ putStr("\n"); pIndent(left);
+ } else
+ if (whatIs(stgLetBody(e))==CASE) {
+ putStr("\n"); pIndent(left+2);
+ }
+ putStgExpr(stgLetBody(e));
+ break;
+ }
+ case LAMBDA:
+ {
+ Int left = outColumn;
+ putStr("\\ ");
+ putStgVars(stgLambdaArgs(e));
+ putStr("->\n");
+ pIndent(left+2);
+ putStgExpr(stgLambdaBody(e));
+ break;
+ }
+ case CASE:
+ {
+ Int left = outColumn;
+ putStr("case ");
+ putStgExpr(stgCaseScrut(e));
+ putStr(" of ");
+ putStgAlts(left,stgCaseAlts(e));
+ break;
+ }
+ case DEEFALT:
+ case CASEALT:
+ /* a hack; not for regular use */
+ putStgAlts(outColumn,singleton(e));
+ break;
+ case PRIMALT:
+ /* a hack; not for regular use */
+ putStgPrimAlts(outColumn,singleton(e));
+ break;
+ case PRIMCASE:
+ {
+ Int left = outColumn;
+ putStr("case# ");
+ putStgExpr(stgPrimCaseScrut(e));
+ putStr(" of ");
+ putStgPrimAlts(left,stgPrimCaseAlts(e));
+ break;
+ }
+ case STGPRIM:
+ {
+ Cell op = stgPrimOp(e);
+ unlexVarStr(asmGetPrimopName(name(op).primop));
+ putStgAtoms(stgPrimArgs(e));
+ break;
+ }
+ case STGAPP:
+ putStgExpr(stgAppFun(e));
+ putStgAtoms(stgAppArgs(e));
+ break;
+ case STGCON:
+ putStgRhs(e);
+ break;
+ case STGVAR:
+ case NAME:
+ putStgVar(e);
+ break;
+ case CHARCELL:
+ case INTCELL:
+ case BIGCELL:
+ case FLOATCELL:
+ case STRCELL:
+ case PTRCELL:
+ putStgAtom(e);
+ break;
+ case AP:
+ /* hope that it's really a list of StgExprs, so map putStgExpr
+ over it */
+ for (;nonNull(e);e=tl(e)) {
+ putStgExpr(hd(e));
+ putStr("\n");
+ }
+ break;
+ default:
+ internal("putStgExpr");
+ /* Pretend it's a list of algebraic case alternatives. Used for
+ printing the case-alt lists attached to BCOs which are return
+ continuations. Very useful for debugging. An appalling hack tho.
+ */
+ /* fprintf(stderr, " "); putStgAlts(3,e); */
+ }
+}
+
+Void putStgRhs( StgRhs e ) /* print lifted definition */
+{
+ switch (whatIs(e)) {
+ case STGCON:
+ {
+ Name con = stgConCon(e);
+ if (isTuple(con)) {
+ putStr("Tuple");
+ putInt(tupleOf(con));
+ } else {
+ unlexVar(name(con).text);
+ }
+ putStgAtoms(stgConArgs(e));
+ break;
+ }
+ default:
+ putStgExpr(e);
+ break;
+ }
+}
+
+static void beginStgPP( FILE* fp );
+static void endStgPP( FILE* fp );
+
+static void beginStgPP( FILE* fp )
+{
+ outputStream = fp;
+ outColumn = 0;
+ fflush(stderr); fflush(stdout);
+}
+
+static void endStgPP( FILE* fp )
+{
+ fflush(fp);
+}
+
+Void printStg(fp,b) /* Pretty print sc defn on fp */
+FILE *fp;
+StgVar b;
+{
+ Name n;
+ beginStgPP(fp);
+ n = nameFromStgVar(b);
+ if (nonNull(n)) {
+ putStr(textToStr(name(n).text));
+ } else {
+ putStgVar(b);
+ }
+ putStr(" = ");
+ putStgRhs(stgVarBody(b));
+ putStr("\n");
+ endStgPP(fp);
+}
+
+Void ppStg( StgVar v )
+{
+ printStg(stdout,v);
+}
+
+Void ppStgExpr( StgExpr e )
+{
+ beginStgPP(stdout);
+ putStgExpr(e);
+ endStgPP(stdout);
+}
+
+Void ppStgRhs( StgRhs rhs )
+{
+ beginStgPP(stdout);
+ putStgRhs(rhs);
+ endStgPP(stdout);
+}
+
+Void ppStgAlts( List alts )
+{
+ beginStgPP(stdout);
+ putStgAlts(0,alts);
+ endStgPP(stdout);
+}
+
+extern Void ppStgPrimAlts( List alts )
+{
+ beginStgPP(stdout);
+ putStgPrimAlts(0,alts);
+ endStgPP(stdout);
+}
+
+extern Void ppStgVars( List vs )
+{
+ beginStgPP(stdout);
+ printf("Vars: ");
+ putStgVars(vs);
+ printf("\n");
+ endStgPP(stdout);
+}
+
/*-------------------------------------------------------------------------*/
projects / ghc-hetmet.git / blobdiff