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