ghc/interpreter/codegen.c

   1
   2 /* --------------------------------------------------------------------------
   3  * Code generator
   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: codegen.c,v $
  12  * $Revision: 1.25 $
  13  * $Date: 2000/05/10 16:53:35 $
  14  * ------------------------------------------------------------------------*/
  15
  16 #include "hugsbasictypes.h"
  17 #include "storage.h"
  18 #include "connect.h"
  19 #include "errors.h"
  20
  21 #include "Rts.h"       /* to make StgPtr visible in Assembler.h */
  22 #include "Assembler.h"
  23 #include "RtsFlags.h"
  24
  25 /*#define DEBUG_CODEGEN*/
  26
  27 /*  (JRS, 27 Apr 2000):
  28
  29 A total rewrite of the BCO assembler/linker, and rationalisation of
  30 the code management and code generation phases of Hugs.
  31
  32 Problems with the old linker:
  33
  34 * Didn't have a clean way to insert a pointer to GHC code into a BCO.
  35   This meant CAF GC didn't work properly in combined mode.
  36
  37 * Leaked memory.  Each BCO, caf and constructor generated by Hugs had
  38   a corresponding malloc'd record used in its construction.  These
  39   records existed forever.  Pointers from the Hugs symbol tables into
  40   the runtime heap always went via these intermediates, for no apparent
  41   reason.
  42
  43 * A global variable holding a list of top-level stg trees was used
  44   during code generation.  It was hard to associate trees in this
  45   list with entries in the name/tycon tables.  Just too many
  46   mechanisms.
  47
  48 The New World Order is as follows:
  49
  50 * The global code list (stgGlobals) is gone.
  51
  52 * Each name in the name table has a .closure field.  This points
  53   to the top-level code for that name.  Before bytecode generation
  54   this points to a STG tree.  During bytecode generation but before
  55   bytecode linking it is a MPtr pointing to a malloc'd intermediate
  56   structure (an AsmObject).  After linking, it is a real live pointer
  57   into the execution heap (CPtr) which is treated as a root during GC.
  58
  59   Because tuples do not have name table entries, tycons which are
  60   tuples also have a .closure field, which is treated identically
  61   to those of name table entries.
  62
  63 * Each module has a code list -- a list of names and tuples.  If you
  64   are a name or tuple and you have something (code, CAF or Con) which
  65   needs to wind up in the execution heap, you MUST be on your module's
  66   code list.  Otherwise you won't get code generated.
  67
  68 * Lambda lifting generates new name table entries, which of course
  69   also wind up on the code list.
  70
  71 * The initial phase of code generation for a module m traverses m's
  72   code list.  The stg trees referenced in the .closure fields are
  73   code generated, creating AsmObject (AsmBCO, AsmCAF, AsmCon) in
  74   mallocville.  The .closure fields then point to these AsmObjects.
  75   Since AsmObjects can be mutually recursive, they can contain
  76   references to:
  77      * Other AsmObjects            Asm_RefObject
  78      * Existing closures           Asm_RefNoOp
  79      * name/tycon table entries    Asm_RefHugs
  80   AsmObjects can also contain BCO insns and non-ptr words.
  81
  82 * A second copy-and-link phase copies the AsmObjects into the
  83   execution heap, resolves the Asm_Ref* items, and frees up
  84   the malloc'd entities.
  85
  86 * Minor cleanups in compile-time storage.  There are now 3 kinds of
  87   address-y things available:
  88      CPtr/mkCPtr/cptrOf    -- ptrs to Closures, probably in exec heap
  89                               ie anything which the exec GC knows about
  90      MPtr/mkMPtr/mptrOf    -- ptrs to mallocville, which the exec GC
  91                               knows nothing about
  92      Addr/mkAddr/addrOf    -- literal addresses (like literal ints)
  93
  94 * Many hacky cases removed from codegen.c.  Referencing code or
  95   data during code generation is a lot simpler, since an entity
  96   is either:
  97       a CPtr, in which case use it as is
  98       a MPtr -- stuff it into the AsmObject and the linker will fix it
  99       a name or tycon
 100              -- ditto
 101
 102 * I've checked, using Purify that, at least in standalone mode,
 103   no longer leaks mallocd memory.  Prior to this it would leak at
 104   the rate of about 300k per Prelude.
 105
 106 Still to do:
 107
 108 * Reinstate peephole optimisation for BCOs.
 109
 110 * Nuke magic number headers in AsmObjects, used for debugging.
 111
 112 * Profile and accelerate.  Code generation is slower because linking
 113   is slower.  Evaluation GC is slower because markHugsObjects has
 114   slowed down.
 115
 116 * Make setCurrentModule ignore name table entries created by the
 117   lambda-lifter.
 118 */
 119
 120
 121 /* --------------------------------------------------------------------------
 122  * Local function prototypes:
 123  * ------------------------------------------------------------------------*/
 124
 125 #define getPos(v)     intOf(stgVarInfo(v))
 126 #define setPos(v,sp)  stgVarInfo(v) = mkInt(sp)
 127 #define getObj(v)     mptrOf(stgVarInfo(v))
 128 #define setObj(v,obj) stgVarInfo(v) = mkMPtr(obj)
 129
 130 #define repOf(x)      charOf(stgVarRep(x))
 131
 132 static void      cgBind       ( AsmBCO bco, StgVar v );
 133 static Void      pushAtom     ( AsmBCO bco, StgAtom atom );
 134 static Void      alloc        ( AsmBCO bco, StgRhs rhs );
 135 static Void      build        ( AsmBCO bco, StgRhs rhs );
 136 static Void      cgExpr       ( AsmBCO bco, AsmSp root, StgExpr e );
 137
 138 static AsmBCO    cgAlts       ( AsmSp root, AsmSp sp, List alts );
 139 static void      testPrimPats ( AsmBCO bco, AsmSp root, List pats, StgExpr e );
 140 static AsmBCO    cgLambda     ( StgExpr e );
 141 static AsmBCO    cgRhs        ( StgRhs rhs );
 142 static void      beginTop     ( StgVar v );
 143 static AsmObject endTop       ( StgVar v );
 144
 145 static StgVar currentTop;
 146
 147 /* --------------------------------------------------------------------------
 148  *
 149  * ------------------------------------------------------------------------*/
 150
 151 static void* /* StgClosure*/ cptrFromName ( Name n )
 152 {
 153    char  buf[1000];
 154    void* p;
 155    Module m = name(n).mod;
 156    Text  mt = module(m).text;
 157    sprintf(buf, MAYBE_LEADING_UNDERSCORE_STR("%s_%s_closure"),
 158                 textToStr(mt),
 159                 textToStr( enZcodeThenFindText (
 160                    textToStr (name(n).text) ) ) );
 161    p = lookupOTabName ( m, buf );
 162    if (!p) {
 163       ERRMSG(0) "Can't find object symbol %s", buf
 164       EEND;
 165    }
 166    return p;
 167 }
 168
 169 char* lookupHugsName( void* closure )
 170 {
 171     extern Name nameHw;
 172     Name nm;
 173     for( nm = NAME_BASE_ADDR;
 174          nm < NAME_BASE_ADDR+tabNameSz; ++nm )
 175        if (tabName[nm-NAME_BASE_ADDR].inUse) {
 176            Cell cl = name(nm).closure;
 177            if (isCPtr(cl) && cptrOf(cl) == closure)
 178                return textToStr(name(nm).text);
 179     }
 180     return NULL;
 181 }
 182
 183 static void cgBindRep( AsmBCO bco, StgVar v, AsmRep rep )
 184 {
 185     setPos(v,asmBind(bco,rep));
 186 }
 187
 188 static void cgBind( AsmBCO bco, StgVar v )
 189 {
 190     cgBindRep(bco,v,repOf(v));
 191 }
 192
 193 static void cgAddPtrToObject ( AsmObject obj, Cell ptrish )
 194 {
 195    switch (whatIs(ptrish)) {
 196       case CPTRCELL:
 197          asmAddRefNoOp ( obj, (StgPtr)cptrOf(ptrish) ); break;
 198       case MPTRCELL:
 199          asmAddRefObject ( obj, mptrOf(ptrish) ); break;
 200       default:
 201          internal("cgAddPtrToObject");
 202    }
 203 }
 204
 205 /* Get a pointer to atom e onto the stack. */
 206 static Void pushAtom ( AsmBCO bco, StgAtom e )
 207 {
 208     Cell info;
 209     Cell cl;
 210 #   if 0
 211     printf ( "pushAtom: %d  ", e ); fflush(stdout);
 212     print(e,10);printf("\n");
 213 #   endif
 214     switch (whatIs(e)) {
 215        case STGVAR:
 216            info = stgVarInfo(e);
 217            if (isInt(info)) {
 218               asmVar(bco,intOf(info),repOf(e));
 219            }
 220            else
 221            if (isCPtr(info)) {
 222               asmPushRefNoOp(bco,cptrOf(info));
 223            }
 224            else
 225            if (isMPtr(info)) {
 226               asmPushRefObject(bco,mptrOf(info));
 227            }
 228            else {
 229               internal("pushAtom: STGVAR");
 230            }
 231            break;
 232        case NAME:
 233        case TUPLE:
 234             cl = getNameOrTupleClosure(e);
 235             if (isStgVar(cl)) {
 236                /* a stg tree which hasn't yet been translated */
 237                asmPushRefHugs(bco,e);
 238             }
 239             else
 240             if (isCPtr(cl)) {
 241                /* a pointer to something in the heap */
 242                asmPushRefNoOp(bco,(StgPtr)cptrOf(cl));
 243             }
 244             else
 245             if (isMPtr(cl)) {
 246                /* a pointer to an AsmBCO/AsmCAF/AsmCon object */
 247                asmPushRefObject(bco,mptrOf(cl));
 248             }
 249             else {
 250                StgClosure* addr;
 251                ASSERT(isNull(cl));
 252                addr = cptrFromName(e);
 253 #              if DEBUG_CODEGEN
 254                fprintf ( stderr, "nativeAtom: name %s\n",
 255                                  nameFromOPtr(addr) );
 256 #              endif
 257                asmPushRefNoOp(bco,(StgPtr)addr);
 258             }
 259             break;
 260        case CHARCELL:
 261             asmConstChar(bco,charOf(e));
 262             break;
 263        case INTCELL:
 264             asmConstInt(bco,intOf(e));
 265             break;
 266        case ADDRCELL:
 267             asmConstAddr(bco,addrOf(e));
 268             break;
 269        case BIGCELL:
 270             asmConstInteger(bco,bignumToString(e));
 271             break;
 272        case FLOATCELL:
 273             asmConstDouble(bco,floatOf(e));
 274             break;
 275        case STRCELL:
 276 #           if USE_ADDR_FOR_STRINGS
 277             asmConstAddr(bco,textToStr(textOf(e)));
 278 #           else
 279             asmClosure(bco,asmStringObj(textToStr(textOf(e))));
 280 #           endif
 281             break;
 282        case CPTRCELL:
 283             asmPushRefNoOp(bco,cptrOf(e));
 284             break;
 285        case MPTRCELL:
 286             asmPushRefObject(bco,mptrOf(e));
 287             break;
 288        default:
 289             fprintf(stderr,"\nYoiks1: "); printExp(stderr,e);
 290             internal("pushAtom");
 291     }
 292 }
 293
 294 static AsmBCO cgAlts( AsmSp root, AsmSp sp, List alts )
 295 {
 296     AsmBCO bco = asmBeginContinuation(sp, alts);
 297     Bool omit_test
 298        = length(alts) == 2 &&
 299          isDefaultAlt(hd(tl(alts))) &&
 300          !isDefaultAlt(hd(alts));
 301     if (omit_test) {
 302        /* refine the condition */
 303        Name con;
 304        Tycon t;
 305        omit_test = FALSE;
 306        con = stgCaseAltCon(hd(alts));
 307
 308        /* special case: dictionary constructors */
 309        if (isName(con) && strncmp(":D",textToStr(name(con).text),2)==0) {
 310           omit_test = TRUE;
 311           goto xyzzy;
 312        }
 313        /* special case: Tuples */
 314        if (isTuple(con) || (isName(con) && con==nameUnit)) {
 315           omit_test = TRUE;
 316           goto xyzzy;
 317        }
 318
 319        t = name(con).parent;
 320        if (tycon(t).what == DATATYPE) {
 321           if (length(tycon(t).defn) == 1) omit_test = TRUE;
 322        }
 323     }
 324
 325     xyzzy:
 326
 327     for(; nonNull(alts); alts=tl(alts)) {
 328         StgCaseAlt alt  = hd(alts);
 329         if (isDefaultAlt(alt)) {
 330             cgBind(bco,stgDefaultVar(alt));
 331             cgExpr(bco,root,stgDefaultBody(alt));
 332             asmEndContinuation(bco);
 333             return bco; /* ignore any further alternatives */
 334         } else {
 335             StgDiscr con   = stgCaseAltCon(alt);
 336             List     vs    = stgCaseAltVars(alt);
 337             AsmSp    begin = asmBeginAlt(bco);
 338             AsmPc    fix;
 339             if (omit_test) fix=-1; else fix = asmTest(bco,stgDiscrTag(con));
 340
 341             asmBind(bco,PTR_REP); /* Adjust simulated sp to acct for return value */
 342             if (isBoxingCon(con)) {
 343                 setPos(hd(vs),asmUnbox(bco,boxingConRep(con)));
 344             } else {
 345                 asmBeginUnpack(bco);
 346                 map1Proc(cgBind,bco,reverse(vs));
 347                 asmEndUnpack(bco);
 348             }
 349             cgExpr(bco,root,stgCaseAltBody(alt));
 350             asmEndAlt(bco,begin);
 351             if (fix != -1) asmFixBranch(bco,fix);
 352         }
 353     }
 354     /* if we got this far and didn't match, panic! */
 355     asmPanic(bco);
 356     asmEndContinuation(bco);
 357     return bco;
 358 }
 359
 360 static void testPrimPats( AsmBCO bco, AsmSp root, List pats, StgExpr e )
 361 {
 362     if (isNull(pats)) {
 363         cgExpr(bco,root,e);
 364     } else {
 365         StgVar pat = hd(pats);
 366         if (isInt(stgVarBody(pat))) {
 367             /* asmTestInt leaves stack unchanged - so no need to adjust it */
 368             AsmPc tst = asmTestInt(bco,getPos(pat),intOf(stgVarBody(pat)));
 369             assert(repOf(pat) == INT_REP);
 370             testPrimPats(bco,root,tl(pats),e);
 371             asmFixBranch(bco,tst);
 372         } else {
 373             testPrimPats(bco,root,tl(pats),e);
 374         }
 375     }
 376 }
 377
 378
 379 static AsmBCO cgLambda( StgExpr e )
 380 {
 381     AsmBCO bco = asmBeginBCO(e);
 382
 383     AsmSp root = asmBeginArgCheck(bco);
 384     map1Proc(cgBind,bco,reverse(stgLambdaArgs(e)));
 385     asmEndArgCheck(bco,root);
 386
 387     /* ppStgExpr(e); */
 388     cgExpr(bco,root,stgLambdaBody(e));
 389
 390     asmEndBCO(bco);
 391     return bco;
 392 }
 393
 394 static AsmBCO cgRhs( StgRhs rhs )
 395 {
 396     AsmBCO bco = asmBeginBCO(rhs );
 397
 398     AsmSp root = asmBeginArgCheck(bco);
 399     asmEndArgCheck(bco,root);
 400
 401     /* ppStgExpr(rhs); */
 402     cgExpr(bco,root,rhs);
 403
 404     asmEndBCO(bco);
 405     return bco;
 406 }
 407
 408
 409 static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e )
 410 {
 411 #if 0
 412     printf("cgExpr:");ppStgExpr(e);printf("\n");
 413 #endif
 414     switch (whatIs(e)) {
 415     case LETREC:
 416         {
 417             List binds = stgLetBinds(e);
 418             map1Proc(alloc,bco,binds);
 419             map1Proc(build,bco,binds);
 420             cgExpr(bco,root,stgLetBody(e));
 421             break;
 422         }
 423     case LAMBDA:
 424         {
 425             AsmSp begin = asmBeginEnter(bco);
 426             asmPushRefObject(bco,cgLambda(e));
 427             asmEndEnter(bco,begin,root);
 428             break;
 429         }
 430     case CASE:
 431         {
 432             List  alts     = stgCaseAlts(e);
 433             AsmSp sp       = asmBeginCase(bco);
 434             AsmSp caseroot = asmContinuation(bco,cgAlts(root,sp,alts));
 435             cgExpr(bco,caseroot,stgCaseScrut(e));
 436             asmEndCase(bco);
 437             break;
 438         }
 439     case PRIMCASE:
 440         {
 441             StgExpr scrut = stgPrimCaseScrut(e);
 442             List alts = stgPrimCaseAlts(e);
 443             if (whatIs(scrut) == STGPRIM) {  /* this is an optimisation */
 444
 445                 /* No need to use return address or to Slide */
 446                 AsmSp beginPrim = asmBeginPrim(bco);
 447                 map1Proc(pushAtom,bco,reverse(stgPrimArgs(scrut)));
 448                 asmEndPrim(bco,(AsmPrim*)name(stgPrimOp(scrut)).primop,beginPrim);
 449
 450                 for(; nonNull(alts); alts=tl(alts)) {
 451                     StgPrimAlt alt = hd(alts);
 452                     List    pats = stgPrimAltVars(alt);
 453                     StgExpr body = stgPrimAltBody(alt);
 454                     AsmSp altBegin = asmBeginAlt(bco);
 455                     map1Proc(cgBind,bco,reverse(pats));
 456                     testPrimPats(bco,root,pats,body);
 457                     asmEndAlt(bco,altBegin);
 458                 }
 459                 /* if we got this far and didn't match, panic! */
 460                 asmPanic(bco);
 461
 462             } else if (whatIs(scrut) == STGVAR) { /* another optimisation */
 463
 464                 /* No need to use return address or to Slide */
 465
 466                 /* only part different from primop code... todo */
 467                 AsmSp beginCase = asmBeginCase(bco);
 468                 pushAtom /*pushVar*/ (bco,scrut);
 469                 asmEndAlt(bco,beginCase); /* hack, hack -  */
 470
 471                 for(; nonNull(alts); alts=tl(alts)) {
 472                     StgPrimAlt alt = hd(alts);
 473                     List    pats = stgPrimAltVars(alt);
 474                     StgExpr body = stgPrimAltBody(alt);
 475                     AsmSp altBegin = asmBeginAlt(bco);
 476                     map1Proc(cgBind,bco,pats);
 477                     testPrimPats(bco,root,pats,body);
 478                     asmEndAlt(bco,altBegin);
 479                 }
 480                 /* if we got this far and didn't match, panic! */
 481                 asmPanic(bco);
 482
 483             } else {
 484                 /* ToDo: implement this code...  */
 485                 assert(0);
 486                 /* asmPushRet(bco,delayPrimAlt( stgPrimCaseVars(e),
 487                                                 stgPrimCaseBody(e))); */
 488                 /* cgExpr( bco,root,scrut ); */
 489             }
 490             break;
 491         }
 492     case STGAPP: /* Tail call */
 493         {
 494             AsmSp env = asmBeginEnter(bco);
 495             map1Proc(pushAtom,bco,reverse(stgAppArgs(e)));
 496             pushAtom(bco,stgAppFun(e));
 497             asmEndEnter(bco,env,root);
 498             break;
 499         }
 500     case TUPLE:
 501     case NAME: /* Tail call (with no args) */
 502         {
 503             AsmSp env = asmBeginEnter(bco);
 504             /* JRS 000112: next line used to be: pushVar(bco,name(e).stgVar); */
 505             pushAtom(bco,e);
 506             asmEndEnter(bco,env,root);
 507             break;
 508         }
 509     case STGVAR: /* Tail call (with no args), plus unboxed return */
 510             switch (repOf(e)) {
 511             case PTR_REP:
 512             case ALPHA_REP:
 513             case BETA_REP:
 514                 {
 515                     AsmSp env = asmBeginEnter(bco);
 516                     pushAtom /*pushVar*/ (bco,e);
 517                     asmEndEnter(bco,env,root);
 518                     break;
 519                 }
 520             case INT_REP:
 521                     assert(0);
 522                     /* cgTailCall(bco,singleton(e)); */
 523                     /* asmReturnInt(bco); */
 524                     break;
 525             default:
 526                     internal("cgExpr StgVar");
 527             }
 528             break;
 529     case STGPRIM: /* Tail call again */
 530         {
 531             AsmSp beginPrim = asmBeginPrim(bco);
 532             map1Proc(pushAtom,bco,reverse(stgPrimArgs(e)));
 533             asmEndPrim(bco,(AsmPrim*)name(e).primop,beginPrim);
 534             /* map1Proc(cgBind,bco,rs_vars); */
 535             assert(0); /* asmReturn_retty(); */
 536             break;
 537         }
 538     default:
 539             fprintf(stderr,"\nYoiks2: "); printExp(stderr,e);
 540             internal("cgExpr");
 541     }
 542 }
 543
 544 /* allocate space for top level variable
 545  * any change requires a corresponding change in 'build'.
 546  */
 547 static Void alloc( AsmBCO bco, StgVar v )
 548 {
 549     StgRhs rhs = stgVarBody(v);
 550     assert(isStgVar(v));
 551 #if 0
 552     printf("alloc: ");ppStgExpr(v);
 553 #endif
 554     switch (whatIs(rhs)) {
 555     case STGCON:
 556         {
 557             StgDiscr con  = stgConCon(rhs);
 558             List     args = stgConArgs(rhs);
 559             if (isBoxingCon(con)) {
 560                 pushAtom(bco,hd(args));
 561                 setPos(v,asmBox(bco,boxingConRep(con)));
 562             } else {
 563                 setPos(v,asmAllocCONSTR(bco,stgConInfo(con)));
 564             }
 565             break;
 566         }
 567     case STGAPP: {
 568             Int  totSizeW = 0;
 569             List bs       = stgAppArgs(rhs);
 570             for (; nonNull(bs); bs=tl(bs)) {
 571                if (isName(hd(bs))) {
 572                   totSizeW += 1;
 573                } else {
 574                   ASSERT(whatIs(hd(bs))==STGVAR);
 575                   totSizeW += asmRepSizeW( charOf(stgVarRep(hd(bs))) );
 576                }
 577             }
 578             setPos(v,asmAllocAP(bco,totSizeW));
 579             break;
 580          }
 581     case LAMBDA: /* optimisation */
 582             setObj(v,cgLambda(rhs));
 583             break;
 584     default:
 585             setPos(v,asmAllocAP(bco,0));
 586             break;
 587     }
 588 }
 589
 590 static Void build( AsmBCO bco, StgVar v )
 591 {
 592     StgRhs rhs = stgVarBody(v);
 593     assert(isStgVar(v));
 594     //ppStg(v);
 595     switch (whatIs(rhs)) {
 596     case STGCON:
 597         {
 598             StgDiscr con  = stgConCon(rhs);
 599             List     args = stgConArgs(rhs);
 600             if (isBoxingCon(con)) {
 601                 doNothing();  /* already done in alloc */
 602             } else {
 603                 AsmSp start = asmBeginPack(bco);
 604                 map1Proc(pushAtom,bco,reverse(args));
 605                 asmEndPack(bco,getPos(v),start,stgConInfo(con));
 606             }
 607             return;
 608         }
 609     case STGAPP:
 610         {
 611             Bool   itsaPAP;
 612             StgVar fun  = stgAppFun(rhs);
 613             List   args = stgAppArgs(rhs);
 614
 615             if (isName(fun)) {
 616                itsaPAP = name(fun).arity > length(args);
 617             } else
 618             if (isStgVar(fun)) {
 619                itsaPAP = FALSE;
 620                if (nonNull(stgVarBody(fun))
 621                    && whatIs(stgVarBody(fun)) == LAMBDA
 622                    && length(stgLambdaArgs(stgVarBody(fun))) > length(args)
 623                   )
 624                   itsaPAP = TRUE;
 625             }
 626             else
 627                internal("build: STGAPP");
 628
 629             if (itsaPAP) {
 630                 AsmSp  start = asmBeginMkPAP(bco);
 631                 map1Proc(pushAtom,bco,reverse(args));
 632                 pushAtom(bco,fun);
 633                 asmEndMkPAP(bco,getPos(v),start); /* optimisation */
 634             } else {
 635                 AsmSp  start = asmBeginMkAP(bco);
 636                 map1Proc(pushAtom,bco,reverse(args));
 637                 pushAtom(bco,fun);
 638                 asmEndMkAP(bco,getPos(v),start);
 639             }
 640             return;
 641         }
 642     case LAMBDA: /* optimisation */
 643             doNothing(); /* already pushed in alloc */
 644             break;
 645
 646     /* These two cases look almost identical to the default but they're really
 647      * special cases of STGAPP.  The essential thing here is that we can't call
 648      * cgRhs(rhs) because that expects the rhs to have no free variables when,
 649      * in fact, the rhs is _always_ a free variable.
 650      *
 651      * ToDo: a simple optimiser would eliminate all examples
 652      * of this except "let x = x in ..."
 653      */
 654     case NAME:
 655     case STGVAR:
 656         {
 657             AsmSp  start = asmBeginMkAP(bco);
 658             pushAtom(bco,rhs);
 659             asmEndMkAP(bco,getPos(v),start);
 660         }
 661         return;
 662     default:
 663         {
 664             AsmSp start = asmBeginMkAP(bco);   /* make it updateable! */
 665             asmPushRefObject(bco,cgRhs(rhs));
 666             asmEndMkAP(bco,getPos(v),start);
 667             return;
 668         }
 669     }
 670 }
 671
 672 /* --------------------------------------------------------------------------
 673  * Top level variables
 674  *
 675  * ToDo: these should be handled by allocating a dynamic unentered CAF
 676  * for each top level variable - this should be simpler!
 677  * ------------------------------------------------------------------------*/
 678
 679 /* allocate AsmObject for top level variables
 680  * any change requires a corresponding change in endTop
 681  */
 682 static void beginTop( StgVar v )
 683 {
 684     StgRhs rhs;
 685     assert(isStgVar(v));
 686     currentTop = v;
 687     rhs = stgVarBody(v);
 688     switch (whatIs(rhs)) {
 689        case STGCON:
 690           setObj(v,asmBeginCon(stgConInfo(stgConCon(rhs))));
 691           break;
 692        case LAMBDA:
 693           setObj(v,asmBeginBCO(rhs));
 694           break;
 695        default:
 696           setObj(v,asmBeginCAF());
 697           break;
 698     }
 699 }
 700
 701 static AsmObject endTop( StgVar v )
 702 {
 703     StgRhs rhs = stgVarBody(v);
 704     currentTop = v;
 705     switch (whatIs(rhs)) {
 706        case STGCON: {
 707           List as = stgConArgs(rhs);
 708           AsmCon con = (AsmCon)getObj(v);
 709           for ( ; nonNull(as); as=tl(as)) {
 710              StgAtom a = hd(as);
 711              switch (whatIs(a)) {
 712                 case STGVAR:
 713                    /* should be a delayed combinator! */
 714                    asmAddRefObject(con,(AsmObject)getObj(a));
 715                    break;
 716                 case NAME: {
 717                    StgVar var = name(a).closure;
 718                    cgAddPtrToObject(con,var);
 719                    break;
 720                 }
 721 #               if !USE_ADDR_FOR_STRINGS
 722                 case STRCELL:
 723                    asmAddPtr(con,asmStringObj(textToStr(textOf(a))));
 724                    break;
 725 #               endif
 726                 default:
 727                    /* asmAddPtr(con,??); */
 728                    assert(0);
 729                    break;
 730              }
 731           }
 732           asmEndCon(con);
 733           return con;
 734        }
 735        case LAMBDA: { /* optimisation */
 736           /* ToDo: merge this code with cgLambda */
 737           AsmBCO bco = (AsmBCO)getObj(v);
 738           AsmSp root = asmBeginArgCheck(bco);
 739           map1Proc(cgBind,bco,reverse(stgLambdaArgs(rhs)));
 740           asmEndArgCheck(bco,root);
 741
 742           cgExpr(bco,root,stgLambdaBody(rhs));
 743
 744           asmEndBCO(bco);
 745           return bco;
 746        }
 747        default: {  /* updateable caf */
 748           AsmCAF caf = (AsmCAF)getObj(v);
 749           asmAddRefObject ( caf, cgRhs(rhs) );
 750           asmEndCAF(caf);
 751           return caf;
 752        }
 753     }
 754 }
 755
 756
 757 /* --------------------------------------------------------------------------
 758  * The external entry points for the code generator.
 759  * ------------------------------------------------------------------------*/
 760
 761 Void cgModule ( Module mod )
 762 {
 763     List cl;
 764     Cell c;
 765     int i;
 766
 767     /* Lambda-lift, by traversing the code list of this module.
 768        This creates more name-table entries, which are duly added
 769        to the module's code list.
 770     */
 771     liftModule ( mod );
 772
 773     /* Initialise the BCO linker subsystem. */
 774     asmInitialise();
 775
 776     /* Generate BCOs, CAFs and Constructors into mallocville.
 777        At this point, the .closure values of the names/tycons on
 778        the codelist contain StgVars, ie trees.  The call to beginTop
 779        converts them to MPtrs to AsmObjects.
 780     */
 781     for (cl=module(mod).codeList; nonNull(cl); cl=tl(cl)) {
 782        c = getNameOrTupleClosure(hd(cl));
 783        if (isCPtr(c)) continue;
 784 #      if 0
 785        if (isName(hd(cl))) {
 786           printStg( stdout, name(hd(cl)).closure ); printf( "\n\n");
 787        }
 788 #      endif
 789        beginTop ( c );
 790     }
 791
 792     for (cl=module(mod).codeList; nonNull(cl); cl=tl(cl)) {
 793        c = getNameOrTupleClosure(hd(cl));
 794        if (isCPtr(c)) continue;
 795 #      if 0
 796        if (isName(hd(cl))) {
 797           printStg( stdout, name(hd(cl)).closure ); printf( "\n\n");
 798        }
 799 #      endif
 800        setNameOrTupleClosure ( hd(cl), mkMPtr(endTop(c)) );
 801     }
 802
 803     //fprintf ( stderr, "\nstarting sanity check\n" );
 804     for (cl = module(mod).codeList; nonNull(cl); cl=tl(cl)) {
 805        Cell c = hd(cl);
 806        ASSERT(isName(c) || isTuple(c));
 807        c = getNameOrTupleClosure(c);
 808        ASSERT(isMPtr(c) || isCPtr(c));
 809     }
 810     //fprintf ( stderr, "completed sanity check\n" );
 811
 812
 813     /* Figure out how big each object will be in the evaluator's heap,
 814        and allocate space to put each in, but don't copy yet.  Record
 815        the heap address in the object.  Assumes that GC doesn't happen;
 816        reasonable since we use allocate().
 817     */
 818     asmAllocateHeapSpace();
 819
 820     /* Update name/tycon table closure entries with these new heap addrs. */
 821     for (cl = module(mod).codeList; nonNull(cl); cl=tl(cl)) {
 822        c = getNameOrTupleClosure(hd(cl));
 823        if (isMPtr(c))
 824           setNameOrTupleClosureCPtr (
 825              hd(cl), asmGetClosureOfObject(mptrOf(c)) );
 826     }
 827
 828     /* Copy out of mallocville into the heap, resolving references on
 829        the way.
 830     */
 831     asmCopyAndLink();
 832
 833     /* Free up the malloc'd memory. */
 834     asmShutdown();
 835 }
 836
 837
 838 /* --------------------------------------------------------------------------
 839  * Code Generator control:
 840  * ------------------------------------------------------------------------*/
 841
 842 Void codegen(what)
 843 Int what; {
 844     switch (what) {
 845        case PREPREL:  break;
 846        case RESET:    break;
 847        case MARK:     break;
 848        case POSTPREL: break;
 849     }
 850     liftControl(what);
 851 }
 852
 853 /*-------------------------------------------------------------------------*/