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