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