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/03/01 14:46:53 $
12 * ------------------------------------------------------------------------*/
19 #include "link.h" /* for nameTrue/False */
20 #include "Assembler.h" /* for AsmRep and primops */
22 /* --------------------------------------------------------------------------
24 * ------------------------------------------------------------------------*/
26 int stgConTag( StgDiscr d )
34 internal("stgConTag");
38 void* stgConInfo( StgDiscr d )
42 return asmMkInfo(cfunOf(d),name(d).arity);
44 return asmMkInfo(0,tupleOf(d));
46 internal("stgConInfo");
50 /* ToDo: identical to stgConTag */
51 int stgDiscrTag( StgDiscr d )
59 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)));
122 //printf("{%d %d %d} ", namePMFail, e, whatIs(e) );
148 StgVar mkStgVar( StgRhs rhs, Cell info )
150 return ap(STGVAR,triple(rhs,mkStgRep(PTR_REP),info));
153 /*-------------------------------------------------------------------------*/
155 /* --------------------------------------------------------------------------
158 * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
159 * All rights reserved. See NOTICE for details and conditions of use etc...
160 * Hugs version 1.4, December 1997
162 * $RCSfile: stg.c,v $
164 * $Date: 1999/03/01 14:46:53 $
165 * ------------------------------------------------------------------------*/
167 /* --------------------------------------------------------------------------
169 * ------------------------------------------------------------------------*/
171 static Void local pIndent Args((Int));
173 static Void local putStgVar Args((StgVar));
174 static Void local putStgVars Args((List));
175 static Void local putStgAtom Args((StgAtom a));
176 static Void local putStgAtoms Args((List as));
177 static Void local putStgBinds Args((List));
178 static Void local putStgExpr Args((StgExpr));
179 static Void local putStgRhs Args((StgRhs));
180 static Void local putStgPat Args((StgPat));
181 static Void local putStgPrimPat Args((StgPrimPat));
184 /* --------------------------------------------------------------------------
185 * Indentation and showing names/constants
186 * ------------------------------------------------------------------------*/
188 static Void local pIndent(n) /* indent to particular position */
192 Putc(' ',outputStream);
197 /* --------------------------------------------------------------------------
198 * Pretty printer for stg code:
199 * ------------------------------------------------------------------------*/
201 static Void putStgAlts ( Int left, List alts );
202 //static Void putStgPrimAlt ( Int left, List vs, StgExpr body );
204 static Void local putStgVar(StgVar v)
207 unlexVar(name(v).text);
214 static Void local putStgVars( List vs )
216 for(; nonNull(vs); vs=tl(vs)) {
222 static Void local putStgAtom( StgAtom a )
230 unlexCharConst(charOf(a));
238 putStr(bignumToString(a));
242 putStr(floatToString(a));
246 unlexStrConst(textOf(a));
253 fprintf(stderr,"\nYoiks: "); printExp(stderr,a);
254 internal("putStgAtom");
258 Void putStgAtoms( List as )
261 while (nonNull(as)) {
271 Void putStgPat( StgPat pat )
274 if (nonNull(stgVarBody(pat))) {
275 StgDiscr d = stgConCon(stgVarBody(pat));
276 List vs = stgConArgs(stgVarBody(pat));
281 unlexVar(name(d).text);
282 for (; nonNull(vs); vs=tl(vs)) {
293 while (nonNull(vs)) {
302 fprintf(stderr,"\nYoiks: "); printExp(stderr,d);
303 internal("putStgPat");
308 Void putStgPrimPat( StgPrimPat pat )
311 if (nonNull(stgVarBody(pat))) {
312 StgExpr d = stgVarBody(pat);
322 fprintf(stderr,"\nYoiks: "); printExp(stderr,d);
323 internal("putStgPrimPat");
329 Void putStgBinds(binds) /* pretty print locals */
331 Int left = outColumn;
334 while (nonNull(binds)) {
335 Cell bind = hd(binds);
338 putStgRhs(stgVarBody(bind));
348 static Void putStgAlts( Int left, List alts )
350 if (length(alts) == 1) {
351 StgCaseAlt alt = hd(alts);
353 putStgPat(stgCaseAltPat(alt));
356 putStgExpr(stgCaseAltBody(alt));
360 for (; nonNull(alts); alts=tl(alts)) {
361 StgCaseAlt alt = hd(alts);
363 putStgPat(stgCaseAltPat(alt));
369 putStgExpr(stgCaseAltBody(alt));
377 static Void putStgPrimAlts( Int left, List alts )
379 if (length(alts) == 1) {
380 StgPrimAlt alt = hd(alts);
382 mapProc(putStgPrimPat,stgPrimAltPats(alt));
385 putStgExpr(stgPrimAltBody(alt));
389 for (; nonNull(alts); alts=tl(alts)) {
390 StgPrimAlt alt = hd(alts);
392 mapProc(putStgPrimPat,stgPrimAltPats(alt));
394 putStgExpr(stgPrimAltBody(alt));
402 Void putStgExpr( StgExpr e ) /* pretty print expr */
406 putStgBinds(stgLetBinds(e));
407 putStgExpr(stgLetBody(e));
411 Int left = outColumn;
413 putStgVars(stgLambdaArgs(e));
416 putStgExpr(stgLambdaBody(e));
421 Int left = outColumn;
423 putStgExpr(stgCaseScrut(e));
425 putStgAlts(left,stgCaseAlts(e));
430 Int left = outColumn;
432 putStgExpr(stgPrimCaseScrut(e));
434 putStgPrimAlts(left,stgPrimCaseAlts(e));
439 Cell op = stgPrimOp(e);
440 unlexVar(name(op).text);
441 putStgAtoms(stgPrimArgs(e));
445 putStgVar(stgAppFun(e));
446 putStgAtoms(stgAppArgs(e));
453 //fprintf(stderr,"\nYoiks: "); printExp(stderr,e);
454 //internal("putStgExpr");
455 //ToDo: rm this appalling hack
456 fprintf(stderr, " "); putStgAlts(3,e);
460 Void putStgRhs( StgRhs e ) /* print lifted definition */
465 Name con = stgConCon(e);
468 putInt(tupleOf(con));
470 unlexVar(name(con).text);
472 putStgAtoms(stgConArgs(e));
481 static void beginStgPP( FILE* fp );
482 static void endStgPP( FILE* fp );
484 static void beginStgPP( FILE* fp )
491 static void endStgPP( FILE* fp )
496 Void printStg(fp,b) /* Pretty print sc defn on fp */
503 putStgRhs(stgVarBody(b));
508 #if 1 /*DEBUG_PRINTER*/
509 Void ppStg( StgVar v )
511 if ( 1 /*debugCode*/ ) {
516 Void ppStgExpr( StgExpr e )
518 if ( 1 /*debugCode*/ ) {
525 Void ppStgRhs( StgRhs rhs )
527 if (1 /*debugCode*/ ) {
534 Void ppStgAlts( List alts )
543 extern Void ppStgPrimAlts( List alts )
547 putStgPrimAlts(0,alts);
552 extern Void ppStgVars( List vs )
564 /*-------------------------------------------------------------------------*/