ghc/interpreter/stg.c

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