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