ghc/interpreter/stg.c

   1
   2 /* --------------------------------------------------------------------------
   3  * STG syntax
   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: stg.c,v $
  10  * $Revision: 1.3 $
  11  * $Date: 1999/02/03 17:08:39 $
  12  * ------------------------------------------------------------------------*/
  13
  14 #include "prelude.h"
  15 #include "storage.h"
  16 #include "backend.h"
  17 #include "connect.h"
  18 #include "errors.h"
  19 #include "link.h"      /* for nameTrue/False     */
  20 #include "Assembler.h" /* for AsmRep and primops */
  21
  22 /* --------------------------------------------------------------------------
  23  * Utility functions
  24  * ------------------------------------------------------------------------*/
  25
  26 int stgConTag( StgDiscr d )
  27 {
  28     switch (whatIs(d)) {
  29     case NAME:
  30             return cfunOf(d);
  31     case TUPLE:
  32             return 0;
  33     default:
  34             internal("stgConTag");
  35     }
  36 }
  37
  38 void* stgConInfo( StgDiscr d )
  39 {
  40     switch (whatIs(d)) {
  41     case NAME:
  42             return asmMkInfo(cfunOf(d),name(d).arity);
  43     case TUPLE:
  44             return asmMkInfo(0,tupleOf(d));
  45     default:
  46             internal("stgConInfo");
  47     }
  48 }
  49
  50 /* ToDo: identical to stgConTag */
  51 int stgDiscrTag( StgDiscr d )
  52 {
  53     switch (whatIs(d)) {
  54     case NAME:
  55             return cfunOf(d);
  56     case TUPLE:
  57             return 0;
  58     default:
  59             internal("stgDiscrTag");
  60     }
  61 }
  62
  63 /* --------------------------------------------------------------------------
  64  * Utility functions for manipulating STG syntax trees.
  65  * ------------------------------------------------------------------------*/
  66
  67 List makeArgs( Int n )
  68 {
  69     List args = NIL;
  70     for(; n>0; --n) {
  71         args = cons(mkStgVar(NIL,NIL),args);
  72     }
  73     return args;
  74 }
  75
  76 StgExpr makeStgLambda( List args, StgExpr body )
  77 {
  78     if (isNull(args)) {
  79         return body;
  80     } else {
  81         if (whatIs(body) == LAMBDA) {
  82             return mkStgLambda(dupOnto(args,stgLambdaArgs(body)),
  83                                stgLambdaBody(body));
  84         } else {
  85             return mkStgLambda(args,body);
  86         }
  87     }
  88 }
  89
  90 StgExpr makeStgApp( StgVar fun, List args )
  91 {
  92     if (isNull(args)) {
  93         return fun;
  94     } else {
  95         return mkStgApp(fun,args);
  96     }
  97 }
  98
  99 StgExpr makeStgLet( List binds, StgExpr body )
 100 {
 101     if (isNull(binds)) {
 102         return body;
 103     } else {
 104         return mkStgLet(binds,body);
 105     }
 106 }
 107
 108 StgExpr makeStgIf( StgExpr cond, StgExpr e1, StgExpr e2 )
 109 {
 110     if (cond == nameTrue) {
 111         return e1;
 112     } else if (cond == nameFalse) {
 113         return e2;
 114     } else {
 115         return mkStgCase(cond,doubleton(mkStgCaseAlt(nameTrue,NIL,e1),
 116                                         mkStgCaseAlt(nameFalse,NIL,e2)));
 117     }
 118 }
 119
 120 Bool isStgVar(e)
 121 StgRhs e; {
 122     switch (whatIs(e)) {
 123     case STGVAR:
 124             return TRUE;
 125     default:
 126             return FALSE;
 127     }
 128 }
 129
 130 Bool isAtomic(e)
 131 StgRhs e; {
 132     switch (whatIs(e)) {
 133     case STGVAR:
 134     case NAME:
 135     case CHARCELL:
 136     case INTCELL:
 137     case BIGCELL:
 138     case FLOATCELL:
 139     case STRCELL:
 140     case PTRCELL:
 141             return TRUE;
 142     default:
 143             return FALSE;
 144     }
 145 }
 146
 147 StgVar mkStgVar( StgRhs rhs, Cell info )
 148 {
 149     return ap(STGVAR,triple(rhs,mkStgRep(PTR_REP),info));
 150 }
 151
 152 /*-------------------------------------------------------------------------*/
 153
 154 /* --------------------------------------------------------------------------
 155  * STG pretty printer
 156  *
 157  * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
 158  * All rights reserved. See NOTICE for details and conditions of use etc...
 159  * Hugs version 1.4, December 1997
 160  *
 161  * $RCSfile: stg.c,v $
 162  * $Revision: 1.3 $
 163  * $Date: 1999/02/03 17:08:39 $
 164  * ------------------------------------------------------------------------*/
 165
 166 /* --------------------------------------------------------------------------
 167  * Local functions
 168  * ------------------------------------------------------------------------*/
 169
 170 static Void local pIndent        Args((Int));
 171 static Void local unlexVar       Args((Text));
 172 static Void local unlexCharConst Args((Cell));
 173 static Void local unlexStrConst  Args((Text));
 174
 175 static Void local putStgVar       Args((StgVar));
 176 static Void local putStgVars      Args((List));
 177 static Void local putStgAtom      Args((StgAtom a));
 178 static Void local putStgAtoms     Args((List as));
 179 static Void local putStgBinds     Args((List));
 180 static Void local putStgExpr      Args((StgExpr));
 181 static Void local putStgRhs       Args((StgRhs));
 182 static Void local putStgPat       Args((StgPat));
 183 static Void local putStgPrimPat   Args((StgPrimPat));
 184
 185 /* --------------------------------------------------------------------------
 186  * Basic output routines:
 187  * ------------------------------------------------------------------------*/
 188
 189 static FILE *outputStream;             /* current output stream            */
 190 static Int  outColumn = 0;             /* current output column number     */
 191
 192 static Void local putChr( Int c );
 193 static Void local putStr( String s );
 194 static Void local putInt( Int n );
 195 static Void local putPtr( Ptr p );
 196
 197 static Void local putChr(c)            /* print single character           */
 198 Int c; {
 199     Putc(c,outputStream);
 200     outColumn++;
 201 }
 202
 203 static Void local putStr(s)            /* print string                     */
 204 String s; {
 205     for (; *s; s++) {
 206         Putc(*s,outputStream);
 207         outColumn++;
 208     }
 209 }
 210
 211 static Void local putInt(n)            /* print integer                    */
 212 Int n; {
 213     static char intBuf[16];
 214     sprintf(intBuf,"%d",n);
 215     putStr(intBuf);
 216 }
 217
 218 static Void local putPtr(p)            /* print pointer                    */
 219 Ptr p; {
 220     static char intBuf[16];
 221     sprintf(intBuf,"%p",p);
 222     putStr(intBuf);
 223 }
 224
 225 /* --------------------------------------------------------------------------
 226  * Indentation and showing names/constants
 227  * ------------------------------------------------------------------------*/
 228
 229 static Void local pIndent(n)           /* indent to particular position    */
 230 Int n; {
 231     outColumn = n;
 232     while (0<n--) {
 233         Putc(' ',outputStream);
 234     }
 235 }
 236
 237 static Void local unlexVar(t)          /* print text as a variable name    */
 238 Text t; {                              /* operator symbols must be enclosed*/
 239     String s = textToStr(t);           /* in parentheses... except [] ...  */
 240
 241     if ((isascii(s[0]) && isalpha(s[0])) || s[0]=='_' || s[0]=='[' || s[0]=='(')
 242         putStr(s);
 243     else {
 244         putChr('(');
 245         putStr(s);
 246         putChr(')');
 247     }
 248 }
 249
 250 static Void local unlexCharConst(c)
 251 Cell c; {
 252     putChr('\'');
 253     putStr(unlexChar(c,'\''));
 254     putChr('\'');
 255 }
 256
 257 static Void local unlexStrConst(t)
 258 Text t; {
 259     String s            = textToStr(t);
 260     static Char SO      = 14;          /* ASCII code for '\SO'             */
 261     Bool   lastWasSO    = FALSE;
 262     Bool   lastWasDigit = FALSE;
 263     Bool   lastWasEsc   = FALSE;
 264
 265     putChr('\"');
 266     for (; *s; s++) {
 267         String ch = unlexChar(*s,'\"');
 268         Char   c  = ' ';
 269
 270         if ((lastWasSO && *ch=='H') ||
 271                 (lastWasEsc && lastWasDigit && isascii(*ch) && isdigit(*ch)))
 272             putStr("\\&");
 273
 274         lastWasEsc   = (*ch=='\\');
 275         lastWasSO    = (*s==SO);
 276         for (; *ch; c = *ch++)
 277             putChr(*ch);
 278         lastWasDigit = (isascii(c) && isdigit(c));
 279     }
 280     putChr('\"');
 281 }
 282
 283 /* --------------------------------------------------------------------------
 284  * Pretty printer for stg code:
 285  * ------------------------------------------------------------------------*/
 286
 287 static Void putStgAlts    ( Int left, List alts );
 288 static Void putStgPrimAlt ( Int left, List vs, StgExpr body );
 289
 290 static Void local putStgVar(StgVar v)
 291 {
 292     if (isName(v)) {
 293         unlexVar(name(v).text);
 294     } else {
 295         putStr("id");
 296         putInt(-v);
 297     }
 298 }
 299
 300 static Void local putStgVars( List vs )
 301 {
 302     for(; nonNull(vs); vs=tl(vs)) {
 303         putStgVar(hd(vs));
 304         putChr(' ');
 305     }
 306 }
 307
 308 static Void local putStgAtom( StgAtom a )
 309 {
 310     switch (whatIs(a)) {
 311     case STGVAR:
 312     case NAME:
 313             putStgVar(a);
 314             break;
 315     case CHARCELL:
 316             unlexCharConst(charOf(a));
 317             putChr('#');
 318             break;
 319     case INTCELL:
 320             putInt(intOf(a));
 321             putChr('#');
 322             break;
 323     case BIGCELL:
 324             putStr(bignumToString(a));
 325             putChr('#');
 326             break;
 327     case FLOATCELL:
 328             putStr(floatToString(a));
 329             putChr('#');
 330             break;
 331     case STRCELL:
 332             unlexStrConst(textOf(a));
 333             break;
 334     case PTRCELL:
 335             putPtr(ptrOf(a));
 336             putChr('#');
 337             break;
 338     default:
 339             fprintf(stderr,"\nYoiks: "); printExp(stderr,a);
 340             internal("putStgAtom");
 341     }
 342 }
 343
 344 Void putStgAtoms( List as )
 345 {
 346     putChr('{');
 347     while (nonNull(as)) {
 348         putStgAtom(hd(as));
 349         as=tl(as);
 350         if (nonNull(as)) {
 351             putChr(',');
 352         }
 353     }
 354     putChr('}');
 355 }
 356
 357 Void putStgPat( StgPat pat )
 358 {
 359     putStgVar(pat);
 360     if (nonNull(stgVarBody(pat))) {
 361         StgDiscr d  = stgConCon(stgVarBody(pat));
 362         List     vs = stgConArgs(stgVarBody(pat));
 363         putChr('@');
 364         switch (whatIs(d)) {
 365         case NAME:
 366             {
 367                 unlexVar(name(d).text);
 368                 for (; nonNull(vs); vs=tl(vs)) {
 369                     putChr(' ');
 370                     putStgVar(hd(vs));
 371                 }
 372                 break;
 373             }
 374         case TUPLE:
 375             {
 376                 putChr('(');
 377                 putStgVar(hd(vs));
 378                 vs=tl(vs);
 379                 while (nonNull(vs)) {
 380                     putChr(',');
 381                     putStgVar(hd(vs));
 382                     vs=tl(vs);
 383                 }
 384                 putChr(')');
 385                 break;
 386             }
 387         default:
 388                 fprintf(stderr,"\nYoiks: "); printExp(stderr,d);
 389                 internal("putStgPat");
 390         }
 391     }
 392 }
 393
 394 Void putStgPrimPat( StgPrimPat pat )
 395 {
 396     putStgVar(pat);
 397     if (nonNull(stgVarBody(pat))) {
 398         StgExpr d  = stgVarBody(pat);
 399         putChr('@');
 400         switch (whatIs(d)) {
 401         case INTCELL:
 402             {
 403                 putInt(intOf(d));
 404                 putChr('#');
 405                 break;
 406             }
 407         default:
 408                 fprintf(stderr,"\nYoiks: "); printExp(stderr,d);
 409                 internal("putStgPrimPat");
 410         }
 411     }
 412     putChr(' ');
 413 }
 414
 415 Void putStgBinds(binds)        /* pretty print locals           */
 416 List binds; {
 417     Int left = outColumn;
 418
 419     putStr("let { ");
 420     while (nonNull(binds)) {
 421         Cell bind = hd(binds);
 422         putStgVar(bind);
 423         putStr(" = ");
 424         putStgRhs(stgVarBody(bind));
 425         putStr("\n");
 426         binds = tl(binds);
 427         if (nonNull(binds))
 428             pIndent(left+6);
 429     }
 430     pIndent(left);
 431     putStr("} in  ");
 432 }
 433
 434 static Void putStgAlts( Int left, List alts )
 435 {
 436     if (length(alts) == 1) {
 437         StgCaseAlt alt = hd(alts);
 438         putStr("{ ");
 439         putStgPat(stgCaseAltPat(alt));
 440         putStr(" ->\n");
 441         pIndent(left);
 442         putStgExpr(stgCaseAltBody(alt));
 443         putStr("}");
 444     } else {
 445         putStr("{\n");
 446         for (; nonNull(alts); alts=tl(alts)) {
 447             StgCaseAlt alt = hd(alts);
 448             pIndent(left+2);
 449             putStgPat(stgCaseAltPat(alt));
 450             putStr(" -> ");
 451             putStgExpr(stgCaseAltBody(alt));
 452             putStr("\n");
 453         }
 454         pIndent(left);
 455         putStr("}\n");
 456     }
 457 }
 458
 459 static Void putStgPrimAlts( Int left, List alts )
 460 {
 461     if (length(alts) == 1) {
 462         StgPrimAlt alt = hd(alts);
 463         putStr("{ ");
 464         mapProc(putStgPrimPat,stgPrimAltPats(alt));
 465         putStr(" ->\n");
 466         pIndent(left);
 467         putStgExpr(stgPrimAltBody(alt));
 468         putStr("}");
 469     } else {
 470         putStr("{\n");
 471         for (; nonNull(alts); alts=tl(alts)) {
 472             StgPrimAlt alt = hd(alts);
 473             pIndent(left+2);
 474             mapProc(putStgPrimPat,stgPrimAltPats(alt));
 475             putStr(" -> ");
 476             putStgExpr(stgPrimAltBody(alt));
 477             putStr("\n");
 478         }
 479         pIndent(left);
 480         putStr("}\n");
 481     }
 482 }
 483
 484 Void putStgExpr( StgExpr e )                        /* pretty print expr */
 485 {
 486     switch (whatIs(e)) {
 487     case LETREC:
 488             putStgBinds(stgLetBinds(e));
 489             putStgExpr(stgLetBody(e));
 490             break;
 491     case LAMBDA:
 492         {
 493             Int left = outColumn;
 494             putStr("\\ ");
 495             putStgVars(stgLambdaArgs(e));
 496             putStr("->\n");
 497             pIndent(left+2);
 498             putStgExpr(stgLambdaBody(e));
 499             break;
 500         }
 501     case CASE:
 502         {
 503             Int left = outColumn;
 504             putStr("case ");
 505             putStgExpr(stgCaseScrut(e));
 506             putStr(" of ");
 507             putStgAlts(left,stgCaseAlts(e));
 508             break;
 509         }
 510     case PRIMCASE:
 511         {
 512             Int  left = outColumn;
 513             putStr("case# ");
 514             putStgExpr(stgPrimCaseScrut(e));
 515             putStr(" of ");
 516             putStgPrimAlts(left,stgPrimCaseAlts(e));
 517             break;
 518         }
 519     case STGPRIM:
 520         {
 521             Cell op = stgPrimOp(e);
 522             unlexVar(name(op).text);
 523             putStgAtoms(stgPrimArgs(e));
 524             break;
 525         }
 526     case STGAPP:
 527             putStgVar(stgAppFun(e));
 528             putStgAtoms(stgAppArgs(e));
 529             break;
 530     case STGVAR:
 531     case NAME:
 532             putStgVar(e);
 533             break;
 534     default:
 535             fprintf(stderr,"\nYoiks: "); printExp(stderr,e);
 536             internal("putStgExpr");
 537     }
 538 }
 539
 540 Void putStgRhs( StgRhs e )            /* print lifted definition         */
 541 {
 542     switch (whatIs(e)) {
 543     case STGCON:
 544         {
 545             Name   con  = stgConCon(e);
 546             if (isTuple(con)) {
 547                 putStr("Tuple");
 548                 putInt(tupleOf(con));
 549             } else {
 550                 unlexVar(name(con).text);
 551             }
 552             putStgAtoms(stgConArgs(e));
 553             break;
 554         }
 555     default:
 556             putStgExpr(e);
 557             break;
 558     }
 559 }
 560
 561 static void beginStgPP( FILE* fp );
 562 static void endStgPP( FILE* fp );
 563
 564 static void beginStgPP( FILE* fp )
 565 {
 566     outputStream = fp;
 567     putChr('\n');
 568     outColumn = 0;
 569 }
 570
 571 static void endStgPP( FILE* fp )
 572 {
 573     fflush(fp);
 574 }
 575
 576 Void printStg(fp,b)              /* Pretty print sc defn on fp      */
 577 FILE  *fp;
 578 StgVar b;
 579 {
 580     beginStgPP(fp);
 581     putStgVar(b);
 582     putStr(" = ");
 583     putStgRhs(stgVarBody(b));
 584     putStr("\n");
 585     endStgPP(fp);
 586 }
 587
 588 #if DEBUG_PRINTER
 589 Void ppStg( StgVar v )
 590 {
 591     if (debugCode) {
 592         printStg(stdout,v);
 593     }
 594 }
 595
 596 Void ppStgExpr( StgExpr e )
 597 {
 598     if (debugCode) {
 599         beginStgPP(stdout);
 600         putStgExpr(e);
 601         endStgPP(stdout);
 602     }
 603 }
 604
 605 Void ppStgRhs( StgRhs rhs )
 606 {
 607     if (debugCode) {
 608         beginStgPP(stdout);
 609         putStgRhs(rhs);
 610         endStgPP(stdout);
 611     }
 612 }
 613
 614 Void ppStgAlts( List alts )
 615 {
 616     if (debugCode) {
 617         beginStgPP(stdout);
 618         putStgAlts(0,alts);
 619         endStgPP(stdout);
 620     }
 621 }
 622
 623 extern Void ppStgPrimAlts( List alts )
 624 {
 625     if (debugCode) {
 626         beginStgPP(stdout);
 627         putStgPrimAlts(0,alts);
 628         endStgPP(stdout);
 629     }
 630 }
 631
 632 extern Void ppStgVars( List vs )
 633 {
 634     if (debugCode) {
 635         beginStgPP(stdout);
 636         printf("Vars: ");
 637         putStgVars(vs);
 638         printf("\n");
 639         endStgPP(stdout);
 640     }
 641 }
 642 #endif
 643
 644 /*-------------------------------------------------------------------------*/