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