ghc/interpreter/pp.c

   1 /* -*- mode: hugs-c; -*- */
   2 /* --------------------------------------------------------------------------
   3  * STG pretty printer
   4  *
   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
   8  *
   9  * $RCSfile: pp.c,v $
  10  * $Revision: 1.2 $
  11  * $Date: 1998/12/02 13:22:31 $
  12  * ------------------------------------------------------------------------*/
  13
  14 #include "prelude.h"
  15 #include "storage.h"
  16 #include "connect.h"
  17 #include "errors.h"
  18 #include "stg.h"
  19 #include "pp.h"
  20 #include "hugs.h"  /* for debugCode */
  21 #include "input.h" /* for unlexChar */
  22
  23 /* --------------------------------------------------------------------------
  24  * Local functions
  25  * ------------------------------------------------------------------------*/
  26
  27 static Void local pIndent        Args((Int));
  28 static Void local unlexVar       Args((Text));
  29 static Void local unlexCharConst Args((Cell));
  30 static Void local unlexStrConst  Args((Text));
  31
  32 static Void local putStgVar       Args((StgVar));
  33 static Void local putStgVars      Args((List));
  34 static Void local putStgAtom      Args((StgAtom a));
  35 static Void local putStgAtoms     Args((List as));
  36 static Void local putStgBinds     Args((List));
  37 static Void local putStgExpr      Args((StgExpr));
  38 static Void local putStgRhs       Args((StgRhs));
  39 static Void local putStgPat       Args((StgPat));
  40 static Void local putStgPrimPat   Args((StgPrimPat));
  41
  42 /* --------------------------------------------------------------------------
  43  * Basic output routines:
  44  * ------------------------------------------------------------------------*/
  45
  46 static FILE *outputStream;             /* current output stream            */
  47 static Int  outColumn = 0;             /* current output column number     */
  48
  49 static Void local putChr( Int c );
  50 static Void local putStr( String s );
  51 static Void local putInt( Int n );
  52 static Void local putPtr( Ptr p );
  53
  54 static Void local putChr(c)            /* print single character           */
  55 Int c; {
  56     Putc(c,outputStream);
  57     outColumn++;
  58 }
  59
  60 static Void local putStr(s)            /* print string                     */
  61 String s; {
  62     for (; *s; s++) {
  63         Putc(*s,outputStream);
  64         outColumn++;
  65     }
  66 }
  67
  68 static Void local putInt(n)            /* print integer                    */
  69 Int n; {
  70     static char intBuf[16];
  71     sprintf(intBuf,"%d",n);
  72     putStr(intBuf);
  73 }
  74
  75 static Void local putPtr(p)            /* print pointer                    */
  76 Ptr p; {
  77     static char intBuf[16];
  78     sprintf(intBuf,"%p",p);
  79     putStr(intBuf);
  80 }
  81
  82 /* --------------------------------------------------------------------------
  83  * Indentation and showing names/constants
  84  * ------------------------------------------------------------------------*/
  85
  86 static Void local pIndent(n)           /* indent to particular position    */
  87 Int n; {
  88     outColumn = n;
  89     while (0<n--) {
  90         Putc(' ',outputStream);
  91     }
  92 }
  93
  94 static Void local unlexVar(t)          /* print text as a variable name    */
  95 Text t; {                              /* operator symbols must be enclosed*/
  96     String s = textToStr(t);           /* in parentheses... except [] ...  */
  97
  98     if ((isascii(s[0]) && isalpha(s[0])) || s[0]=='_' || s[0]=='[' || s[0]=='(')
  99         putStr(s);
 100     else {
 101         putChr('(');
 102         putStr(s);
 103         putChr(')');
 104     }
 105 }
 106
 107 static Void local unlexCharConst(c)
 108 Cell c; {
 109     putChr('\'');
 110     putStr(unlexChar(c,'\''));
 111     putChr('\'');
 112 }
 113
 114 static Void local unlexStrConst(t)
 115 Text t; {
 116     String s            = textToStr(t);
 117     static Char SO      = 14;          /* ASCII code for '\SO'             */
 118     Bool   lastWasSO    = FALSE;
 119     Bool   lastWasDigit = FALSE;
 120     Bool   lastWasEsc   = FALSE;
 121
 122     putChr('\"');
 123     for (; *s; s++) {
 124         String ch = unlexChar(*s,'\"');
 125         Char   c  = ' ';
 126
 127         if ((lastWasSO && *ch=='H') ||
 128                 (lastWasEsc && lastWasDigit && isascii(*ch) && isdigit(*ch)))
 129             putStr("\\&");
 130
 131         lastWasEsc   = (*ch=='\\');
 132         lastWasSO    = (*s==SO);
 133         for (; *ch; c = *ch++)
 134             putChr(*ch);
 135         lastWasDigit = (isascii(c) && isdigit(c));
 136     }
 137     putChr('\"');
 138 }
 139
 140 /* --------------------------------------------------------------------------
 141  * Pretty printer for stg code:
 142  * ------------------------------------------------------------------------*/
 143
 144 static Void putStgAlts    ( Int left, List alts );
 145 static Void putStgPrimAlt ( Int left, List vs, StgExpr body );
 146
 147 static Void local putStgVar(StgVar v)
 148 {
 149     if (isName(v)) {
 150         unlexVar(name(v).text);
 151     } else {
 152         putStr("id");
 153         putInt(-v);
 154     }
 155 }
 156
 157 static Void local putStgVars( List vs )
 158 {
 159     for(; nonNull(vs); vs=tl(vs)) {
 160         putStgVar(hd(vs));
 161         putChr(' ');
 162     }
 163 }
 164
 165 static Void local putStgAtom( StgAtom a )
 166 {
 167     switch (whatIs(a)) {
 168     case STGVAR:
 169     case NAME:
 170             putStgVar(a);
 171             break;
 172     case CHARCELL:
 173             unlexCharConst(charOf(a));
 174             putChr('#');
 175             break;
 176     case INTCELL:
 177             putInt(intOf(a));
 178             putChr('#');
 179             break;
 180     case BIGCELL:
 181             putStr(bignumToString(a));
 182             putChr('#');
 183             break;
 184     case FLOATCELL:
 185             putStr(floatToString(a));
 186             putChr('#');
 187             break;
 188     case STRCELL:
 189             unlexStrConst(textOf(a));
 190             break;
 191     case PTRCELL:
 192             putPtr(ptrOf(a));
 193             putChr('#');
 194             break;
 195     default:
 196             fprintf(stderr,"\nYoiks: "); printExp(stderr,a);
 197             internal("putStgAtom");
 198     }
 199 }
 200
 201 Void putStgAtoms( List as )
 202 {
 203     putChr('{');
 204     while (nonNull(as)) {
 205         putStgAtom(hd(as));
 206         as=tl(as);
 207         if (nonNull(as)) {
 208             putChr(',');
 209         }
 210     }
 211     putChr('}');
 212 }
 213
 214 Void putStgPat( StgPat pat )
 215 {
 216     putStgVar(pat);
 217     if (nonNull(stgVarBody(pat))) {
 218         StgDiscr d  = stgConCon(stgVarBody(pat));
 219         List     vs = stgConArgs(stgVarBody(pat));
 220         putChr('@');
 221         switch (whatIs(d)) {
 222         case NAME:
 223             {
 224                 unlexVar(name(d).text);
 225                 for (; nonNull(vs); vs=tl(vs)) {
 226                     putChr(' ');
 227                     putStgVar(hd(vs));
 228                 }
 229                 break;
 230             }
 231         case TUPLE:
 232             {
 233                 putChr('(');
 234                 putStgVar(hd(vs));
 235                 vs=tl(vs);
 236                 while (nonNull(vs)) {
 237                     putChr(',');
 238                     putStgVar(hd(vs));
 239                     vs=tl(vs);
 240                 }
 241                 putChr(')');
 242                 break;
 243             }
 244         default:
 245                 fprintf(stderr,"\nYoiks: "); printExp(stderr,d);
 246                 internal("putStgPat");
 247         }
 248     }
 249 }
 250
 251 Void putStgPrimPat( StgPrimPat pat )
 252 {
 253     putStgVar(pat);
 254     if (nonNull(stgVarBody(pat))) {
 255         StgExpr d  = stgVarBody(pat);
 256         putChr('@');
 257         switch (whatIs(d)) {
 258         case INTCELL:
 259             {
 260                 putInt(intOf(d));
 261                 putChr('#');
 262                 break;
 263             }
 264         default:
 265                 fprintf(stderr,"\nYoiks: "); printExp(stderr,d);
 266                 internal("putStgPrimPat");
 267         }
 268     }
 269     putChr(' ');
 270 }
 271
 272 Void putStgBinds(binds)        /* pretty print locals           */
 273 List binds; {
 274     Int left = outColumn;
 275
 276     putStr("let { ");
 277     while (nonNull(binds)) {
 278         Cell bind = hd(binds);
 279         putStgVar(bind);
 280         putStr(" = ");
 281         putStgRhs(stgVarBody(bind));
 282         putStr("\n");
 283         binds = tl(binds);
 284         if (nonNull(binds))
 285             pIndent(left+6);
 286     }
 287     pIndent(left);
 288     putStr("} in  ");
 289 }
 290
 291 static Void putStgAlts( Int left, List alts )
 292 {
 293     if (length(alts) == 1) {
 294         StgCaseAlt alt = hd(alts);
 295         putStr("{ ");
 296         putStgPat(stgCaseAltPat(alt));
 297         putStr(" ->\n");
 298         pIndent(left);
 299         putStgExpr(stgCaseAltBody(alt));
 300         putStr("}");
 301     } else {
 302         putStr("{\n");
 303         for (; nonNull(alts); alts=tl(alts)) {
 304             StgCaseAlt alt = hd(alts);
 305             pIndent(left+2);
 306             putStgPat(stgCaseAltPat(alt));
 307             putStr(" -> ");
 308             putStgExpr(stgCaseAltBody(alt));
 309             putStr("\n");
 310         }
 311         pIndent(left);
 312         putStr("}\n");
 313     }
 314 }
 315
 316 static Void putStgPrimAlts( Int left, List alts )
 317 {
 318     if (length(alts) == 1) {
 319         StgPrimAlt alt = hd(alts);
 320         putStr("{ ");
 321         mapProc(putStgPrimPat,stgPrimAltPats(alt));
 322         putStr(" ->\n");
 323         pIndent(left);
 324         putStgExpr(stgPrimAltBody(alt));
 325         putStr("}");
 326     } else {
 327         putStr("{\n");
 328         for (; nonNull(alts); alts=tl(alts)) {
 329             StgPrimAlt alt = hd(alts);
 330             pIndent(left+2);
 331             mapProc(putStgPrimPat,stgPrimAltPats(alt));
 332             putStr(" -> ");
 333             putStgExpr(stgPrimAltBody(alt));
 334             putStr("\n");
 335         }
 336         pIndent(left);
 337         putStr("}\n");
 338     }
 339 }
 340
 341 Void putStgExpr( StgExpr e )                        /* pretty print expr */
 342 {
 343     switch (whatIs(e)) {
 344     case LETREC:
 345             putStgBinds(stgLetBinds(e));
 346             putStgExpr(stgLetBody(e));
 347             break;
 348     case LAMBDA:
 349         {
 350             Int left = outColumn;
 351             putStr("\\ ");
 352             putStgVars(stgLambdaArgs(e));
 353             putStr("->\n");
 354             pIndent(left+2);
 355             putStgExpr(stgLambdaBody(e));
 356             break;
 357         }
 358     case CASE:
 359         {
 360             Int left = outColumn;
 361             putStr("case ");
 362             putStgExpr(stgCaseScrut(e));
 363             putStr(" of ");
 364             putStgAlts(left,stgCaseAlts(e));
 365             break;
 366         }
 367     case PRIMCASE:
 368         {
 369             Int  left = outColumn;
 370             putStr("case# ");
 371             putStgExpr(stgPrimCaseScrut(e));
 372             putStr(" of ");
 373             putStgPrimAlts(left,stgPrimCaseAlts(e));
 374             break;
 375         }
 376     case STGPRIM:
 377         {
 378             Cell op = stgPrimOp(e);
 379             unlexVar(name(op).text);
 380             putStgAtoms(stgPrimArgs(e));
 381             break;
 382         }
 383     case STGAPP:
 384             putStgVar(stgAppFun(e));
 385             putStgAtoms(stgAppArgs(e));
 386             break;
 387     case STGVAR:
 388     case NAME:
 389             putStgVar(e);
 390             break;
 391     default:
 392             fprintf(stderr,"\nYoiks: "); printExp(stderr,e);
 393             internal("putStgExpr");
 394     }
 395 }
 396
 397 Void putStgRhs( StgRhs e )            /* print lifted definition         */
 398 {
 399     switch (whatIs(e)) {
 400     case STGCON:
 401         {
 402             Name   con  = stgConCon(e);
 403             if (isTuple(con)) {
 404                 putStr("Tuple");
 405                 putInt(tupleOf(con));
 406             } else {
 407                 unlexVar(name(con).text);
 408             }
 409             putStgAtoms(stgConArgs(e));
 410             break;
 411         }
 412     default:
 413             putStgExpr(e);
 414             break;
 415     }
 416 }
 417
 418 static void beginStgPP( FILE* fp );
 419 static void endStgPP( FILE* fp );
 420
 421 static void beginStgPP( FILE* fp )
 422 {
 423     outputStream = fp;
 424     putChr('\n');
 425     outColumn = 0;
 426 }
 427
 428 static void endStgPP( FILE* fp )
 429 {
 430     fflush(fp);
 431 }
 432
 433 Void printStg(fp,b)              /* Pretty print sc defn on fp      */
 434 FILE  *fp;
 435 StgVar b;
 436 {
 437     beginStgPP(fp);
 438     putStgVar(b);
 439     putStr(" = ");
 440     putStgRhs(stgVarBody(b));
 441     putStr("\n");
 442     endStgPP(fp);
 443 }
 444
 445 #if DEBUG_PRINTER
 446 Void ppStg( StgVar v )
 447 {
 448     if (debugCode) {
 449         printStg(stdout,v);
 450     }
 451 }
 452
 453 Void ppStgExpr( StgExpr e )
 454 {
 455     if (debugCode) {
 456         beginStgPP(stdout);
 457         putStgExpr(e);
 458         endStgPP(stdout);
 459     }
 460 }
 461
 462 Void ppStgRhs( StgRhs rhs )
 463 {
 464     if (debugCode) {
 465         beginStgPP(stdout);
 466         putStgRhs(rhs);
 467         endStgPP(stdout);
 468     }
 469 }
 470
 471 Void ppStgAlts( List alts )
 472 {
 473     if (debugCode) {
 474         beginStgPP(stdout);
 475         putStgAlts(0,alts);
 476         endStgPP(stdout);
 477     }
 478 }
 479
 480 extern Void ppStgPrimAlts( List alts )
 481 {
 482     if (debugCode) {
 483         beginStgPP(stdout);
 484         putStgPrimAlts(0,alts);
 485         endStgPP(stdout);
 486     }
 487 }
 488
 489 extern Void ppStgVars( List vs )
 490 {
 491     if (debugCode) {
 492         beginStgPP(stdout);
 493         printf("Vars: ");
 494         putStgVars(vs);
 495         printf("\n");
 496         endStgPP(stdout);
 497     }
 498 }
 499 #endif
 500
 501 /*-------------------------------------------------------------------------*/