/* --------------------------------------------------------------------------
* 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.3 $
- * $Date: 1999/02/03 17:08:39 $
+ * $Revision: 1.9 $
+ * $Date: 1999/11/29 18:59:32 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
* Utility functions
* ------------------------------------------------------------------------*/
-int stgConTag( StgDiscr d )
-{
- switch (whatIs(d)) {
- case NAME:
- return cfunOf(d);
- case TUPLE:
- return 0;
- default:
- internal("stgConTag");
- }
-}
-
void* stgConInfo( StgDiscr d )
{
switch (whatIs(d)) {
}
}
-/* ToDo: identical to stgConTag */
int stgDiscrTag( StgDiscr d )
{
switch (whatIs(d)) {
return body;
} else {
if (whatIs(body) == LAMBDA) {
- return mkStgLambda(dupOnto(args,stgLambdaArgs(body)),
+ return mkStgLambda(dupListOnto(args,stgLambdaArgs(body)),
stgLambdaBody(body));
} else {
return mkStgLambda(args,body);
return ap(STGVAR,triple(rhs,mkStgRep(PTR_REP),info));
}
-/*-------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
* STG pretty printer
- *
- * 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
- *
- * $RCSfile: stg.c,v $
- * $Revision: 1.3 $
- * $Date: 1999/02/03 17:08:39 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
* ------------------------------------------------------------------------*/
static Void local pIndent Args((Int));
-static Void local unlexVar Args((Text));
-static Void local unlexCharConst Args((Cell));
-static Void local unlexStrConst Args((Text));
static Void local putStgVar Args((StgVar));
static Void local putStgVars Args((List));
static Void local putStgBinds Args((List));
static Void local putStgExpr Args((StgExpr));
static Void local putStgRhs Args((StgRhs));
-static Void local putStgPat Args((StgPat));
-static Void local putStgPrimPat Args((StgPrimPat));
+static Void local putStgPat Args((StgCaseAlt));
+static Void local putStgPrimPat Args((StgPrimAlt));
-/* --------------------------------------------------------------------------
- * Basic output routines:
- * ------------------------------------------------------------------------*/
-static FILE *outputStream; /* current output stream */
-static Int outColumn = 0; /* current output column number */
-
-static Void local putChr( Int c );
-static Void local putStr( String s );
-static Void local putInt( Int n );
-static Void local putPtr( Ptr p );
-
-static Void local putChr(c) /* print single character */
-Int c; {
- Putc(c,outputStream);
- outColumn++;
-}
-
-static Void local putStr(s) /* print string */
-String s; {
- for (; *s; s++) {
- Putc(*s,outputStream);
- outColumn++;
- }
-}
-
-static Void local putInt(n) /* print integer */
-Int n; {
- static char intBuf[16];
- sprintf(intBuf,"%d",n);
- putStr(intBuf);
-}
-
-static Void local putPtr(p) /* print pointer */
-Ptr p; {
- static char intBuf[16];
- sprintf(intBuf,"%p",p);
- putStr(intBuf);
-}
/* --------------------------------------------------------------------------
* Indentation and showing names/constants
}
}
-static Void local unlexVar(t) /* print text as a variable name */
-Text t; { /* operator symbols must be enclosed*/
- String s = textToStr(t); /* in parentheses... except [] ... */
-
- if ((isascii(s[0]) && isalpha(s[0])) || s[0]=='_' || s[0]=='[' || s[0]=='(')
- putStr(s);
- else {
- putChr('(');
- putStr(s);
- putChr(')');
- }
-}
-
-static Void local unlexCharConst(c)
-Cell c; {
- putChr('\'');
- putStr(unlexChar(c,'\''));
- putChr('\'');
-}
-
-static Void local unlexStrConst(t)
-Text t; {
- String s = textToStr(t);
- static Char SO = 14; /* ASCII code for '\SO' */
- Bool lastWasSO = FALSE;
- Bool lastWasDigit = FALSE;
- Bool lastWasEsc = FALSE;
-
- putChr('\"');
- for (; *s; s++) {
- String ch = unlexChar(*s,'\"');
- Char c = ' ';
-
- if ((lastWasSO && *ch=='H') ||
- (lastWasEsc && lastWasDigit && isascii(*ch) && isdigit(*ch)))
- putStr("\\&");
-
- lastWasEsc = (*ch=='\\');
- lastWasSO = (*s==SO);
- for (; *ch; c = *ch++)
- putChr(*ch);
- lastWasDigit = (isascii(c) && isdigit(c));
- }
- putChr('\"');
-}
/* --------------------------------------------------------------------------
* Pretty printer for stg code:
* ------------------------------------------------------------------------*/
static Void putStgAlts ( Int left, List alts );
-static Void putStgPrimAlt ( Int left, List vs, StgExpr body );
static Void local putStgVar(StgVar v)
{
} else {
putStr("id");
putInt(-v);
+ putStr("<");
+ putChr(charOf(stgVarRep(v)));
+ putStr(">");
+ if (isInt(stgVarInfo(v))) {
+ putStr("(");
+ putInt(intOf(stgVarInfo(v)));
+ putStr(")");
+ }
}
}
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");
putChr('}');
}
-Void putStgPat( StgPat pat )
+Void putStgPat( StgCaseAlt alt )
{
- putStgVar(pat);
- if (nonNull(stgVarBody(pat))) {
- StgDiscr d = stgConCon(stgVarBody(pat));
- List vs = stgConArgs(stgVarBody(pat));
- putChr('@');
- switch (whatIs(d)) {
- case NAME:
- {
- unlexVar(name(d).text);
- for (; nonNull(vs); vs=tl(vs)) {
- putChr(' ');
- putStgVar(hd(vs));
- }
- break;
- }
- case TUPLE:
- {
- putChr('(');
- putStgVar(hd(vs));
- vs=tl(vs);
- while (nonNull(vs)) {
- putChr(',');
- putStgVar(hd(vs));
- vs=tl(vs);
- }
- putChr(')');
- break;
- }
- default:
- fprintf(stderr,"\nYoiks: "); printExp(stderr,d);
- internal("putStgPat");
- }
- }
-}
-
-Void putStgPrimPat( StgPrimPat pat )
+ 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 )
{
- putStgVar(pat);
- if (nonNull(stgVarBody(pat))) {
- StgExpr d = stgVarBody(pat);
- putChr('@');
+ if (nonNull(stgVarBody(v))) {
+ StgExpr d = stgVarBody(v);
switch (whatIs(d)) {
case INTCELL:
{
fprintf(stderr,"\nYoiks: "); printExp(stderr,d);
internal("putStgPrimPat");
}
+ } else {
+ putStgVar(v);
}
putChr(' ');
}
static Void putStgAlts( Int left, List alts )
{
- if (length(alts) == 1) {
+ if (length(alts) == 1) {
StgCaseAlt alt = hd(alts);
putStr("{ ");
- putStgPat(stgCaseAltPat(alt));
+ putStgPat(alt);
putStr(" ->\n");
pIndent(left);
- putStgExpr(stgCaseAltBody(alt));
+ 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(stgCaseAltPat(alt));
- putStr(" -> ");
- putStgExpr(stgCaseAltBody(alt));
+ putStgPat(alt);
+
+ putStr(" ->\n");
+ pIndent(left+4);
+
+ if (isDefaultAlt(alt))
+ putStgExpr(stgDefaultBody(alt)); else
+ putStgExpr(stgCaseAltBody(alt));
+
putStr("\n");
}
pIndent(left);
if (length(alts) == 1) {
StgPrimAlt alt = hd(alts);
putStr("{ ");
- mapProc(putStgPrimPat,stgPrimAltPats(alt));
+ mapProc(putStgPrimPat,stgPrimAltVars(alt));
putStr(" ->\n");
pIndent(left);
putStgExpr(stgPrimAltBody(alt));
for (; nonNull(alts); alts=tl(alts)) {
StgPrimAlt alt = hd(alts);
pIndent(left+2);
- mapProc(putStgPrimPat,stgPrimAltPats(alt));
+ mapProc(putStgPrimPat,stgPrimAltVars(alt));
putStr(" -> ");
putStgExpr(stgPrimAltBody(alt));
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;
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;
case STGPRIM:
{
Cell op = stgPrimOp(e);
- unlexVar(name(op).text);
+ unlexVarStr(asmGetPrimopName(name(op).primop));
putStgAtoms(stgPrimArgs(e));
break;
}
case STGAPP:
- putStgVar(stgAppFun(e));
+ 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:
- fprintf(stderr,"\nYoiks: "); printExp(stderr,e);
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); */
}
}
static void beginStgPP( FILE* fp )
{
outputStream = fp;
- putChr('\n');
outColumn = 0;
+ fflush(stderr); fflush(stdout);
}
static void endStgPP( FILE* fp )
Void printStg(fp,b) /* Pretty print sc defn on fp */
FILE *fp;
-StgVar b;
+StgVar b;
{
+ Name n;
beginStgPP(fp);
- putStgVar(b);
+ n = nameFromStgVar(b);
+ if (nonNull(n)) {
+ putStr(textToStr(name(n).text));
+ } else {
+ putStgVar(b);
+ }
putStr(" = ");
putStgRhs(stgVarBody(b));
putStr("\n");
endStgPP(fp);
}
-#if DEBUG_PRINTER
+#if 1 /*DEBUG_PRINTER*/
Void ppStg( StgVar v )
{
- if (debugCode) {
- printStg(stdout,v);
- }
+ printStg(stdout,v);
}
Void ppStgExpr( StgExpr e )
{
- if (debugCode) {
- beginStgPP(stdout);
- putStgExpr(e);
- endStgPP(stdout);
- }
+ beginStgPP(stdout);
+ putStgExpr(e);
+ endStgPP(stdout);
}
Void ppStgRhs( StgRhs rhs )
{
- if (debugCode) {
- beginStgPP(stdout);
- putStgRhs(rhs);
- endStgPP(stdout);
- }
+ beginStgPP(stdout);
+ putStgRhs(rhs);
+ endStgPP(stdout);
}
Void ppStgAlts( List alts )
{
- if (debugCode) {
- beginStgPP(stdout);
- putStgAlts(0,alts);
- endStgPP(stdout);
- }
+ beginStgPP(stdout);
+ putStgAlts(0,alts);
+ endStgPP(stdout);
}
extern Void ppStgPrimAlts( List alts )
{
- if (debugCode) {
- beginStgPP(stdout);
- putStgPrimAlts(0,alts);
- endStgPP(stdout);
- }
+ beginStgPP(stdout);
+ putStgPrimAlts(0,alts);
+ endStgPP(stdout);
}
extern Void ppStgVars( List vs )
{
- if (debugCode) {
- beginStgPP(stdout);
- printf("Vars: ");
- putStgVars(vs);
- printf("\n");
- endStgPP(stdout);
- }
+ beginStgPP(stdout);
+ printf("Vars: ");
+ putStgVars(vs);
+ printf("\n");
+ endStgPP(stdout);
}
#endif
projects / ghc-hetmet.git / blobdiff