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: 1999/11/12 17:32:45 $
14 * ------------------------------------------------------------------------*/
21 #include "link.h" /* for nameTrue/False */
22 #include "Assembler.h" /* for AsmRep and primops */
24 /* --------------------------------------------------------------------------
26 * ------------------------------------------------------------------------*/
28 void* stgConInfo( StgDiscr d )
32 return asmMkInfo(cfunOf(d),name(d).arity);
34 return asmMkInfo(0,tupleOf(d));
36 internal("stgConInfo");
40 int stgDiscrTag( StgDiscr d )
48 internal("stgDiscrTag");
52 /* --------------------------------------------------------------------------
53 * Utility functions for manipulating STG syntax trees.
54 * ------------------------------------------------------------------------*/
56 List makeArgs( Int n )
60 args = cons(mkStgVar(NIL,NIL),args);
65 StgExpr makeStgLambda( List args, StgExpr body )
70 if (whatIs(body) == LAMBDA) {
71 return mkStgLambda(dupListOnto(args,stgLambdaArgs(body)),
74 return mkStgLambda(args,body);
79 StgExpr makeStgApp( StgVar fun, List args )
84 return mkStgApp(fun,args);
88 StgExpr makeStgLet( List binds, StgExpr body )
93 return mkStgLet(binds,body);
97 StgExpr makeStgIf( StgExpr cond, StgExpr e1, StgExpr e2 )
99 if (cond == nameTrue) {
101 } else if (cond == nameFalse) {
104 return mkStgCase(cond,doubleton(mkStgCaseAlt(nameTrue,NIL,e1),
105 mkStgCaseAlt(nameFalse,NIL,e2)));
136 StgVar mkStgVar( StgRhs rhs, Cell info )
138 return ap(STGVAR,triple(rhs,mkStgRep(PTR_REP),info));
142 /* --------------------------------------------------------------------------
144 * ------------------------------------------------------------------------*/
146 /* --------------------------------------------------------------------------
148 * ------------------------------------------------------------------------*/
150 static Void local pIndent Args((Int));
152 static Void local putStgVar Args((StgVar));
153 static Void local putStgVars Args((List));
154 static Void local putStgAtom Args((StgAtom a));
155 static Void local putStgAtoms Args((List as));
156 static Void local putStgBinds Args((List));
157 static Void local putStgExpr Args((StgExpr));
158 static Void local putStgRhs Args((StgRhs));
159 static Void local putStgPat Args((StgCaseAlt));
160 static Void local putStgPrimPat Args((StgPrimAlt));
164 /* --------------------------------------------------------------------------
165 * Indentation and showing names/constants
166 * ------------------------------------------------------------------------*/
168 static Void local pIndent(n) /* indent to particular position */
172 Putc(' ',outputStream);
177 /* --------------------------------------------------------------------------
178 * Pretty printer for stg code:
179 * ------------------------------------------------------------------------*/
181 static Void putStgAlts ( Int left, List alts );
183 static Void local putStgVar(StgVar v)
186 unlexVar(name(v).text);
191 putChr(charOf(stgVarRep(v)));
193 if (isInt(stgVarInfo(v))) {
195 putInt(intOf(stgVarInfo(v)));
201 static Void local putStgVars( List vs )
203 for(; nonNull(vs); vs=tl(vs)) {
209 static Void local putStgAtom( StgAtom a )
217 unlexCharConst(charOf(a));
225 putStr(bignumToString(a));
229 putStr(floatToString(a));
233 unlexStrConst(textOf(a));
239 case LETREC: case LAMBDA: case CASE: case PRIMCASE:
240 case STGAPP: case STGPRIM: case STGCON:
244 fprintf(stderr,"\nYoiks: "); printExp(stderr,a);
245 internal("putStgAtom");
249 Void putStgAtoms( List as )
252 while (nonNull(as)) {
262 Void putStgPat( StgCaseAlt alt )
264 if (whatIs(alt)==DEEFALT) {
265 putStgVar(stgDefaultVar(alt));
268 if (whatIs(alt)==CASEALT) {
269 List vs = stgCaseAltVars(alt);
270 if (whatIs(stgCaseAltCon(alt))==TUPLE) {
274 while (nonNull(vs)) {
282 if (whatIs(stgCaseAltCon(alt))==NAME) {
283 unlexVar(name(stgCaseAltCon(alt)).text);
284 for (; nonNull(vs); vs=tl(vs)) {
290 internal("putStgPat(2)");
293 internal("putStgPat(1)");
296 Void putStgPrimPat( StgVar v )
298 if (nonNull(stgVarBody(v))) {
299 StgExpr d = stgVarBody(v);
308 fprintf(stderr,"\nYoiks: "); printExp(stderr,d);
309 internal("putStgPrimPat");
317 Void putStgBinds(binds) /* pretty print locals */
319 Int left = outColumn;
322 while (nonNull(binds)) {
323 Cell bind = hd(binds);
326 putStgRhs(stgVarBody(bind));
336 static Void putStgAlts( Int left, List alts )
338 if (length(alts) == 1) {
339 StgCaseAlt alt = hd(alts);
344 if (isDefaultAlt(alt))
345 putStgExpr(stgDefaultBody(alt)); else
346 putStgExpr(stgCaseAltBody(alt));
350 for (; nonNull(alts); alts=tl(alts)) {
351 StgCaseAlt alt = hd(alts);
358 if (isDefaultAlt(alt))
359 putStgExpr(stgDefaultBody(alt)); else
360 putStgExpr(stgCaseAltBody(alt));
369 static Void putStgPrimAlts( Int left, List alts )
371 if (length(alts) == 1) {
372 StgPrimAlt alt = hd(alts);
374 mapProc(putStgPrimPat,stgPrimAltVars(alt));
377 putStgExpr(stgPrimAltBody(alt));
381 for (; nonNull(alts); alts=tl(alts)) {
382 StgPrimAlt alt = hd(alts);
384 mapProc(putStgPrimPat,stgPrimAltVars(alt));
386 putStgExpr(stgPrimAltBody(alt));
394 Void putStgExpr( StgExpr e ) /* pretty print expr */
396 if (isNull(e)) putStr("(putStgExpr:NIL)");else
401 Int left = outColumn;
402 putStgBinds(stgLetBinds(e));
403 if (whatIs(stgLetBody(e))==LETREC) {
404 putStr("\n"); pIndent(left);
406 if (whatIs(stgLetBody(e))==CASE) {
407 putStr("\n"); pIndent(left+2);
409 putStgExpr(stgLetBody(e));
414 Int left = outColumn;
416 putStgVars(stgLambdaArgs(e));
419 putStgExpr(stgLambdaBody(e));
424 Int left = outColumn;
426 putStgExpr(stgCaseScrut(e));
428 putStgAlts(left,stgCaseAlts(e));
433 /* a hack; not for regular use */
434 putStgAlts(outColumn,singleton(e));
437 /* a hack; not for regular use */
438 putStgPrimAlts(outColumn,singleton(e));
442 Int left = outColumn;
444 putStgExpr(stgPrimCaseScrut(e));
446 putStgPrimAlts(left,stgPrimCaseAlts(e));
451 Cell op = stgPrimOp(e);
452 unlexVar(name(op).text);
453 putStgAtoms(stgPrimArgs(e));
457 putStgExpr(stgAppFun(e));
458 putStgAtoms(stgAppArgs(e));
476 /* hope that it's really a list of StgExprs, so map putStgExpr
478 for (;nonNull(e);e=tl(e)) {
484 internal("putStgExpr");
485 /* Pretend it's a list of algebraic case alternatives. Used for
486 printing the case-alt lists attached to BCOs which are return
487 continuations. Very useful for debugging. An appalling hack tho.
489 /* fprintf(stderr, " "); putStgAlts(3,e); */
493 Void putStgRhs( StgRhs e ) /* print lifted definition */
498 Name con = stgConCon(e);
501 putInt(tupleOf(con));
503 unlexVar(name(con).text);
505 putStgAtoms(stgConArgs(e));
514 static void beginStgPP( FILE* fp );
515 static void endStgPP( FILE* fp );
517 static void beginStgPP( FILE* fp )
521 fflush(stderr); fflush(stdout);
524 static void endStgPP( FILE* fp )
529 Void printStg(fp,b) /* Pretty print sc defn on fp */
535 n = nameFromStgVar(b);
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 /*-------------------------------------------------------------------------*/