2 /* --------------------------------------------------------------------------
5 * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
6 * All rights reserved. See NOTICE for details and conditions of use etc...
7 * Hugs version 1.4, December 1997
11 * $Date: 1999/04/27 10:07:04 $
12 * ------------------------------------------------------------------------*/
19 #include "link.h" /* for nameTrue/False */
20 #include "Assembler.h" /* for AsmRep and primops */
22 /* --------------------------------------------------------------------------
24 * ------------------------------------------------------------------------*/
26 void* stgConInfo( StgDiscr d )
30 return asmMkInfo(cfunOf(d),name(d).arity);
32 return asmMkInfo(0,tupleOf(d));
34 internal("stgConInfo");
38 int stgDiscrTag( StgDiscr d )
46 internal("stgDiscrTag");
50 /* --------------------------------------------------------------------------
51 * Utility functions for manipulating STG syntax trees.
52 * ------------------------------------------------------------------------*/
54 List makeArgs( Int n )
58 args = cons(mkStgVar(NIL,NIL),args);
63 StgExpr makeStgLambda( List args, StgExpr body )
68 if (whatIs(body) == LAMBDA) {
69 return mkStgLambda(dupListOnto(args,stgLambdaArgs(body)),
72 return mkStgLambda(args,body);
77 StgExpr makeStgApp( StgVar fun, List args )
82 return mkStgApp(fun,args);
86 StgExpr makeStgLet( List binds, StgExpr body )
91 return mkStgLet(binds,body);
95 StgExpr makeStgIf( StgExpr cond, StgExpr e1, StgExpr e2 )
97 if (cond == nameTrue) {
99 } else if (cond == nameFalse) {
102 return mkStgCase(cond,doubleton(mkStgCaseAlt(nameTrue,NIL,e1),
103 mkStgCaseAlt(nameFalse,NIL,e2)));
134 StgVar mkStgVar( StgRhs rhs, Cell info )
136 return ap(STGVAR,triple(rhs,mkStgRep(PTR_REP),info));
140 /* --------------------------------------------------------------------------
142 * ------------------------------------------------------------------------*/
144 /* --------------------------------------------------------------------------
146 * ------------------------------------------------------------------------*/
148 static Void local pIndent Args((Int));
150 static Void local putStgVar Args((StgVar));
151 static Void local putStgVars Args((List));
152 static Void local putStgAtom Args((StgAtom a));
153 static Void local putStgAtoms Args((List as));
154 static Void local putStgBinds Args((List));
155 static Void local putStgExpr Args((StgExpr));
156 static Void local putStgRhs Args((StgRhs));
157 static Void local putStgPat Args((StgCaseAlt));
158 static Void local putStgPrimPat Args((StgPrimAlt));
162 /* --------------------------------------------------------------------------
163 * Indentation and showing names/constants
164 * ------------------------------------------------------------------------*/
166 static Void local pIndent(n) /* indent to particular position */
170 Putc(' ',outputStream);
175 /* --------------------------------------------------------------------------
176 * Pretty printer for stg code:
177 * ------------------------------------------------------------------------*/
179 static Void putStgAlts ( Int left, List alts );
181 static Void local putStgVar(StgVar v)
184 if (name(v).inlineMe) putStr("IL__");
185 unlexVar(name(v).text);
190 putChr(charOf(stgVarRep(v)));
192 if (isInt(stgVarInfo(v))) {
194 putInt(intOf(stgVarInfo(v)));
200 static Void local putStgVars( List vs )
202 for(; nonNull(vs); vs=tl(vs)) {
208 static Void local putStgAtom( StgAtom a )
216 unlexCharConst(charOf(a));
224 putStr(bignumToString(a));
228 putStr(floatToString(a));
232 unlexStrConst(textOf(a));
238 case LETREC: case LAMBDA: case CASE: case PRIMCASE:
239 case STGAPP: case STGPRIM: case STGCON:
243 fprintf(stderr,"\nYoiks: "); printExp(stderr,a);
244 internal("putStgAtom");
248 Void putStgAtoms( List as )
251 while (nonNull(as)) {
261 Void putStgPat( StgCaseAlt alt )
263 if (whatIs(alt)==DEEFALT) {
264 putStgVar(stgDefaultVar(alt));
267 if (whatIs(alt)==CASEALT) {
268 List vs = stgCaseAltVars(alt);
269 if (whatIs(stgCaseAltCon(alt))==TUPLE) {
273 while (nonNull(vs)) {
281 if (whatIs(stgCaseAltCon(alt))==NAME) {
282 unlexVar(name(stgCaseAltCon(alt)).text);
283 for (; nonNull(vs); vs=tl(vs)) {
289 internal("putStgPat(2)");
292 internal("putStgPat(1)");
295 Void putStgPrimPat( StgVar v )
297 if (nonNull(stgVarBody(v))) {
298 StgExpr d = stgVarBody(v);
307 fprintf(stderr,"\nYoiks: "); printExp(stderr,d);
308 internal("putStgPrimPat");
316 Void putStgBinds(binds) /* pretty print locals */
318 Int left = outColumn;
321 while (nonNull(binds)) {
322 Cell bind = hd(binds);
325 putStgRhs(stgVarBody(bind));
335 static Void putStgAlts( Int left, List alts )
337 if (length(alts) == 1) {
338 StgCaseAlt alt = hd(alts);
343 if (isDefaultAlt(alt))
344 putStgExpr(stgDefaultBody(alt)); else
345 putStgExpr(stgCaseAltBody(alt));
349 for (; nonNull(alts); alts=tl(alts)) {
350 StgCaseAlt alt = hd(alts);
357 if (isDefaultAlt(alt))
358 putStgExpr(stgDefaultBody(alt)); else
359 putStgExpr(stgCaseAltBody(alt));
368 static Void putStgPrimAlts( Int left, List alts )
370 if (length(alts) == 1) {
371 StgPrimAlt alt = hd(alts);
373 mapProc(putStgPrimPat,stgPrimAltVars(alt));
376 putStgExpr(stgPrimAltBody(alt));
380 for (; nonNull(alts); alts=tl(alts)) {
381 StgPrimAlt alt = hd(alts);
383 mapProc(putStgPrimPat,stgPrimAltVars(alt));
385 putStgExpr(stgPrimAltBody(alt));
393 Void putStgExpr( StgExpr e ) /* pretty print expr */
395 if (isNull(e)) putStr("(putStgExpr:NIL)");else
400 Int left = outColumn;
401 putStgBinds(stgLetBinds(e));
402 if (whatIs(stgLetBody(e))==LETREC) {
403 putStr("\n"); pIndent(left);
405 if (whatIs(stgLetBody(e))==CASE) {
406 putStr("\n"); pIndent(left+2);
408 putStgExpr(stgLetBody(e));
413 Int left = outColumn;
415 putStgVars(stgLambdaArgs(e));
418 putStgExpr(stgLambdaBody(e));
423 Int left = outColumn;
425 putStgExpr(stgCaseScrut(e));
427 putStgAlts(left,stgCaseAlts(e));
432 /* a hack; not for regular use */
433 putStgAlts(outColumn,singleton(e));
436 /* a hack; not for regular use */
437 putStgPrimAlts(outColumn,singleton(e));
441 Int left = outColumn;
443 putStgExpr(stgPrimCaseScrut(e));
445 putStgPrimAlts(left,stgPrimCaseAlts(e));
450 Cell op = stgPrimOp(e);
451 unlexVar(name(op).text);
452 putStgAtoms(stgPrimArgs(e));
456 putStgExpr(stgAppFun(e));
457 putStgAtoms(stgAppArgs(e));
475 /* hope that it's really a list of StgExprs, so map putStgExpr
477 for (;nonNull(e);e=tl(e)) {
483 internal("putStgExpr");
484 /* Pretend it's a list of algebraic case alternatives. Used for
485 printing the case-alt lists attached to BCOs which are return
486 continuations. Very useful for debugging. An appalling hack tho.
488 /* fprintf(stderr, " "); putStgAlts(3,e); */
492 Void putStgRhs( StgRhs e ) /* print lifted definition */
497 Name con = stgConCon(e);
500 putInt(tupleOf(con));
502 unlexVar(name(con).text);
504 putStgAtoms(stgConArgs(e));
513 static void beginStgPP( FILE* fp );
514 static void endStgPP( FILE* fp );
516 static void beginStgPP( FILE* fp )
520 fflush(stderr); fflush(stdout);
523 static void endStgPP( FILE* fp )
528 Void printStg(fp,b) /* Pretty print sc defn on fp */
534 n = nameFromStgVar(b);
536 if (name(n).inlineMe) { putStr("INLINE\n"); pIndent(0); };
537 putStr(textToStr(name(n).text));
542 putStgRhs(stgVarBody(b));
547 #if 1 /*DEBUG_PRINTER*/
548 Void ppStg( StgVar v )
553 Void ppStgExpr( StgExpr e )
560 Void ppStgRhs( StgRhs rhs )
567 Void ppStgAlts( List alts )
574 extern Void ppStgPrimAlts( List alts )
577 putStgPrimAlts(0,alts);
581 extern Void ppStgVars( List vs )
591 /*-------------------------------------------------------------------------*/