ghc/interpreter/codegen.c

   1
   2 /* --------------------------------------------------------------------------
   3  * Code generator
   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: codegen.c,v $
  10  * $Revision: 1.3 $
  11  * $Date: 1999/02/03 17:08:25 $
  12  * ------------------------------------------------------------------------*/
  13
  14 #include "prelude.h"
  15 #include "storage.h"
  16 #include "backend.h"
  17 #include "connect.h"
  18 #include "errors.h"
  19 #include "Assembler.h"
  20 #include "link.h"
  21
  22
  23 /* --------------------------------------------------------------------------
  24  * Local function prototypes:
  25  * ------------------------------------------------------------------------*/
  26
  27 #define getPos(v)     intOf(stgVarInfo(v))
  28 #define setPos(v,sp)  stgVarInfo(v) = mkInt(sp)
  29 #define getObj(v)     ptrOf(stgVarInfo(v))
  30 #define setObj(v,obj) stgVarInfo(v) = mkPtr(obj)
  31
  32 #define repOf(x)      charOf(stgVarRep(x))
  33
  34 static void  cgBind        ( AsmBCO bco, StgVar v );
  35 static Void  pushVar       ( AsmBCO bco, StgVar v );
  36 static Void  pushAtom      ( AsmBCO bco, StgAtom atom );
  37 static Void  alloc         ( AsmBCO bco, StgRhs rhs );
  38 static Void  build         ( AsmBCO bco, StgRhs rhs );
  39 static Void  cgExpr        ( AsmBCO bco, AsmSp root, StgExpr e );
  40
  41 static AsmBCO cgAlts       ( AsmSp root, AsmSp sp, List alts );
  42 static void   testPrimPats ( AsmBCO bco, AsmSp root, List pats, StgExpr e );
  43 static void   cgPrimAlt    ( AsmBCO bco, AsmSp root, List vs, StgExpr e );
  44 static AsmBCO cgLambda     ( StgExpr e );
  45 static AsmBCO cgRhs        ( StgRhs rhs );
  46 static void   beginTop     ( StgVar v );
  47 static void   endTop       ( StgVar v );
  48
  49 /* --------------------------------------------------------------------------
  50  *
  51  * ------------------------------------------------------------------------*/
  52
  53 static Bool varHasClosure( StgVar v )
  54 {
  55     return asmObjectHasClosure((AsmClosure*)ptrOf(stgVarInfo(v)));
  56 }
  57
  58 /* should be AsmClosure* */
  59 void* closureOfVar( StgVar v )
  60 {
  61     return asmClosureOfObject((AsmClosure*)ptrOf(stgVarInfo(v)));
  62 }
  63
  64 char* lookupHugsName( void* closure )
  65 {
  66     extern Name nameHw;
  67     Name nm;
  68     for( nm=NAMEMIN; nm<nameHw; ++nm ) {
  69         StgVar v  = name(nm).stgVar;
  70         if (isStgVar(v)
  71             && isPtr(stgVarInfo(v))
  72             && varHasClosure(v)
  73             && closureOfVar(v) == closure) {
  74             return textToStr(name(nm).text);
  75         }
  76     }
  77     return 0;
  78 }
  79
  80 /* called at the start of GC */
  81 void markHugsObjects( void )
  82 {
  83     extern Name nameHw;
  84     Name nm;
  85     for( nm=NAMEMIN; nm<nameHw; ++nm ) {
  86         StgVar v  = name(nm).stgVar;
  87         if (isStgVar(v) && isPtr(stgVarInfo(v))) {
  88             asmMarkObject((AsmClosure*)ptrOf(stgVarInfo(v)));
  89         }
  90     }
  91 }
  92
  93 static void cgBindRep( AsmBCO bco, StgVar v, AsmRep rep )
  94 {
  95     setPos(v,asmBind(bco,rep));
  96 }
  97
  98 static void cgBind( AsmBCO bco, StgVar v )
  99 {
 100     cgBindRep(bco,v,repOf(v));
 101 }
 102
 103 static Void pushVar( AsmBCO bco, StgVar v )
 104 {
 105     Cell info = stgVarInfo(v);
 106     assert(isStgVar(v));
 107     if (isPtr(info)) {
 108         asmClosure(bco,ptrOf(info));
 109     } else if (isInt(info)) {
 110         asmVar(bco,intOf(info),repOf(v));
 111     } else {
 112         internal("pushVar");
 113     }
 114 }
 115
 116 static Void pushAtom( AsmBCO bco, StgAtom e )
 117 {
 118     switch (whatIs(e)) {
 119     case STGVAR:
 120             pushVar(bco,e);
 121             break;
 122     case NAME:
 123             pushVar(bco,name(e).stgVar);
 124             break;
 125     case CHARCELL:
 126             asmConstChar(bco,charOf(e));
 127             break;
 128     case INTCELL:
 129             asmConstInt(bco,intOf(e));
 130             break;
 131 #if BIGNUM_IS_INTEGER
 132     case BIGCELL:
 133             asmConstInteger(bco,bignumToString(e));
 134             break;
 135 #elif BIGNUM_IS_INT64
 136     case BIGCELL:
 137             asmConstInt64(bco,bignumOf(e));
 138             break;
 139 #else
 140 #warning What is BIGNUM?
 141 #endif
 142     case FLOATCELL:
 143 #if 0
 144             asmConstFloat(bco,e); /* ToDo: support both float and double! */
 145 #else
 146             asmConstDouble(bco,floatOf(e));
 147 #endif
 148             break;
 149 #if DOUBLES
 150     case DOUBLECELL:
 151             asmConstDouble(bco,doubleOf(e));
 152             break;
 153 #endif
 154     case STRCELL:
 155 #if USE_ADDR_FOR_STRINGS
 156             asmConstAddr(bco,textToStr(textOf(e)));
 157 #else
 158             asmClosure(bco,asmStringObj(textToStr(textOf(e))));
 159 #endif
 160             break;
 161     case PTRCELL:
 162             asmConstAddr(bco,ptrOf(e));
 163             break;
 164     default:
 165             fprintf(stderr,"\nYoiks: "); printExp(stderr,e);
 166             internal("pushAtom");
 167     }
 168 }
 169
 170 static AsmBCO cgAlts( AsmSp root, AsmSp sp, List alts )
 171 {
 172     AsmBCO bco = asmBeginContinuation(sp);
 173     /* ppStgAlts(alts); */
 174     for(; nonNull(alts); alts=tl(alts)) {
 175         StgCaseAlt alt  = hd(alts);
 176         StgPat     pat  = stgCaseAltPat(alt);
 177         StgExpr    body = stgCaseAltBody(alt);
 178         if (isDefaultPat(pat)) {
 179             AsmSp      begin = asmBeginAlt(bco);
 180             cgBind(bco,pat);
 181             cgExpr(bco,root,body);
 182             asmEndContinuation(bco);
 183             return bco; /* ignore any further alternatives */
 184         } else {
 185             StgDiscr con = stgPatDiscr(pat);
 186             List     vs  = stgPatVars(pat);
 187             AsmSp    begin = asmBeginAlt(bco);
 188             AsmPc    fix = asmTest(bco,stgDiscrTag(con)); /* ToDo: omit in single constructor types! */
 189             cgBind(bco,pat);
 190             if (isBoxingCon(con)) {
 191                 setPos(hd(vs),asmUnbox(bco,boxingConRep(con)));
 192             } else {
 193                 asmBeginUnpack(bco);
 194                 map1Proc(cgBind,bco,rev(vs));
 195                 asmEndUnpack(bco);
 196             }
 197             cgExpr(bco,root,body);
 198             asmEndAlt(bco,begin);
 199             asmFixBranch(bco,fix);
 200         }
 201     }
 202     /* if we got this far and didn't match, panic! */
 203     asmPanic(bco);
 204     asmEndContinuation(bco);
 205     return bco;
 206 }
 207
 208 static void testPrimPats( AsmBCO bco, AsmSp root, List pats, StgExpr e )
 209 {
 210     if (isNull(pats)) {
 211         cgExpr(bco,root,e);
 212     } else {
 213         StgPrimPat pat = hd(pats);
 214         if (isInt(stgVarBody(pat))) {
 215             /* asmTestInt leaves stack unchanged - so no need to adjust it */
 216             AsmPc tst = asmTestInt(bco,getPos(pat),intOf(stgVarBody(pat)));
 217             assert(repOf(pat) == INT_REP);
 218             testPrimPats(bco,root,tl(pats),e);
 219             asmFixBranch(bco,tst);
 220         } else {
 221             testPrimPats(bco,root,tl(pats),e);
 222         }
 223     }
 224 }
 225
 226 static void cgPrimAlt( AsmBCO bco, AsmSp root, List vs, StgExpr e )
 227 {
 228     assert(0); /* ToDo: test for patterns */
 229     map1Proc(cgBind,bco,vs); /* ToDo: are these in right order? */
 230     cgExpr(bco,root,e);
 231 }
 232
 233 static AsmBCO cgLambda( StgExpr e )
 234 {
 235     AsmBCO bco = asmBeginBCO();
 236
 237     AsmSp root = asmBeginArgCheck(bco);
 238     map1Proc(cgBind,bco,rev(stgLambdaArgs(e)));
 239     asmEndArgCheck(bco,root);
 240
 241     /* ppStgExpr(e); */
 242     cgExpr(bco,root,stgLambdaBody(e));
 243
 244     asmEndBCO(bco);
 245     return bco;
 246 }
 247
 248 static AsmBCO cgRhs( StgRhs rhs )
 249 {
 250     AsmBCO bco = asmBeginBCO( );
 251
 252     AsmSp root = asmBeginArgCheck(bco);
 253     asmEndArgCheck(bco,root);
 254
 255     /* ppStgExpr(rhs); */
 256     cgExpr(bco,root,rhs);
 257
 258     asmEndBCO(bco);
 259     return bco;
 260 }
 261
 262 static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e )
 263 {
 264     switch (whatIs(e)) {
 265     case LETREC:
 266         {
 267             List binds = stgLetBinds(e);
 268             map1Proc(alloc,bco,binds);
 269             map1Proc(build,bco,binds);
 270             cgExpr(bco,root,stgLetBody(e));
 271             break;
 272         }
 273     case LAMBDA:
 274         {
 275             AsmSp begin = asmBeginEnter(bco);
 276             asmClosure(bco,cgLambda(e));
 277             asmEndEnter(bco,begin,root);
 278             break;
 279         }
 280     case CASE:
 281         {
 282             List  alts     = stgCaseAlts(e);
 283             AsmSp sp       = asmBeginCase(bco);
 284             AsmSp caseroot = asmContinuation(bco,cgAlts(root,sp,alts));
 285             cgExpr(bco,caseroot,stgCaseScrut(e));
 286             asmEndCase(bco);
 287             break;
 288         }
 289     case PRIMCASE:
 290         {
 291             StgExpr scrut = stgPrimCaseScrut(e);
 292             List alts = stgPrimCaseAlts(e);
 293             if (whatIs(scrut) == STGPRIM) {  /* this is an optimisation */
 294
 295                 /* No need to use return address or to Slide */
 296                 AsmSp beginPrim = asmBeginPrim(bco);
 297                 map1Proc(pushAtom,bco,rev(stgPrimArgs(scrut)));
 298                 asmEndPrim(bco,(AsmPrim*)name(stgPrimOp(scrut)).primop,beginPrim);
 299
 300                 for(; nonNull(alts); alts=tl(alts)) {
 301                     StgPrimAlt alt = hd(alts);
 302                     List    pats = stgPrimAltPats(alt);
 303                     StgExpr body = stgPrimAltBody(alt);
 304                     AsmSp altBegin = asmBeginAlt(bco);
 305                     map1Proc(cgBind,bco,rev(pats));
 306                     testPrimPats(bco,root,pats,body);
 307                     asmEndAlt(bco,altBegin);
 308                 }
 309                 /* if we got this far and didn't match, panic! */
 310                 asmPanic(bco);
 311
 312             } else if (whatIs(scrut) == STGVAR) { /* another optimisation */
 313
 314                 /* No need to use return address or to Slide */
 315
 316                 /* only part different from primop code... todo */
 317                 AsmSp beginCase = asmBeginCase(bco);
 318                 pushVar(bco,scrut);
 319                 asmEndAlt(bco,beginCase); /* hack, hack -  */
 320
 321                 for(; nonNull(alts); alts=tl(alts)) {
 322                     StgPrimAlt alt = hd(alts);
 323                     List    pats = stgPrimAltPats(alt);
 324                     StgExpr body = stgPrimAltBody(alt);
 325                     AsmSp altBegin = asmBeginAlt(bco);
 326                     map1Proc(cgBind,bco,pats);
 327                     testPrimPats(bco,root,pats,body);
 328                     asmEndAlt(bco,altBegin);
 329                 }
 330                 /* if we got this far and didn't match, panic! */
 331                 asmPanic(bco);
 332
 333             } else {
 334                 /* ToDo: implement this code...  */
 335                 assert(0);
 336                 /* asmPushRet(bco,delayPrimAlt( stgPrimCaseVars(e), stgPrimCaseBody(e))); */
 337                 /* cgExpr( bco,root,scrut ); */
 338             }
 339             break;
 340         }
 341     case STGAPP: /* Tail call */
 342         {
 343             AsmSp env = asmBeginEnter(bco);
 344             map1Proc(pushAtom,bco,rev(stgAppArgs(e)));
 345             pushAtom(bco,stgAppFun(e));
 346             asmEndEnter(bco,env,root);
 347             break;
 348         }
 349     case NAME: /* Tail call (with no args) */
 350         {
 351             AsmSp env = asmBeginEnter(bco);
 352             pushVar(bco,name(e).stgVar);
 353             asmEndEnter(bco,env,root);
 354             break;
 355         }
 356     case STGVAR: /* Tail call (with no args), plus unboxed return */
 357             switch (repOf(e)) {
 358             case PTR_REP:
 359             case ALPHA_REP:
 360             case BETA_REP:
 361                 {
 362                     AsmSp env = asmBeginEnter(bco);
 363                     pushVar(bco,e);
 364                     asmEndEnter(bco,env,root);
 365                     break;
 366                 }
 367             case INT_REP:
 368                     assert(0);
 369                     /* cgTailCall(bco,singleton(e)); */
 370                     /* asmReturnInt(bco); */
 371                     break;
 372             default:
 373                     internal("cgExpr StgVar");
 374             }
 375             break;
 376     case STGPRIM: /* Tail call again */
 377         {
 378             AsmSp beginPrim = asmBeginPrim(bco);
 379             map1Proc(pushAtom,bco,rev(stgPrimArgs(e)));
 380             asmEndPrim(bco,(AsmPrim*)name(e).primop,beginPrim);
 381             /* map1Proc(cgBind,bco,rs_vars); */
 382             assert(0); /* asmReturn_retty(); */
 383             break;
 384         }
 385     default:
 386             fprintf(stderr,"\nYoiks: "); printExp(stderr,e);
 387             internal("cgExpr");
 388     }
 389 }
 390
 391 /* allocate space for top level variable
 392  * any change requires a corresponding change in 'build'.
 393  */
 394 static Void alloc( AsmBCO bco, StgVar v )
 395 {
 396     StgRhs rhs = stgVarBody(v);
 397     assert(isStgVar(v));
 398     switch (whatIs(rhs)) {
 399     case STGCON:
 400         {
 401             StgDiscr con  = stgConCon(rhs);
 402             List     args = stgConArgs(rhs);
 403             if (isBoxingCon(con)) {
 404                 pushAtom(bco,hd(args));
 405                 setPos(v,asmBox(bco,boxingConRep(con)));
 406             } else {
 407                 setPos(v,asmAllocCONSTR(bco,stgConInfo(con)));
 408             }
 409             break;
 410         }
 411     case STGAPP:
 412             setPos(v,asmAllocAP(bco,length(stgAppArgs(rhs))));
 413             break;
 414     case LAMBDA: /* optimisation */
 415             setObj(v,cgLambda(rhs));
 416             break;
 417     default:
 418             setPos(v,asmAllocAP(bco,0));
 419             break;
 420     }
 421 }
 422
 423 static Void build( AsmBCO bco, StgVar v )
 424 {
 425     StgRhs rhs = stgVarBody(v);
 426     assert(isStgVar(v));
 427     switch (whatIs(rhs)) {
 428     case STGCON:
 429         {
 430             StgDiscr con  = stgConCon(rhs);
 431             List     args = stgConArgs(rhs);
 432             if (isBoxingCon(con)) {
 433                 doNothing();  /* already done in alloc */
 434             } else {
 435                 AsmSp start = asmBeginPack(bco);
 436                 map1Proc(pushAtom,bco,rev(args));
 437                 asmEndPack(bco,getPos(v),start,stgConInfo(con));
 438             }
 439             return;
 440         }
 441     case STGAPP:
 442         {
 443             StgVar fun  = stgAppFun(rhs);
 444             List   args = stgAppArgs(rhs);
 445             if (isName(fun)) {
 446                 fun = name(fun).stgVar;
 447             }
 448             if (nonNull(stgVarBody(fun))
 449                 && whatIs(stgVarBody(fun)) == LAMBDA
 450                 && length(stgLambdaArgs(stgVarBody(fun))) > length(args)) {
 451                 AsmSp  start = asmBeginMkPAP(bco);
 452                 map1Proc(pushAtom,bco,rev(args));
 453                 pushAtom(bco,fun);
 454                 asmEndMkPAP(bco,getPos(v),start); /* optimisation */
 455             } else {
 456                 AsmSp  start = asmBeginMkAP(bco);
 457                 map1Proc(pushAtom,bco,rev(args));
 458                 pushAtom(bco,fun);
 459                 asmEndMkAP(bco,getPos(v),start);
 460             }
 461             return;
 462         }
 463     case LAMBDA: /* optimisation */
 464             doNothing(); /* already pushed in alloc */
 465             break;
 466
 467     /* These two cases look almost identical to the default but they're really
 468      * special cases of STGAPP.  The essential thing here is that we can't call
 469      * cgRhs(rhs) because that expects the rhs to have no free variables when,
 470      * in fact, the rhs is _always_ a free variable.
 471      *
 472      * ToDo: a simple optimiser would eliminate all examples
 473      * of this except "let x = x in ..."
 474      */
 475     case NAME:
 476             rhs = name(rhs).stgVar;
 477     case STGVAR:
 478         {
 479             AsmSp  start = asmBeginMkAP(bco);
 480             pushAtom(bco,rhs);
 481             asmEndMkAP(bco,getPos(v),start);
 482         }
 483         return;
 484     default:
 485         {
 486             AsmSp start = asmBeginMkAP(bco);   /* make it updateable! */
 487             asmClosure(bco,cgRhs(rhs));
 488             asmEndMkAP(bco,getPos(v),start);
 489             return;
 490         }
 491     }
 492 }
 493
 494 /* --------------------------------------------------------------------------
 495  * Top level variables
 496  *
 497  * ToDo: these should be handled by allocating a dynamic unentered CAF
 498  * for each top level variable - this should be simpler!
 499  * ------------------------------------------------------------------------*/
 500
 501 static void cgAddVar( AsmObject obj, StgAtom v )
 502 {
 503     if (isName(v)) {
 504         v = name(v).stgVar;
 505     }
 506     assert(isStgVar(v));
 507     asmAddPtr(obj,getObj(v));
 508 }
 509
 510 /* allocate AsmObject for top level variables
 511  * any change requires a corresponding change in endTop
 512  */
 513 static void beginTop( StgVar v )
 514 {
 515     StgRhs rhs;
 516     assert(isStgVar(v));
 517     rhs = stgVarBody(v);
 518     switch (whatIs(rhs)) {
 519     case STGCON:
 520         {
 521             List as = stgConArgs(rhs);
 522             setObj(v,asmBeginCon(stgConInfo(stgConCon(rhs))));
 523             break;
 524         }
 525     case LAMBDA:
 526             setObj(v,asmBeginBCO());
 527             break;
 528     default:
 529             setObj(v,asmBeginCAF());
 530             break;
 531     }
 532 }
 533
 534 static void endTop( StgVar v )
 535 {
 536     StgRhs rhs = stgVarBody(v);
 537     ppStgRhs(rhs);
 538     switch (whatIs(rhs)) {
 539     case STGCON:
 540         {
 541             List as = stgConArgs(rhs);
 542             AsmCon con = (AsmCon)getObj(v);
 543             for( ; nonNull(as); as=tl(as)) {
 544                 StgAtom a = hd(as);
 545                 switch (whatIs(a)) {
 546                 case STGVAR:
 547                         /* should be a delayed combinator! */
 548                         asmAddPtr(con,(AsmObject)getObj(a));
 549                         break;
 550                 case NAME:
 551                     {
 552                         StgVar var = name(a).stgVar;
 553                         assert(var);
 554                         asmAddPtr(con,(AsmObject)getObj(a));
 555                         break;
 556                     }
 557 #if !USE_ADDR_FOR_STRINGS
 558                 case STRCELL:
 559                         asmAddPtr(con,asmStringObj(textToStr(textOf(a))));
 560                         break;
 561 #endif
 562                 default:
 563                         /* asmAddPtr(con,??); */
 564                         assert(0);
 565                         break;
 566                 }
 567             }
 568             asmEndCon(con);
 569             break;
 570         }
 571     case LAMBDA: /* optimisation */
 572         {
 573             /* ToDo: merge this code with cgLambda */
 574             AsmBCO bco = (AsmBCO)getObj(v);
 575             AsmSp root = asmBeginArgCheck(bco);
 576             map1Proc(cgBind,bco,rev(stgLambdaArgs(rhs)));
 577             asmEndArgCheck(bco,root);
 578
 579             cgExpr(bco,root,stgLambdaBody(rhs));
 580
 581             asmEndBCO(bco);
 582             break;
 583         }
 584     default:   /* updateable caf */
 585         {
 586             AsmCAF caf = (AsmCAF)getObj(v);
 587             asmEndCAF(caf,cgRhs(rhs));
 588             break;
 589         }
 590     }
 591 }
 592
 593 static void zap( StgVar v )
 594 {
 595     stgVarBody(v) = NIL;
 596 }
 597
 598 /* external entry point */
 599 Void cgBinds( List binds )
 600 {
 601     binds = liftBinds(binds);
 602     mapProc(beginTop,binds);
 603     mapProc(endTop,binds);
 604     mapProc(zap,binds);
 605 }
 606
 607 /* --------------------------------------------------------------------------
 608  * Code Generator control:
 609  * ------------------------------------------------------------------------*/
 610
 611 Void codegen(what)
 612 Int what; {
 613     switch (what) {
 614     case INSTALL:
 615             /* deliberate fall though */
 616     case RESET:
 617             break;
 618     case MARK:
 619             break;
 620     }
 621     liftControl(what);
 622 }
 623
 624 /*-------------------------------------------------------------------------*/