ghc/interpreter/codegen.c

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