2 /* --------------------------------------------------------------------------
5 * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
6 * Yale Haskell Group, and the Oregon Graduate Institute of Science and
7 * Technology, 1994-1999, All rights reserved. It is distributed as
8 * free software under the license in the file "License", which is
9 * included in the distribution.
13 * $Date: 2000/03/23 14:54:21 $
14 * ------------------------------------------------------------------------*/
16 #include "hugsbasictypes.h"
21 #include "Assembler.h" /* for AsmRep and primops */
23 /* --------------------------------------------------------------------------
25 * ------------------------------------------------------------------------*/
27 /* Make an info table for a constructor or tuple. */
28 void* stgConInfo ( StgDiscr d )
36 name(d).itbl = asmMkInfo(tag,name(d).arity);
42 tycon(d).itbl = asmMkInfo(tag,tupleOf(d));
46 internal("stgConInfo");
50 /* Return the tag for a constructor or tuple, starting at zero. */
51 int stgDiscrTag ( StgDiscr d )
55 case NAME: tag = cfunOf(d); break;
57 default: internal("stgDiscrTag");
63 /* --------------------------------------------------------------------------
64 * Utility functions for manipulating STG syntax trees.
65 * ------------------------------------------------------------------------*/
67 List makeArgs( Int n )
71 args = cons(mkStgVar(NIL,NIL),args);
76 StgExpr makeStgLambda( List args, StgExpr body )
81 if (whatIs(body) == LAMBDA) {
82 return mkStgLambda(dupListOnto(args,stgLambdaArgs(body)),
85 return mkStgLambda(args,body);
90 StgExpr makeStgApp( StgVar fun, List args )
95 return mkStgApp(fun,args);
99 StgExpr makeStgLet( List binds, StgExpr body )
104 return mkStgLet(binds,body);
108 StgExpr makeStgIf( StgExpr cond, StgExpr e1, StgExpr e2 )
110 if (cond == nameTrue) {
112 } else if (cond == nameFalse) {
115 return mkStgCase(cond,doubleton(mkStgCaseAlt(nameTrue,NIL,e1),
116 mkStgCaseAlt(nameFalse,NIL,e2)));
147 StgVar mkStgVar( StgRhs rhs, Cell info )
149 return ap(STGVAR,triple(rhs,mkStgRep(PTR_REP),info));
153 /* --------------------------------------------------------------------------
155 * ------------------------------------------------------------------------*/
157 /* --------------------------------------------------------------------------
159 * ------------------------------------------------------------------------*/
161 static Void local pIndent ( Int );
162 static Void local putStgVar ( StgVar );
163 static Void local putStgVars ( List );
164 static Void local putStgAtom ( StgAtom a );
165 static Void local putStgAtoms ( List as );
166 static Void local putStgBinds ( List );
167 static Void local putStgExpr ( StgExpr );
168 static Void local putStgRhs ( StgRhs );
169 static Void local putStgPat ( StgCaseAlt );
170 static Void local putStgPrimPat ( StgPrimAlt );
174 /* --------------------------------------------------------------------------
175 * Indentation and showing names/constants
176 * ------------------------------------------------------------------------*/
178 static Void local pIndent(n) /* indent to particular position */
182 Putc(' ',outputStream);
187 /* --------------------------------------------------------------------------
188 * Pretty printer for stg code:
189 * ------------------------------------------------------------------------*/
191 static Void putStgAlts ( Int left, List alts );
193 static Void local putStgVar(StgVar v)
196 unlexVar(name(v).text);
201 putChr(charOf(stgVarRep(v)));
203 if (isInt(stgVarInfo(v))) {
205 putInt(intOf(stgVarInfo(v)));
211 static Void local putStgVars( List vs )
213 for(; nonNull(vs); vs=tl(vs)) {
219 static Void local putStgAtom( StgAtom a )
227 unlexCharConst(charOf(a));
235 putStr(bignumToString(a));
239 putStr(floatToString(a));
243 unlexStrConst(textOf(a));
249 case LETREC: case LAMBDA: case CASE: case PRIMCASE:
250 case STGAPP: case STGPRIM: case STGCON:
254 fprintf(stderr,"\nYoiks: "); printExp(stderr,a);
255 internal("putStgAtom");
259 Void putStgAtoms( List as )
262 while (nonNull(as)) {
272 Void putStgPat( StgCaseAlt alt )
274 if (whatIs(alt)==DEEFALT) {
275 putStgVar(stgDefaultVar(alt));
278 if (whatIs(alt)==CASEALT) {
279 List vs = stgCaseAltVars(alt);
280 if (whatIs(stgCaseAltCon(alt))==TUPLE) {
284 while (nonNull(vs)) {
292 if (whatIs(stgCaseAltCon(alt))==NAME) {
293 unlexVar(name(stgCaseAltCon(alt)).text);
294 for (; nonNull(vs); vs=tl(vs)) {
300 internal("putStgPat(2)");
303 internal("putStgPat(1)");
306 Void putStgPrimPat( StgVar v )
308 if (nonNull(stgVarBody(v))) {
309 StgExpr d = stgVarBody(v);
318 fprintf(stderr,"\nYoiks: "); printExp(stderr,d);
319 internal("putStgPrimPat");
327 Void putStgBinds(binds) /* pretty print locals */
329 Int left = outColumn;
332 while (nonNull(binds)) {
333 Cell bind = hd(binds);
336 putStgRhs(stgVarBody(bind));
346 static Void putStgAlts( Int left, List alts )
348 if (length(alts) == 1) {
349 StgCaseAlt alt = hd(alts);
354 if (isDefaultAlt(alt))
355 putStgExpr(stgDefaultBody(alt)); else
356 putStgExpr(stgCaseAltBody(alt));
360 for (; nonNull(alts); alts=tl(alts)) {
361 StgCaseAlt alt = hd(alts);
368 if (isDefaultAlt(alt))
369 putStgExpr(stgDefaultBody(alt)); else
370 putStgExpr(stgCaseAltBody(alt));
379 static Void putStgPrimAlts( Int left, List alts )
381 if (length(alts) == 1) {
382 StgPrimAlt alt = hd(alts);
384 mapProc(putStgPrimPat,stgPrimAltVars(alt));
387 putStgExpr(stgPrimAltBody(alt));
391 for (; nonNull(alts); alts=tl(alts)) {
392 StgPrimAlt alt = hd(alts);
394 mapProc(putStgPrimPat,stgPrimAltVars(alt));
396 putStgExpr(stgPrimAltBody(alt));
404 Void putStgExpr( StgExpr e ) /* pretty print expr */
406 if (isNull(e)) putStr("(putStgExpr:NIL)");else
411 Int left = outColumn;
412 putStgBinds(stgLetBinds(e));
413 if (whatIs(stgLetBody(e))==LETREC) {
414 putStr("\n"); pIndent(left);
416 if (whatIs(stgLetBody(e))==CASE) {
417 putStr("\n"); pIndent(left+2);
419 putStgExpr(stgLetBody(e));
424 Int left = outColumn;
426 putStgVars(stgLambdaArgs(e));
429 putStgExpr(stgLambdaBody(e));
434 Int left = outColumn;
436 putStgExpr(stgCaseScrut(e));
438 putStgAlts(left,stgCaseAlts(e));
443 /* a hack; not for regular use */
444 putStgAlts(outColumn,singleton(e));
447 /* a hack; not for regular use */
448 putStgPrimAlts(outColumn,singleton(e));
452 Int left = outColumn;
454 putStgExpr(stgPrimCaseScrut(e));
456 putStgPrimAlts(left,stgPrimCaseAlts(e));
461 Cell op = stgPrimOp(e);
462 unlexVarStr(asmGetPrimopName(name(op).primop));
463 putStgAtoms(stgPrimArgs(e));
467 putStgExpr(stgAppFun(e));
468 putStgAtoms(stgAppArgs(e));
486 /* hope that it's really a list of StgExprs, so map putStgExpr
488 for (;nonNull(e);e=tl(e)) {
494 internal("putStgExpr");
495 /* Pretend it's a list of algebraic case alternatives. Used for
496 printing the case-alt lists attached to BCOs which are return
497 continuations. Very useful for debugging. An appalling hack tho.
499 /* fprintf(stderr, " "); putStgAlts(3,e); */
503 Void putStgRhs( StgRhs e ) /* print lifted definition */
508 Name con = stgConCon(e);
511 putInt(tupleOf(con));
513 unlexVar(name(con).text);
515 putStgAtoms(stgConArgs(e));
524 static void beginStgPP( FILE* fp );
525 static void endStgPP( FILE* fp );
527 static void beginStgPP( FILE* fp )
531 fflush(stderr); fflush(stdout);
534 static void endStgPP( FILE* fp )
539 Void printStg(fp,b) /* Pretty print sc defn on fp */
545 n = nameFromStgVar(b);
547 putStr(textToStr(name(n).text));
552 putStgRhs(stgVarBody(b));
557 Void ppStg( StgVar v )
562 Void ppStgExpr( StgExpr e )
569 Void ppStgRhs( StgRhs rhs )
576 Void ppStgAlts( List alts )
583 extern Void ppStgPrimAlts( List alts )
586 putStgPrimAlts(0,alts);
590 extern Void ppStgVars( List vs )
599 /*-------------------------------------------------------------------------*/