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