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.5 $
  11  * $Date: 1999/03/09 14:51:13 $
  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(dupListOnto(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   //printf("{%d %d %d} ", namePMFail, e, whatIs(e) );
 123     switch (whatIs(e)) {
 124     case STGVAR:
 125             return TRUE;
 126     default:
 127             return FALSE;
 128     }
 129 }
 130
 131 Bool isAtomic(e)
 132 StgRhs e; {
 133     switch (whatIs(e)) {
 134     case STGVAR:
 135     case NAME:
 136     case CHARCELL:
 137     case INTCELL:
 138     case BIGCELL:
 139     case FLOATCELL:
 140     case STRCELL:
 141     case PTRCELL:
 142             return TRUE;
 143     default:
 144             return FALSE;
 145     }
 146 }
 147
 148 StgVar mkStgVar( StgRhs rhs, Cell info )
 149 {
 150     return ap(STGVAR,triple(rhs,mkStgRep(PTR_REP),info));
 151 }
 152
 153 /*-------------------------------------------------------------------------*/
 154
 155 /* --------------------------------------------------------------------------
 156  * STG pretty printer
 157  *
 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
 161  *
 162  * $RCSfile: stg.c,v $
 163  * $Revision: 1.5 $
 164  * $Date: 1999/03/09 14:51:13 $
 165  * ------------------------------------------------------------------------*/
 166
 167 /* --------------------------------------------------------------------------
 168  * Local functions
 169  * ------------------------------------------------------------------------*/
 170
 171 static Void local pIndent        Args((Int));
 172
 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));
 182
 183
 184 /* --------------------------------------------------------------------------
 185  * Indentation and showing names/constants
 186  * ------------------------------------------------------------------------*/
 187
 188 static Void local pIndent(n)           /* indent to particular position    */
 189 Int n; {
 190     outColumn = n;
 191     while (0<n--) {
 192         Putc(' ',outputStream);
 193     }
 194 }
 195
 196
 197 /* --------------------------------------------------------------------------
 198  * Pretty printer for stg code:
 199  * ------------------------------------------------------------------------*/
 200
 201 static Void putStgAlts    ( Int left, List alts );
 202 //static Void putStgPrimAlt ( Int left, List vs, StgExpr body );
 203
 204 static Void local putStgVar(StgVar v)
 205 {
 206     if (isName(v)) {
 207         unlexVar(name(v).text);
 208     } else {
 209         putStr("id");
 210         putInt(-v);
 211     }
 212 }
 213
 214 static Void local putStgVars( List vs )
 215 {
 216     for(; nonNull(vs); vs=tl(vs)) {
 217         putStgVar(hd(vs));
 218         putChr(' ');
 219     }
 220 }
 221
 222 static Void local putStgAtom( StgAtom a )
 223 {
 224     switch (whatIs(a)) {
 225     case STGVAR:
 226     case NAME:
 227             putStgVar(a);
 228             break;
 229     case CHARCELL:
 230             unlexCharConst(charOf(a));
 231             putChr('#');
 232             break;
 233     case INTCELL:
 234             putInt(intOf(a));
 235             putChr('#');
 236             break;
 237     case BIGCELL:
 238             putStr(bignumToString(a));
 239             putChr('#');
 240             break;
 241     case FLOATCELL:
 242             putStr(floatToString(a));
 243             putChr('#');
 244             break;
 245     case STRCELL:
 246             unlexStrConst(textOf(a));
 247             break;
 248     case PTRCELL:
 249             putPtr(ptrOf(a));
 250             putChr('#');
 251             break;
 252     default:
 253             fprintf(stderr,"\nYoiks: "); printExp(stderr,a);
 254             internal("putStgAtom");
 255     }
 256 }
 257
 258 Void putStgAtoms( List as )
 259 {
 260     putChr('{');
 261     while (nonNull(as)) {
 262         putStgAtom(hd(as));
 263         as=tl(as);
 264         if (nonNull(as)) {
 265             putChr(',');
 266         }
 267     }
 268     putChr('}');
 269 }
 270
 271 Void putStgPat( StgPat pat )
 272 {
 273     putStgVar(pat);
 274     if (nonNull(stgVarBody(pat))) {
 275         StgDiscr d  = stgConCon(stgVarBody(pat));
 276         List     vs = stgConArgs(stgVarBody(pat));
 277         putChr('@');
 278         switch (whatIs(d)) {
 279         case NAME:
 280             {
 281                 unlexVar(name(d).text);
 282                 for (; nonNull(vs); vs=tl(vs)) {
 283                     putChr(' ');
 284                     putStgVar(hd(vs));
 285                 }
 286                 break;
 287             }
 288         case TUPLE:
 289             {
 290                 putChr('(');
 291                 putStgVar(hd(vs));
 292                 vs=tl(vs);
 293                 while (nonNull(vs)) {
 294                     putChr(',');
 295                     putStgVar(hd(vs));
 296                     vs=tl(vs);
 297                 }
 298                 putChr(')');
 299                 break;
 300             }
 301         default:
 302                 fprintf(stderr,"\nYoiks: "); printExp(stderr,d);
 303                 internal("putStgPat");
 304         }
 305     }
 306 }
 307
 308 Void putStgPrimPat( StgPrimPat pat )
 309 {
 310     putStgVar(pat);
 311     if (nonNull(stgVarBody(pat))) {
 312         StgExpr d  = stgVarBody(pat);
 313         putChr('@');
 314         switch (whatIs(d)) {
 315         case INTCELL:
 316             {
 317                 putInt(intOf(d));
 318                 putChr('#');
 319                 break;
 320             }
 321         default:
 322                 fprintf(stderr,"\nYoiks: "); printExp(stderr,d);
 323                 internal("putStgPrimPat");
 324         }
 325     }
 326     putChr(' ');
 327 }
 328
 329 Void putStgBinds(binds)        /* pretty print locals           */
 330 List binds; {
 331     Int left = outColumn;
 332
 333     putStr("let { ");
 334     while (nonNull(binds)) {
 335         Cell bind = hd(binds);
 336         putStgVar(bind);
 337         putStr(" = ");
 338         putStgRhs(stgVarBody(bind));
 339         putStr("\n");
 340         binds = tl(binds);
 341         if (nonNull(binds))
 342             pIndent(left+6);
 343     }
 344     pIndent(left);
 345     putStr("} in  ");
 346 }
 347
 348 static Void putStgAlts( Int left, List alts )
 349 {
 350   if (length(alts) == 1) {
 351         StgCaseAlt alt = hd(alts);
 352         putStr("{ ");
 353         putStgPat(stgCaseAltPat(alt));
 354         putStr(" ->\n");
 355         pIndent(left);
 356         putStgExpr(stgCaseAltBody(alt));
 357         putStr("}");
 358     } else {
 359         putStr("{\n");
 360         for (; nonNull(alts); alts=tl(alts)) {
 361             StgCaseAlt alt = hd(alts);
 362             pIndent(left+2);
 363             putStgPat(stgCaseAltPat(alt));
 364
 365             //putStr(" -> ");
 366             putStr(" ->\n");
 367             pIndent(left+4);
 368
 369             putStgExpr(stgCaseAltBody(alt));
 370             putStr("\n");
 371         }
 372         pIndent(left);
 373         putStr("}\n");
 374     }
 375 }
 376
 377 static Void putStgPrimAlts( Int left, List alts )
 378 {
 379     if (length(alts) == 1) {
 380         StgPrimAlt alt = hd(alts);
 381         putStr("{ ");
 382         mapProc(putStgPrimPat,stgPrimAltPats(alt));
 383         putStr(" ->\n");
 384         pIndent(left);
 385         putStgExpr(stgPrimAltBody(alt));
 386         putStr("}");
 387     } else {
 388         putStr("{\n");
 389         for (; nonNull(alts); alts=tl(alts)) {
 390             StgPrimAlt alt = hd(alts);
 391             pIndent(left+2);
 392             mapProc(putStgPrimPat,stgPrimAltPats(alt));
 393             putStr(" -> ");
 394             putStgExpr(stgPrimAltBody(alt));
 395             putStr("\n");
 396         }
 397         pIndent(left);
 398         putStr("}\n");
 399     }
 400 }
 401
 402 Void putStgExpr( StgExpr e )                        /* pretty print expr */
 403 {
 404     switch (whatIs(e)) {
 405     case LETREC:
 406             putStgBinds(stgLetBinds(e));
 407             putStgExpr(stgLetBody(e));
 408             break;
 409     case LAMBDA:
 410         {
 411             Int left = outColumn;
 412             putStr("\\ ");
 413             putStgVars(stgLambdaArgs(e));
 414             putStr("->\n");
 415             pIndent(left+2);
 416             putStgExpr(stgLambdaBody(e));
 417             break;
 418         }
 419     case CASE:
 420         {
 421             Int left = outColumn;
 422             putStr("case ");
 423             putStgExpr(stgCaseScrut(e));
 424             putStr(" of ");
 425             putStgAlts(left,stgCaseAlts(e));
 426             break;
 427         }
 428     case PRIMCASE:
 429         {
 430             Int  left = outColumn;
 431             putStr("case# ");
 432             putStgExpr(stgPrimCaseScrut(e));
 433             putStr(" of ");
 434             putStgPrimAlts(left,stgPrimCaseAlts(e));
 435             break;
 436         }
 437     case STGPRIM:
 438         {
 439             Cell op = stgPrimOp(e);
 440             unlexVar(name(op).text);
 441             putStgAtoms(stgPrimArgs(e));
 442             break;
 443         }
 444     case STGAPP:
 445             putStgVar(stgAppFun(e));
 446             putStgAtoms(stgAppArgs(e));
 447             break;
 448     case STGVAR:
 449     case NAME:
 450             putStgVar(e);
 451             break;
 452     default:
 453       //fprintf(stderr,"\nYoiks: "); printExp(stderr,e);
 454       //internal("putStgExpr");
 455       //ToDo: rm this appalling hack
 456       fprintf(stderr, "   "); putStgAlts(3,e);
 457     }
 458 }
 459
 460 Void putStgRhs( StgRhs e )            /* print lifted definition         */
 461 {
 462     switch (whatIs(e)) {
 463     case STGCON:
 464         {
 465             Name   con  = stgConCon(e);
 466             if (isTuple(con)) {
 467                 putStr("Tuple");
 468                 putInt(tupleOf(con));
 469             } else {
 470                 unlexVar(name(con).text);
 471             }
 472             putStgAtoms(stgConArgs(e));
 473             break;
 474         }
 475     default:
 476             putStgExpr(e);
 477             break;
 478     }
 479 }
 480
 481 static void beginStgPP( FILE* fp );
 482 static void endStgPP( FILE* fp );
 483
 484 static void beginStgPP( FILE* fp )
 485 {
 486     outputStream = fp;
 487     //putChr('\n');
 488     outColumn = 0;
 489 }
 490
 491 static void endStgPP( FILE* fp )
 492 {
 493     fflush(fp);
 494 }
 495
 496 Void printStg(fp,b)              /* Pretty print sc defn on fp      */
 497 FILE  *fp;
 498 StgVar b;
 499 {
 500     beginStgPP(fp);
 501     putStgVar(b);
 502     putStr(" = ");
 503     putStgRhs(stgVarBody(b));
 504     putStr("\n");
 505     endStgPP(fp);
 506 }
 507
 508 #if 1 /*DEBUG_PRINTER*/
 509 Void ppStg( StgVar v )
 510 {
 511   if ( 1 /*debugCode*/ ) {
 512         printStg(stdout,v);
 513     }
 514 }
 515
 516 Void ppStgExpr( StgExpr e )
 517 {
 518     if ( 1 /*debugCode*/ ) {
 519         beginStgPP(stderr);
 520         putStgExpr(e);
 521         endStgPP(stdout);
 522     }
 523 }
 524
 525 Void ppStgRhs( StgRhs rhs )
 526 {
 527   if (1 /*debugCode*/ ) {
 528         beginStgPP(stdout);
 529         putStgRhs(rhs);
 530         endStgPP(stdout);
 531     }
 532 }
 533
 534 Void ppStgAlts( List alts )
 535 {
 536   if (1 /*debugCode*/ ) {
 537         beginStgPP(stdout);
 538         putStgAlts(0,alts);
 539         endStgPP(stdout);
 540     }
 541 }
 542
 543 extern Void ppStgPrimAlts( List alts )
 544 {
 545     if (1 /*debugCode*/ ) {
 546         beginStgPP(stdout);
 547         putStgPrimAlts(0,alts);
 548         endStgPP(stdout);
 549     }
 550 }
 551
 552 extern Void ppStgVars( List vs )
 553 {
 554     if (1 /*debugCode*/ ) {
 555         beginStgPP(stdout);
 556         printf("Vars: ");
 557         putStgVars(vs);
 558         printf("\n");
 559         endStgPP(stdout);
 560     }
 561 }
 562 #endif
 563
 564 /*-------------------------------------------------------------------------*/