ghc/interpreter/stg.c

   1
   2 /* --------------------------------------------------------------------------
   3  * STG syntax
   4  *
   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.
  10  *
  11  * $RCSfile: stg.c,v $
  12  * $Revision: 1.13 $
  13  * $Date: 2000/03/10 20:03:36 $
  14  * ------------------------------------------------------------------------*/
  15
  16 #include "prelude.h"
  17 #include "storage.h"
  18 #include "connect.h"
  19 #include "errors.h"
  20
  21 #include "Assembler.h" /* for AsmRep and primops */
  22
  23 /* --------------------------------------------------------------------------
  24  * Utility functions
  25  * ------------------------------------------------------------------------*/
  26
  27 /* Make an info table for a constructor or tuple. */
  28 void* stgConInfo ( StgDiscr d )
  29 {
  30     int tag;
  31     switch (whatIs(d)) {
  32        case NAME: {
  33           tag = cfunOf(d);
  34           if (tag > 0) tag--;
  35           if (!name(d).itbl)
  36              name(d).itbl = asmMkInfo(tag,name(d).arity);
  37           return name(d).itbl;
  38        }
  39        case TUPLE: {
  40           tag = 0;
  41           if (!tycon(d).itbl)
  42              tycon(d).itbl = asmMkInfo(tag,tupleOf(d));
  43           return tycon(d).itbl;
  44        }
  45        default:
  46           internal("stgConInfo");
  47     }
  48 }
  49
  50 /* Return the tag for a constructor or tuple, starting at zero. */
  51 int stgDiscrTag ( StgDiscr d )
  52 {
  53     int tag;
  54     switch (whatIs(d)) {
  55        case NAME:  tag = cfunOf(d); break;
  56        case TUPLE: tag = 0;
  57        default:    internal("stgDiscrTag");
  58     }
  59     if (tag > 0) tag--;
  60     return tag;
  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     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  * STG pretty printer
 155  * ------------------------------------------------------------------------*/
 156
 157 /* --------------------------------------------------------------------------
 158  * Local functions
 159  * ------------------------------------------------------------------------*/
 160
 161 static Void local pIndent        Args((Int));
 162
 163 static Void local putStgVar       Args((StgVar));
 164 static Void local putStgVars      Args((List));
 165 static Void local putStgAtom      Args((StgAtom a));
 166 static Void local putStgAtoms     Args((List as));
 167 static Void local putStgBinds     Args((List));
 168 static Void local putStgExpr      Args((StgExpr));
 169 static Void local putStgRhs       Args((StgRhs));
 170 static Void local putStgPat       Args((StgCaseAlt));
 171 static Void local putStgPrimPat   Args((StgPrimAlt));
 172
 173
 174
 175 /* --------------------------------------------------------------------------
 176  * Indentation and showing names/constants
 177  * ------------------------------------------------------------------------*/
 178
 179 static Void local pIndent(n)           /* indent to particular position    */
 180 Int n; {
 181     outColumn = n;
 182     while (0<n--) {
 183         Putc(' ',outputStream);
 184     }
 185 }
 186
 187
 188 /* --------------------------------------------------------------------------
 189  * Pretty printer for stg code:
 190  * ------------------------------------------------------------------------*/
 191
 192 static Void putStgAlts    ( Int left, List alts );
 193
 194 static Void local putStgVar(StgVar v)
 195 {
 196     if (isName(v)) {
 197         unlexVar(name(v).text);
 198     } else {
 199         putStr("id");
 200         putInt(-v);
 201         putStr("<");
 202         putChr(charOf(stgVarRep(v)));
 203         putStr(">");
 204         if (isInt(stgVarInfo(v))) {
 205            putStr("(");
 206            putInt(intOf(stgVarInfo(v)));
 207            putStr(")");
 208         }
 209     }
 210 }
 211
 212 static Void local putStgVars( List vs )
 213 {
 214     for(; nonNull(vs); vs=tl(vs)) {
 215         putStgVar(hd(vs));
 216         putChr(' ');
 217     }
 218 }
 219
 220 static Void local putStgAtom( StgAtom a )
 221 {
 222     switch (whatIs(a)) {
 223     case STGVAR:
 224     case NAME:
 225             putStgVar(a);
 226             break;
 227     case CHARCELL:
 228             unlexCharConst(charOf(a));
 229             putChr('#');
 230             break;
 231     case INTCELL:
 232             putInt(intOf(a));
 233             putChr('#');
 234             break;
 235     case BIGCELL:
 236             putStr(bignumToString(a));
 237             putChr('#');
 238             break;
 239     case FLOATCELL:
 240             putStr(floatToString(a));
 241             putChr('#');
 242             break;
 243     case STRCELL:
 244             unlexStrConst(textOf(a));
 245             break;
 246     case PTRCELL:
 247             putPtr(ptrOf(a));
 248             putChr('#');
 249             break;
 250     case LETREC: case LAMBDA: case CASE: case PRIMCASE:
 251     case STGAPP: case STGPRIM: case STGCON:
 252             putStgExpr(a);
 253             break;
 254     default:
 255             fprintf(stderr,"\nYoiks: "); printExp(stderr,a);
 256             internal("putStgAtom");
 257     }
 258 }
 259
 260 Void putStgAtoms( List as )
 261 {
 262     putChr('{');
 263     while (nonNull(as)) {
 264         putStgAtom(hd(as));
 265         as=tl(as);
 266         if (nonNull(as)) {
 267             putChr(',');
 268         }
 269     }
 270     putChr('}');
 271 }
 272
 273 Void putStgPat( StgCaseAlt alt )
 274 {
 275    if (whatIs(alt)==DEEFALT) {
 276       putStgVar(stgDefaultVar(alt));
 277    }
 278    else
 279    if (whatIs(alt)==CASEALT) {
 280       List vs = stgCaseAltVars(alt);
 281       if (whatIs(stgCaseAltCon(alt))==TUPLE) {
 282          putChr('(');
 283          putStgVar(hd(vs));
 284          vs=tl(vs);
 285          while (nonNull(vs)) {
 286             putChr(',');
 287             putStgVar(hd(vs));
 288             vs=tl(vs);
 289          }
 290          putChr(')');
 291        }
 292        else
 293        if (whatIs(stgCaseAltCon(alt))==NAME) {
 294           unlexVar(name(stgCaseAltCon(alt)).text);
 295           for (; nonNull(vs); vs=tl(vs)) {
 296              putChr(' ');
 297              putStgVar(hd(vs));
 298           }
 299        }
 300        else
 301           internal("putStgPat(2)");
 302    }
 303    else
 304       internal("putStgPat(1)");
 305 }
 306
 307 Void putStgPrimPat( StgVar v )
 308 {
 309     if (nonNull(stgVarBody(v))) {
 310         StgExpr d  = stgVarBody(v);
 311         switch (whatIs(d)) {
 312         case INTCELL:
 313             {
 314                 putInt(intOf(d));
 315                 putChr('#');
 316                 break;
 317             }
 318         default:
 319                 fprintf(stderr,"\nYoiks: "); printExp(stderr,d);
 320                 internal("putStgPrimPat");
 321         }
 322     } else {
 323        putStgVar(v);
 324     }
 325     putChr(' ');
 326 }
 327
 328 Void putStgBinds(binds)        /* pretty print locals           */
 329 List binds; {
 330     Int left = outColumn;
 331
 332     putStr("let { ");
 333     while (nonNull(binds)) {
 334         Cell bind = hd(binds);
 335         putStgVar(bind);
 336         putStr(" = ");
 337         putStgRhs(stgVarBody(bind));
 338         putStr("\n");
 339         binds = tl(binds);
 340         if (nonNull(binds))
 341             pIndent(left+6);
 342     }
 343     pIndent(left);
 344     putStr("} in  ");
 345 }
 346
 347 static Void putStgAlts( Int left, List alts )
 348 {
 349   if (length(alts) == 1) {
 350         StgCaseAlt alt = hd(alts);
 351         putStr("{ ");
 352         putStgPat(alt);
 353         putStr(" ->\n");
 354         pIndent(left);
 355         if (isDefaultAlt(alt))
 356            putStgExpr(stgDefaultBody(alt)); else
 357            putStgExpr(stgCaseAltBody(alt));
 358         putStr("}");
 359     } else {
 360         putStr("{\n");
 361         for (; nonNull(alts); alts=tl(alts)) {
 362             StgCaseAlt alt = hd(alts);
 363             pIndent(left+2);
 364             putStgPat(alt);
 365
 366             putStr(" ->\n");
 367             pIndent(left+4);
 368
 369             if (isDefaultAlt(alt))
 370                putStgExpr(stgDefaultBody(alt)); else
 371                putStgExpr(stgCaseAltBody(alt));
 372
 373             putStr("\n");
 374         }
 375         pIndent(left);
 376         putStr("}\n");
 377     }
 378 }
 379
 380 static Void putStgPrimAlts( Int left, List alts )
 381 {
 382     if (length(alts) == 1) {
 383         StgPrimAlt alt = hd(alts);
 384         putStr("{ ");
 385         mapProc(putStgPrimPat,stgPrimAltVars(alt));
 386         putStr(" ->\n");
 387         pIndent(left);
 388         putStgExpr(stgPrimAltBody(alt));
 389         putStr("}");
 390     } else {
 391         putStr("{\n");
 392         for (; nonNull(alts); alts=tl(alts)) {
 393             StgPrimAlt alt = hd(alts);
 394             pIndent(left+2);
 395             mapProc(putStgPrimPat,stgPrimAltVars(alt));
 396             putStr(" -> ");
 397             putStgExpr(stgPrimAltBody(alt));
 398             putStr("\n");
 399         }
 400         pIndent(left);
 401         putStr("}\n");
 402     }
 403 }
 404
 405 Void putStgExpr( StgExpr e )                        /* pretty print expr */
 406 {
 407     if (isNull(e)) putStr("(putStgExpr:NIL)");else
 408
 409     switch (whatIs(e)) {
 410     case LETREC:
 411         {
 412             Int left = outColumn;
 413             putStgBinds(stgLetBinds(e));
 414             if (whatIs(stgLetBody(e))==LETREC) {
 415                putStr("\n"); pIndent(left);
 416             } else
 417             if (whatIs(stgLetBody(e))==CASE) {
 418                putStr("\n"); pIndent(left+2);
 419             }
 420             putStgExpr(stgLetBody(e));
 421             break;
 422         }
 423     case LAMBDA:
 424         {
 425             Int left = outColumn;
 426             putStr("\\ ");
 427             putStgVars(stgLambdaArgs(e));
 428             putStr("->\n");
 429             pIndent(left+2);
 430             putStgExpr(stgLambdaBody(e));
 431             break;
 432         }
 433     case CASE:
 434         {
 435             Int left = outColumn;
 436             putStr("case ");
 437             putStgExpr(stgCaseScrut(e));
 438             putStr(" of ");
 439             putStgAlts(left,stgCaseAlts(e));
 440             break;
 441         }
 442     case DEEFALT:
 443     case CASEALT:
 444             /* a hack; not for regular use */
 445             putStgAlts(outColumn,singleton(e));
 446             break;
 447     case PRIMALT:
 448             /* a hack; not for regular use */
 449             putStgPrimAlts(outColumn,singleton(e));
 450             break;
 451     case PRIMCASE:
 452         {
 453             Int  left = outColumn;
 454             putStr("case# ");
 455             putStgExpr(stgPrimCaseScrut(e));
 456             putStr(" of ");
 457             putStgPrimAlts(left,stgPrimCaseAlts(e));
 458             break;
 459         }
 460     case STGPRIM:
 461         {
 462             Cell op = stgPrimOp(e);
 463             unlexVarStr(asmGetPrimopName(name(op).primop));
 464             putStgAtoms(stgPrimArgs(e));
 465             break;
 466         }
 467     case STGAPP:
 468             putStgExpr(stgAppFun(e));
 469             putStgAtoms(stgAppArgs(e));
 470             break;
 471     case STGCON:
 472             putStgRhs(e);
 473             break;
 474     case STGVAR:
 475     case NAME:
 476             putStgVar(e);
 477             break;
 478     case CHARCELL:
 479     case INTCELL:
 480     case BIGCELL:
 481     case FLOATCELL:
 482     case STRCELL:
 483     case PTRCELL:
 484             putStgAtom(e);
 485             break;
 486     case AP:
 487             /* hope that it's really a list of StgExprs, so map putStgExpr
 488                over it */
 489             for (;nonNull(e);e=tl(e)) {
 490                putStgExpr(hd(e));
 491                putStr("\n");
 492             }
 493             break;
 494     default:
 495             internal("putStgExpr");
 496             /* Pretend it's a list of algebraic case alternatives.  Used for
 497                printing the case-alt lists attached to BCOs which are return
 498                continuations.  Very useful for debugging.  An appalling hack tho.
 499             */
 500             /* fprintf(stderr, "   "); putStgAlts(3,e); */
 501     }
 502 }
 503
 504 Void putStgRhs( StgRhs e )            /* print lifted definition         */
 505 {
 506     switch (whatIs(e)) {
 507     case STGCON:
 508         {
 509             Name   con  = stgConCon(e);
 510             if (isTuple(con)) {
 511                 putStr("Tuple");
 512                 putInt(tupleOf(con));
 513             } else {
 514                 unlexVar(name(con).text);
 515             }
 516             putStgAtoms(stgConArgs(e));
 517             break;
 518         }
 519     default:
 520             putStgExpr(e);
 521             break;
 522     }
 523 }
 524
 525 static void beginStgPP( FILE* fp );
 526 static void endStgPP( FILE* fp );
 527
 528 static void beginStgPP( FILE* fp )
 529 {
 530     outputStream = fp;
 531     outColumn = 0;
 532     fflush(stderr); fflush(stdout);
 533 }
 534
 535 static void endStgPP( FILE* fp )
 536 {
 537     fflush(fp);
 538 }
 539
 540 Void printStg(fp,b)              /* Pretty print sc defn on fp      */
 541 FILE  *fp;
 542 StgVar b;
 543 {
 544     Name   n;
 545     beginStgPP(fp);
 546     n = nameFromStgVar(b);
 547     if (nonNull(n)) {
 548        putStr(textToStr(name(n).text));
 549     } else {
 550        putStgVar(b);
 551     }
 552     putStr(" = ");
 553     putStgRhs(stgVarBody(b));
 554     putStr("\n");
 555     endStgPP(fp);
 556 }
 557
 558 Void ppStg( StgVar v )
 559 {
 560    printStg(stdout,v);
 561 }
 562
 563 Void ppStgExpr( StgExpr e )
 564 {
 565    beginStgPP(stdout);
 566    putStgExpr(e);
 567    endStgPP(stdout);
 568 }
 569
 570 Void ppStgRhs( StgRhs rhs )
 571 {
 572    beginStgPP(stdout);
 573    putStgRhs(rhs);
 574    endStgPP(stdout);
 575 }
 576
 577 Void ppStgAlts( List alts )
 578 {
 579    beginStgPP(stdout);
 580    putStgAlts(0,alts);
 581    endStgPP(stdout);
 582 }
 583
 584 extern Void ppStgPrimAlts( List alts )
 585 {
 586    beginStgPP(stdout);
 587    putStgPrimAlts(0,alts);
 588    endStgPP(stdout);
 589 }
 590
 591 extern Void ppStgVars( List vs )
 592 {
 593    beginStgPP(stdout);
 594    printf("Vars: ");
 595    putStgVars(vs);
 596    printf("\n");
 597    endStgPP(stdout);
 598 }
 599
 600 /*-------------------------------------------------------------------------*/