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/04/27 16:35:29 $
14 * ------------------------------------------------------------------------*/
16 #include "hugsbasictypes.h"
21 #include "Rts.h" /* to make StgPtr visible in Assembler.h */
22 #include "Assembler.h" /* for AsmRep and primops */
24 /* --------------------------------------------------------------------------
26 * ------------------------------------------------------------------------*/
28 /* Make an info table for a constructor or tuple. */
29 void* stgConInfo ( StgDiscr d )
37 name(d).itbl = asmMkInfo(tag,name(d).arity);
43 tycon(d).itbl = asmMkInfo(tag,tupleOf(d));
47 internal("stgConInfo");
51 /* Return the tag for a constructor or tuple, starting at zero. */
52 int stgDiscrTag ( StgDiscr d )
56 case NAME: tag = cfunOf(d); break;
58 default: internal("stgDiscrTag");
64 /* --------------------------------------------------------------------------
65 * Utility functions for manipulating STG syntax trees.
66 * ------------------------------------------------------------------------*/
68 List makeArgs( Int n )
72 args = cons(mkStgVar(NIL,NIL),args);
77 StgExpr makeStgLambda( List args, StgExpr body )
82 if (whatIs(body) == LAMBDA) {
83 return mkStgLambda(dupListOnto(args,stgLambdaArgs(body)),
86 return mkStgLambda(args,body);
91 StgExpr makeStgApp( StgVar fun, List args )
96 return mkStgApp(fun,args);
100 StgExpr makeStgLet( List binds, StgExpr body )
105 return mkStgLet(binds,body);
109 StgExpr makeStgIf( StgExpr cond, StgExpr e1, StgExpr e2 )
111 if (cond == nameTrue) {
113 } else if (cond == nameFalse) {
116 return mkStgCase(cond,doubleton(mkStgCaseAlt(nameTrue,NIL,e1),
117 mkStgCaseAlt(nameFalse,NIL,e2)));
148 StgVar mkStgVar( StgRhs rhs, Cell info )
150 return ap(STGVAR,triple(rhs,mkStgRep(PTR_REP),info));
154 /* --------------------------------------------------------------------------
156 * ------------------------------------------------------------------------*/
158 /* --------------------------------------------------------------------------
160 * ------------------------------------------------------------------------*/
162 static Void local pIndent ( Int );
163 static Void local putStgVar ( StgVar );
164 static Void local putStgVars ( List );
165 static Void local putStgAtom ( StgAtom a );
166 static Void local putStgAtoms ( List as );
167 static Void local putStgBinds ( List );
168 static Void local putStgExpr ( StgExpr );
169 static Void local putStgRhs ( StgRhs );
170 static Void local putStgPat ( StgCaseAlt );
171 static Void local putStgPrimPat ( StgPrimAlt );
175 /* --------------------------------------------------------------------------
176 * Indentation and showing names/constants
177 * ------------------------------------------------------------------------*/
179 static Void local pIndent(n) /* indent to particular position */
183 Putc(' ',outputStream);
188 /* --------------------------------------------------------------------------
189 * Pretty printer for stg code:
190 * ------------------------------------------------------------------------*/
192 static Void putStgAlts ( Int left, List alts );
194 static Void local putStgVar(StgVar v)
201 unlexVar(name(v).text);
206 putChr(charOf(stgVarRep(v)));
208 if (isInt(stgVarInfo(v))) {
210 putInt(intOf(stgVarInfo(v)));
216 static Void local putStgVars( List vs )
218 for(; nonNull(vs); vs=tl(vs)) {
224 static Void local putStgAtom( StgAtom a )
232 unlexCharConst(charOf(a));
240 putStr(bignumToString(a));
244 putStr(floatToString(a));
248 unlexStrConst(textOf(a));
254 case LETREC: case LAMBDA: case CASE: case PRIMCASE:
255 case STGAPP: case STGPRIM: case STGCON:
259 fprintf(stderr,"\nYoiks: "); printExp(stderr,a);
260 internal("putStgAtom");
264 Void putStgAtoms( List as )
267 while (nonNull(as)) {
277 Void putStgPat( StgCaseAlt alt )
279 if (whatIs(alt)==DEEFALT) {
280 putStgVar(stgDefaultVar(alt));
283 if (whatIs(alt)==CASEALT) {
284 List vs = stgCaseAltVars(alt);
285 if (whatIs(stgCaseAltCon(alt))==TUPLE) {
289 while (nonNull(vs)) {
297 if (whatIs(stgCaseAltCon(alt))==NAME) {
298 unlexVar(name(stgCaseAltCon(alt)).text);
299 for (; nonNull(vs); vs=tl(vs)) {
305 internal("putStgPat(2)");
308 internal("putStgPat(1)");
311 Void putStgPrimPat( StgVar v )
313 if (nonNull(stgVarBody(v))) {
314 StgExpr d = stgVarBody(v);
323 fprintf(stderr,"\nYoiks: "); printExp(stderr,d);
324 internal("putStgPrimPat");
332 Void putStgBinds(binds) /* pretty print locals */
334 Int left = outColumn;
337 while (nonNull(binds)) {
338 Cell bind = hd(binds);
341 putStgRhs(stgVarBody(bind));
351 static Void putStgAlts( Int left, List alts )
353 if (length(alts) == 1) {
354 StgCaseAlt alt = hd(alts);
359 if (isDefaultAlt(alt))
360 putStgExpr(stgDefaultBody(alt)); else
361 putStgExpr(stgCaseAltBody(alt));
365 for (; nonNull(alts); alts=tl(alts)) {
366 StgCaseAlt alt = hd(alts);
373 if (isDefaultAlt(alt))
374 putStgExpr(stgDefaultBody(alt)); else
375 putStgExpr(stgCaseAltBody(alt));
384 static Void putStgPrimAlts( Int left, List alts )
386 if (length(alts) == 1) {
387 StgPrimAlt alt = hd(alts);
389 mapProc(putStgPrimPat,stgPrimAltVars(alt));
392 putStgExpr(stgPrimAltBody(alt));
396 for (; nonNull(alts); alts=tl(alts)) {
397 StgPrimAlt alt = hd(alts);
399 mapProc(putStgPrimPat,stgPrimAltVars(alt));
401 putStgExpr(stgPrimAltBody(alt));
409 Void putStgExpr( StgExpr e ) /* pretty print expr */
412 putStr("(putStgExpr:NIL)");
419 Int left = outColumn;
420 putStgBinds(stgLetBinds(e));
421 if (whatIs(stgLetBody(e))==LETREC) {
422 putStr("\n"); pIndent(left);
424 if (whatIs(stgLetBody(e))==CASE) {
425 putStr("\n"); pIndent(left+2);
427 putStgExpr(stgLetBody(e));
432 Int left = outColumn;
434 putStgVars(stgLambdaArgs(e));
437 putStgExpr(stgLambdaBody(e));
442 Int left = outColumn;
444 putStgExpr(stgCaseScrut(e));
446 putStgAlts(left,stgCaseAlts(e));
451 /* a hack; not for regular use */
452 putStgAlts(outColumn,singleton(e));
455 /* a hack; not for regular use */
456 putStgPrimAlts(outColumn,singleton(e));
460 Int left = outColumn;
462 putStgExpr(stgPrimCaseScrut(e));
464 putStgPrimAlts(left,stgPrimCaseAlts(e));
469 Cell op = stgPrimOp(e);
470 unlexVarStr(asmGetPrimopName(name(op).primop));
471 putStgAtoms(stgPrimArgs(e));
475 putStgExpr(stgAppFun(e));
476 putStgAtoms(stgAppArgs(e));
495 /* hope that it's really a list of StgExprs, so map putStgExpr
497 for (;nonNull(e);e=tl(e)) {
503 internal("putStgExpr");
504 /* Pretend it's a list of algebraic case alternatives. Used for
505 printing the case-alt lists attached to BCOs which are return
506 continuations. Very useful for debugging. An appalling hack tho.
508 /* fprintf(stderr, " "); putStgAlts(3,e); */
512 Void putStgRhs( StgRhs e ) /* print lifted definition */
517 Name con = stgConCon(e);
520 putInt(tupleOf(con));
522 unlexVar(name(con).text);
524 putStgAtoms(stgConArgs(e));
533 static void beginStgPP( FILE* fp );
534 static void endStgPP( FILE* fp );
536 static void beginStgPP( FILE* fp )
540 fflush(stderr); fflush(stdout);
543 static void endStgPP( FILE* fp )
548 Void printStg(fp,b) /* Pretty print sc defn on fp */
554 n = NIL; /* nameFromStgVar(b); */
556 putStr(textToStr(name(n).text));
561 putStgRhs(stgVarBody(b));
566 Void ppStg( StgVar v )
571 Void ppStgExpr( StgExpr e )
578 Void ppStgRhs( StgRhs rhs )
585 Void ppStgAlts( List alts )
592 extern Void ppStgPrimAlts( List alts )
595 putStgPrimAlts(0,alts);
599 extern Void ppStgVars( List vs )
608 /*-------------------------------------------------------------------------*/