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.23 $
  13  * $Date: 2000/04/27 16:35:29 $
  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   sloweed down.
 115
 116 * Make setCurrentModule ignore name table entries created by the
 117   lambda-lifter.
 118
 119 * Zap various #if 0 in codegen.c/Assembler.c.
 120
 121 * Zap CRUDE_PROFILING.
 122 */
 123
 124
 125 /* --------------------------------------------------------------------------
 126  * Local function prototypes:
 127  * ------------------------------------------------------------------------*/
 128
 129 #define getPos(v)     intOf(stgVarInfo(v))
 130 #define setPos(v,sp)  stgVarInfo(v) = mkInt(sp)
 131 #define getObj(v)     mptrOf(stgVarInfo(v))
 132 #define setObj(v,obj) stgVarInfo(v) = mkMPtr(obj)
 133
 134 #define repOf(x)      charOf(stgVarRep(x))
 135
 136 static void      cgBind       ( AsmBCO bco, StgVar v );
 137 static Void      pushAtom     ( AsmBCO bco, StgAtom atom );
 138 static Void      alloc        ( AsmBCO bco, StgRhs rhs );
 139 static Void      build        ( AsmBCO bco, StgRhs rhs );
 140 static Void      cgExpr       ( AsmBCO bco, AsmSp root, StgExpr e );
 141
 142 static AsmBCO    cgAlts       ( AsmSp root, AsmSp sp, List alts );
 143 static void      testPrimPats ( AsmBCO bco, AsmSp root, List pats, StgExpr e );
 144 static AsmBCO    cgLambda     ( StgExpr e );
 145 static AsmBCO    cgRhs        ( StgRhs rhs );
 146 static void      beginTop     ( StgVar v );
 147 static AsmObject endTop       ( StgVar v );
 148
 149 static StgVar currentTop;
 150
 151 /* --------------------------------------------------------------------------
 152  *
 153  * ------------------------------------------------------------------------*/
 154
 155 static void* /* StgClosure*/ cptrFromName ( Name n )
 156 {
 157    char  buf[1000];
 158    void* p;
 159    Module m = name(n).mod;
 160    Text  mt = module(m).text;
 161    sprintf(buf, MAYBE_LEADING_UNDERSCORE_STR("%s_%s_closure"),
 162                 textToStr(mt),
 163                 textToStr( enZcodeThenFindText (
 164                    textToStr (name(n).text) ) ) );
 165    p = lookupOTabName ( m, buf );
 166    if (!p) {
 167       ERRMSG(0) "Can't find object symbol %s", buf
 168       EEND;
 169    }
 170    return p;
 171 }
 172
 173 char* lookupHugsName( void* closure )
 174 {
 175     extern Name nameHw;
 176     Name nm;
 177     for( nm = NAME_BASE_ADDR;
 178          nm < NAME_BASE_ADDR+tabNameSz; ++nm )
 179        if (tabName[nm-NAME_BASE_ADDR].inUse) {
 180            Cell cl = name(nm).closure;
 181            if (isCPtr(cl) && cptrOf(cl) == closure)
 182                return textToStr(name(nm).text);
 183     }
 184     return NULL;
 185 }
 186
 187 static void cgBindRep( AsmBCO bco, StgVar v, AsmRep rep )
 188 {
 189     setPos(v,asmBind(bco,rep));
 190 }
 191
 192 static void cgBind( AsmBCO bco, StgVar v )
 193 {
 194     cgBindRep(bco,v,repOf(v));
 195 }
 196
 197 static void cgAddPtrToObject ( AsmObject obj, Cell ptrish )
 198 {
 199    switch (whatIs(ptrish)) {
 200       case CPTRCELL:
 201          asmAddRefNoOp ( obj, (StgPtr)cptrOf(ptrish) ); break;
 202       case MPTRCELL:
 203          asmAddRefObject ( obj, mptrOf(ptrish) ); break;
 204       default:
 205          internal("cgAddPtrToObject");
 206    }
 207 }
 208
 209 #if 0
 210 static void cgPushRef ( AsmBCO bco, Cell c )
 211 {
 212    switch (whatIs(c)) {
 213       case CPTRCELL:
 214          asmPushRefNoOp(bco,(StgPtr)cptrOf(c)); break;
 215       case PTRCELL:
 216          asmPushRefObject(bco,ptrOf(c)); break;
 217       case NAME:
 218       case TUPLE:
 219          asmPushRefHugs(bco,c); break;
 220       default:
 221          internal("cgPushRef");
 222    }
 223 }
 224 #endif
 225
 226 /* Get a pointer to atom e onto the stack. */
 227 static Void pushAtom ( AsmBCO bco, StgAtom e )
 228 {
 229     Cell info;
 230     Cell cl;
 231 #   if 0
 232     printf ( "pushAtom: %d  ", e ); fflush(stdout);
 233     print(e,10);printf("\n");
 234 #   endif
 235     switch (whatIs(e)) {
 236        case STGVAR:
 237            info = stgVarInfo(e);
 238            if (isInt(info)) {
 239               asmVar(bco,intOf(info),repOf(e));
 240            }
 241            else
 242            if (isCPtr(info)) {
 243               asmPushRefNoOp(bco,cptrOf(info));
 244            }
 245            else
 246            if (isMPtr(info)) {
 247               asmPushRefObject(bco,mptrOf(info));
 248            }
 249            else {
 250               internal("pushAtom: STGVAR");
 251            }
 252            break;
 253        case NAME:
 254        case TUPLE:
 255             cl = getNameOrTupleClosure(e);
 256             if (isStgVar(cl)) {
 257                /* a stg tree which hasn't yet been translated */
 258                asmPushRefHugs(bco,e);
 259             }
 260             else
 261             if (isCPtr(cl)) {
 262                /* a pointer to something in the heap */
 263                asmPushRefNoOp(bco,(StgPtr)cptrOf(cl));
 264             }
 265             else
 266             if (isMPtr(cl)) {
 267                /* a pointer to an AsmBCO/AsmCAF/AsmCon object */
 268                asmPushRefObject(bco,mptrOf(cl));
 269             }
 270             else {
 271                StgClosure* addr;
 272                ASSERT(isNull(cl));
 273                addr = cptrFromName(e);
 274 #              if DEBUG_CODEGEN
 275                fprintf ( stderr, "nativeAtom: name %s\n",
 276                                  nameFromOPtr(addr) );
 277 #              endif
 278                asmPushRefNoOp(bco,(StgPtr)addr);
 279             }
 280             break;
 281        case CHARCELL:
 282             asmConstChar(bco,charOf(e));
 283             break;
 284        case INTCELL:
 285             asmConstInt(bco,intOf(e));
 286             break;
 287        case ADDRCELL:
 288             asmConstAddr(bco,addrOf(e));
 289             break;
 290        case BIGCELL:
 291             asmConstInteger(bco,bignumToString(e));
 292             break;
 293        case FLOATCELL:
 294             asmConstDouble(bco,floatOf(e));
 295             break;
 296        case STRCELL:
 297 #           if USE_ADDR_FOR_STRINGS
 298             asmConstAddr(bco,textToStr(textOf(e)));
 299 #           else
 300             asmClosure(bco,asmStringObj(textToStr(textOf(e))));
 301 #           endif
 302             break;
 303        case CPTRCELL:
 304             asmPushRefNoOp(bco,cptrOf(e));
 305             break;
 306        case MPTRCELL:
 307             asmPushRefObject(bco,mptrOf(e));
 308             break;
 309        default:
 310             fprintf(stderr,"\nYoiks1: "); printExp(stderr,e);
 311             internal("pushAtom");
 312     }
 313 }
 314
 315 static AsmBCO cgAlts( AsmSp root, AsmSp sp, List alts )
 316 {
 317 #ifdef CRUDE_PROFILING
 318     AsmBCO bco = asmBeginContinuation(sp, currentTop + 1000000000);
 319 #else
 320     AsmBCO bco = asmBeginContinuation(sp, alts);
 321 #endif
 322     Bool omit_test
 323        = length(alts) == 2 &&
 324          isDefaultAlt(hd(tl(alts))) &&
 325          !isDefaultAlt(hd(alts));
 326     if (omit_test) {
 327        /* refine the condition */
 328        Name con;
 329        Tycon t;
 330        omit_test = FALSE;
 331        con = stgCaseAltCon(hd(alts));
 332
 333        /* special case: dictionary constructors */
 334        if (isName(con) && strncmp(":D",textToStr(name(con).text),2)==0) {
 335           omit_test = TRUE;
 336           goto xyzzy;
 337        }
 338        /* special case: Tuples */
 339        if (isTuple(con) || (isName(con) && con==nameUnit)) {
 340           omit_test = TRUE;
 341           goto xyzzy;
 342        }
 343
 344        t = name(con).parent;
 345        if (tycon(t).what == DATATYPE) {
 346           if (length(tycon(t).defn) == 1) omit_test = TRUE;
 347        }
 348     }
 349
 350     xyzzy:
 351
 352     for(; nonNull(alts); alts=tl(alts)) {
 353         StgCaseAlt alt  = hd(alts);
 354         if (isDefaultAlt(alt)) {
 355             cgBind(bco,stgDefaultVar(alt));
 356             cgExpr(bco,root,stgDefaultBody(alt));
 357             asmEndContinuation(bco);
 358             return bco; /* ignore any further alternatives */
 359         } else {
 360             StgDiscr con   = stgCaseAltCon(alt);
 361             List     vs    = stgCaseAltVars(alt);
 362             AsmSp    begin = asmBeginAlt(bco);
 363             AsmPc    fix;
 364             if (omit_test) fix=-1; else fix = asmTest(bco,stgDiscrTag(con));
 365
 366             asmBind(bco,PTR_REP); /* Adjust simulated sp to acct for return value */
 367             if (isBoxingCon(con)) {
 368                 setPos(hd(vs),asmUnbox(bco,boxingConRep(con)));
 369             } else {
 370                 asmBeginUnpack(bco);
 371                 map1Proc(cgBind,bco,reverse(vs));
 372                 asmEndUnpack(bco);
 373             }
 374             cgExpr(bco,root,stgCaseAltBody(alt));
 375             asmEndAlt(bco,begin);
 376             if (fix != -1) asmFixBranch(bco,fix);
 377         }
 378     }
 379     /* if we got this far and didn't match, panic! */
 380     asmPanic(bco);
 381     asmEndContinuation(bco);
 382     return bco;
 383 }
 384
 385 static void testPrimPats( AsmBCO bco, AsmSp root, List pats, StgExpr e )
 386 {
 387     if (isNull(pats)) {
 388         cgExpr(bco,root,e);
 389     } else {
 390         StgVar pat = hd(pats);
 391         if (isInt(stgVarBody(pat))) {
 392             /* asmTestInt leaves stack unchanged - so no need to adjust it */
 393             AsmPc tst = asmTestInt(bco,getPos(pat),intOf(stgVarBody(pat)));
 394             assert(repOf(pat) == INT_REP);
 395             testPrimPats(bco,root,tl(pats),e);
 396             asmFixBranch(bco,tst);
 397         } else {
 398             testPrimPats(bco,root,tl(pats),e);
 399         }
 400     }
 401 }
 402
 403
 404 static AsmBCO cgLambda( StgExpr e )
 405 {
 406     AsmBCO bco = asmBeginBCO(e);
 407
 408     AsmSp root = asmBeginArgCheck(bco);
 409     map1Proc(cgBind,bco,reverse(stgLambdaArgs(e)));
 410     asmEndArgCheck(bco,root);
 411
 412     /* ppStgExpr(e); */
 413     cgExpr(bco,root,stgLambdaBody(e));
 414
 415     asmEndBCO(bco);
 416     return bco;
 417 }
 418
 419 static AsmBCO cgRhs( StgRhs rhs )
 420 {
 421     AsmBCO bco = asmBeginBCO(rhs );
 422
 423     AsmSp root = asmBeginArgCheck(bco);
 424     asmEndArgCheck(bco,root);
 425
 426     /* ppStgExpr(rhs); */
 427     cgExpr(bco,root,rhs);
 428
 429     asmEndBCO(bco);
 430     return bco;
 431 }
 432
 433
 434 static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e )
 435 {
 436 #if 0
 437     printf("cgExpr:");ppStgExpr(e);printf("\n");
 438 #endif
 439     switch (whatIs(e)) {
 440     case LETREC:
 441         {
 442             List binds = stgLetBinds(e);
 443             map1Proc(alloc,bco,binds);
 444             map1Proc(build,bco,binds);
 445             cgExpr(bco,root,stgLetBody(e));
 446             break;
 447         }
 448     case LAMBDA:
 449         {
 450             AsmSp begin = asmBeginEnter(bco);
 451             asmPushRefObject(bco,cgLambda(e));
 452             asmEndEnter(bco,begin,root);
 453             break;
 454         }
 455     case CASE:
 456         {
 457             List  alts     = stgCaseAlts(e);
 458             AsmSp sp       = asmBeginCase(bco);
 459             AsmSp caseroot = asmContinuation(bco,cgAlts(root,sp,alts));
 460             cgExpr(bco,caseroot,stgCaseScrut(e));
 461             asmEndCase(bco);
 462             break;
 463         }
 464     case PRIMCASE:
 465         {
 466             StgExpr scrut = stgPrimCaseScrut(e);
 467             List alts = stgPrimCaseAlts(e);
 468             if (whatIs(scrut) == STGPRIM) {  /* this is an optimisation */
 469
 470                 /* No need to use return address or to Slide */
 471                 AsmSp beginPrim = asmBeginPrim(bco);
 472                 map1Proc(pushAtom,bco,reverse(stgPrimArgs(scrut)));
 473                 asmEndPrim(bco,(AsmPrim*)name(stgPrimOp(scrut)).primop,beginPrim);
 474
 475                 for(; nonNull(alts); alts=tl(alts)) {
 476                     StgPrimAlt alt = hd(alts);
 477                     List    pats = stgPrimAltVars(alt);
 478                     StgExpr body = stgPrimAltBody(alt);
 479                     AsmSp altBegin = asmBeginAlt(bco);
 480                     map1Proc(cgBind,bco,reverse(pats));
 481                     testPrimPats(bco,root,pats,body);
 482                     asmEndAlt(bco,altBegin);
 483                 }
 484                 /* if we got this far and didn't match, panic! */
 485                 asmPanic(bco);
 486
 487             } else if (whatIs(scrut) == STGVAR) { /* another optimisation */
 488
 489                 /* No need to use return address or to Slide */
 490
 491                 /* only part different from primop code... todo */
 492                 AsmSp beginCase = asmBeginCase(bco);
 493                 pushAtom /*pushVar*/ (bco,scrut);
 494                 asmEndAlt(bco,beginCase); /* hack, hack -  */
 495
 496                 for(; nonNull(alts); alts=tl(alts)) {
 497                     StgPrimAlt alt = hd(alts);
 498                     List    pats = stgPrimAltVars(alt);
 499                     StgExpr body = stgPrimAltBody(alt);
 500                     AsmSp altBegin = asmBeginAlt(bco);
 501                     map1Proc(cgBind,bco,pats);
 502                     testPrimPats(bco,root,pats,body);
 503                     asmEndAlt(bco,altBegin);
 504                 }
 505                 /* if we got this far and didn't match, panic! */
 506                 asmPanic(bco);
 507
 508             } else {
 509                 /* ToDo: implement this code...  */
 510                 assert(0);
 511                 /* asmPushRet(bco,delayPrimAlt( stgPrimCaseVars(e),
 512                                                 stgPrimCaseBody(e))); */
 513                 /* cgExpr( bco,root,scrut ); */
 514             }
 515             break;
 516         }
 517     case STGAPP: /* Tail call */
 518         {
 519             AsmSp env = asmBeginEnter(bco);
 520             map1Proc(pushAtom,bco,reverse(stgAppArgs(e)));
 521             pushAtom(bco,stgAppFun(e));
 522             asmEndEnter(bco,env,root);
 523             break;
 524         }
 525     case TUPLE:
 526     case NAME: /* Tail call (with no args) */
 527         {
 528             AsmSp env = asmBeginEnter(bco);
 529             /* JRS 000112: next line used to be: pushVar(bco,name(e).stgVar); */
 530             pushAtom(bco,e);
 531             asmEndEnter(bco,env,root);
 532             break;
 533         }
 534     case STGVAR: /* Tail call (with no args), plus unboxed return */
 535             switch (repOf(e)) {
 536             case PTR_REP:
 537             case ALPHA_REP:
 538             case BETA_REP:
 539                 {
 540                     AsmSp env = asmBeginEnter(bco);
 541                     pushAtom /*pushVar*/ (bco,e);
 542                     asmEndEnter(bco,env,root);
 543                     break;
 544                 }
 545             case INT_REP:
 546                     assert(0);
 547                     /* cgTailCall(bco,singleton(e)); */
 548                     /* asmReturnInt(bco); */
 549                     break;
 550             default:
 551                     internal("cgExpr StgVar");
 552             }
 553             break;
 554     case STGPRIM: /* Tail call again */
 555         {
 556             AsmSp beginPrim = asmBeginPrim(bco);
 557             map1Proc(pushAtom,bco,reverse(stgPrimArgs(e)));
 558             asmEndPrim(bco,(AsmPrim*)name(e).primop,beginPrim);
 559             /* map1Proc(cgBind,bco,rs_vars); */
 560             assert(0); /* asmReturn_retty(); */
 561             break;
 562         }
 563     default:
 564             fprintf(stderr,"\nYoiks2: "); printExp(stderr,e);
 565             internal("cgExpr");
 566     }
 567 }
 568
 569 /* allocate space for top level variable
 570  * any change requires a corresponding change in 'build'.
 571  */
 572 static Void alloc( AsmBCO bco, StgVar v )
 573 {
 574     StgRhs rhs = stgVarBody(v);
 575     assert(isStgVar(v));
 576 #if 0
 577     printf("alloc: ");ppStgExpr(v);
 578 #endif
 579     switch (whatIs(rhs)) {
 580     case STGCON:
 581         {
 582             StgDiscr con  = stgConCon(rhs);
 583             List     args = stgConArgs(rhs);
 584             if (isBoxingCon(con)) {
 585                 pushAtom(bco,hd(args));
 586                 setPos(v,asmBox(bco,boxingConRep(con)));
 587             } else {
 588                 setPos(v,asmAllocCONSTR(bco,stgConInfo(con)));
 589             }
 590             break;
 591         }
 592     case STGAPP: {
 593             Int  totSizeW = 0;
 594             List bs       = stgAppArgs(rhs);
 595             for (; nonNull(bs); bs=tl(bs)) {
 596                if (isName(hd(bs))) {
 597                   totSizeW += 1;
 598                } else {
 599                   ASSERT(whatIs(hd(bs))==STGVAR);
 600                   totSizeW += asmRepSizeW( charOf(stgVarRep(hd(bs))) );
 601                }
 602             }
 603             setPos(v,asmAllocAP(bco,totSizeW));
 604             break;
 605          }
 606     case LAMBDA: /* optimisation */
 607             setObj(v,cgLambda(rhs));
 608             break;
 609     default:
 610             setPos(v,asmAllocAP(bco,0));
 611             break;
 612     }
 613 }
 614
 615 static Void build( AsmBCO bco, StgVar v )
 616 {
 617     StgRhs rhs = stgVarBody(v);
 618     assert(isStgVar(v));
 619     //ppStg(v);
 620     switch (whatIs(rhs)) {
 621     case STGCON:
 622         {
 623             StgDiscr con  = stgConCon(rhs);
 624             List     args = stgConArgs(rhs);
 625             if (isBoxingCon(con)) {
 626                 doNothing();  /* already done in alloc */
 627             } else {
 628                 AsmSp start = asmBeginPack(bco);
 629                 map1Proc(pushAtom,bco,reverse(args));
 630                 asmEndPack(bco,getPos(v),start,stgConInfo(con));
 631             }
 632             return;
 633         }
 634     case STGAPP:
 635         {
 636             Bool   itsaPAP;
 637             StgVar fun  = stgAppFun(rhs);
 638             List   args = stgAppArgs(rhs);
 639
 640             if (isName(fun)) {
 641                itsaPAP = name(fun).arity > length(args);
 642             } else
 643             if (isStgVar(fun)) {
 644                itsaPAP = FALSE;
 645                if (nonNull(stgVarBody(fun))
 646                    && whatIs(stgVarBody(fun)) == LAMBDA
 647                    && length(stgLambdaArgs(stgVarBody(fun))) > length(args)
 648                   )
 649                   itsaPAP = TRUE;
 650             }
 651             else
 652                internal("build: STGAPP");
 653 #if 0
 654 Looks like a hack to me.
 655             if (isName(fun)) {
 656                 if (nonNull(name(fun).closure))
 657                    fun = name(fun).closure; else
 658                    fun = cptrFromName(fun);
 659             }
 660
 661             if (isCPtr(fun)) {
 662                assert(isName(fun0));
 663                itsaPAP = name(fun0).arity > length(args);
 664 #              if DEBUG_CODEGEN
 665                fprintf ( stderr, "nativeCall: name %s, arity %d, args %d\n",
 666                          nameFromOPtr(cptrOf(fun)), name(fun0).arity,
 667                          length(args) );
 668 #              endif
 669             } else {
 670                itsaPAP = FALSE;
 671                if (nonNull(stgVarBody(fun))
 672                    && whatIs(stgVarBody(fun)) == LAMBDA
 673                    && length(stgLambdaArgs(stgVarBody(fun))) > length(args)
 674                   )
 675                   itsaPAP = TRUE;
 676             }
 677 #endif
 678
 679             if (itsaPAP) {
 680                 AsmSp  start = asmBeginMkPAP(bco);
 681                 map1Proc(pushAtom,bco,reverse(args));
 682                 pushAtom(bco,fun);
 683                 asmEndMkPAP(bco,getPos(v),start); /* optimisation */
 684             } else {
 685                 AsmSp  start = asmBeginMkAP(bco);
 686                 map1Proc(pushAtom,bco,reverse(args));
 687                 pushAtom(bco,fun);
 688                 asmEndMkAP(bco,getPos(v),start);
 689             }
 690             return;
 691         }
 692     case LAMBDA: /* optimisation */
 693             doNothing(); /* already pushed in alloc */
 694             break;
 695
 696     /* These two cases look almost identical to the default but they're really
 697      * special cases of STGAPP.  The essential thing here is that we can't call
 698      * cgRhs(rhs) because that expects the rhs to have no free variables when,
 699      * in fact, the rhs is _always_ a free variable.
 700      *
 701      * ToDo: a simple optimiser would eliminate all examples
 702      * of this except "let x = x in ..."
 703      */
 704     case NAME:
 705     case STGVAR:
 706         {
 707             AsmSp  start = asmBeginMkAP(bco);
 708             pushAtom(bco,rhs);
 709             asmEndMkAP(bco,getPos(v),start);
 710         }
 711         return;
 712     default:
 713         {
 714             AsmSp start = asmBeginMkAP(bco);   /* make it updateable! */
 715             asmPushRefObject(bco,cgRhs(rhs));
 716             asmEndMkAP(bco,getPos(v),start);
 717             return;
 718         }
 719     }
 720 }
 721
 722 /* --------------------------------------------------------------------------
 723  * Top level variables
 724  *
 725  * ToDo: these should be handled by allocating a dynamic unentered CAF
 726  * for each top level variable - this should be simpler!
 727  * ------------------------------------------------------------------------*/
 728
 729 /* allocate AsmObject for top level variables
 730  * any change requires a corresponding change in endTop
 731  */
 732 static void beginTop( StgVar v )
 733 {
 734     StgRhs rhs;
 735     assert(isStgVar(v));
 736     currentTop = v;
 737     rhs = stgVarBody(v);
 738     switch (whatIs(rhs)) {
 739        case STGCON:
 740           setObj(v,asmBeginCon(stgConInfo(stgConCon(rhs))));
 741           break;
 742        case LAMBDA:
 743 #         ifdef CRUDE_PROFILING
 744           setObj(v,asmBeginBCO(currentTop));
 745 #         else
 746           setObj(v,asmBeginBCO(rhs));
 747 #         endif
 748           break;
 749        default:
 750           setObj(v,asmBeginCAF());
 751           break;
 752     }
 753 }
 754
 755 static AsmObject endTop( StgVar v )
 756 {
 757     StgRhs rhs = stgVarBody(v);
 758     currentTop = v;
 759     switch (whatIs(rhs)) {
 760        case STGCON: {
 761           List as = stgConArgs(rhs);
 762           AsmCon con = (AsmCon)getObj(v);
 763           for ( ; nonNull(as); as=tl(as)) {
 764              StgAtom a = hd(as);
 765              switch (whatIs(a)) {
 766                 case STGVAR:
 767                    /* should be a delayed combinator! */
 768                    asmAddRefObject(con,(AsmObject)getObj(a));
 769                    break;
 770                 case NAME: {
 771                    StgVar var = name(a).closure;
 772                    cgAddPtrToObject(con,var);
 773                    break;
 774                 }
 775 #               if !USE_ADDR_FOR_STRINGS
 776                 case STRCELL:
 777                    asmAddPtr(con,asmStringObj(textToStr(textOf(a))));
 778                    break;
 779 #               endif
 780                 default:
 781                    /* asmAddPtr(con,??); */
 782                    assert(0);
 783                    break;
 784              }
 785           }
 786           asmEndCon(con);
 787           return con;
 788        }
 789        case LAMBDA: { /* optimisation */
 790           /* ToDo: merge this code with cgLambda */
 791           AsmBCO bco = (AsmBCO)getObj(v);
 792           AsmSp root = asmBeginArgCheck(bco);
 793           map1Proc(cgBind,bco,reverse(stgLambdaArgs(rhs)));
 794           asmEndArgCheck(bco,root);
 795
 796           cgExpr(bco,root,stgLambdaBody(rhs));
 797
 798           asmEndBCO(bco);
 799           return bco;
 800        }
 801        default: {  /* updateable caf */
 802           AsmCAF caf = (AsmCAF)getObj(v);
 803           asmAddRefObject ( caf, cgRhs(rhs) );
 804           asmEndCAF(caf);
 805           return caf;
 806        }
 807     }
 808 }
 809
 810
 811 /* --------------------------------------------------------------------------
 812  * The external entry points for the code generator.
 813  * ------------------------------------------------------------------------*/
 814
 815 Void cgModule ( Module mod )
 816 {
 817     List cl;
 818     Cell c;
 819     int i;
 820
 821     /* Lambda-lift, by traversing the code list of this module.
 822        This creates more name-table entries, which are duly added
 823        to the module's code list.
 824     */
 825     liftModule ( mod );
 826
 827     /* Initialise the BCO linker subsystem. */
 828     asmInitialise();
 829
 830     /* Generate BCOs, CAFs and Constructors into mallocville.
 831        At this point, the .closure values of the names/tycons on
 832        the codelist contain StgVars, ie trees.  The call to beginTop
 833        converts them to MPtrs to AsmObjects.
 834     */
 835     for (cl=module(mod).codeList; nonNull(cl); cl=tl(cl)) {
 836        c = getNameOrTupleClosure(hd(cl));
 837        if (isCPtr(c)) continue;
 838 #      if 0
 839        if (isName(hd(cl))) {
 840           printStg( stdout, name(hd(cl)).closure ); printf( "\n\n");
 841        }
 842 #      endif
 843        beginTop ( c );
 844     }
 845
 846     for (cl=module(mod).codeList; nonNull(cl); cl=tl(cl)) {
 847        c = getNameOrTupleClosure(hd(cl));
 848        if (isCPtr(c)) continue;
 849 #      if 0
 850        if (isName(hd(cl))) {
 851           printStg( stdout, name(hd(cl)).closure ); printf( "\n\n");
 852        }
 853 #      endif
 854        setNameOrTupleClosure ( hd(cl), mkMPtr(endTop(c)) );
 855     }
 856
 857     //fprintf ( stderr, "\nstarting sanity check\n" );
 858     for (cl = module(mod).codeList; nonNull(cl); cl=tl(cl)) {
 859        Cell c = hd(cl);
 860        ASSERT(isName(c) || isTuple(c));
 861        c = getNameOrTupleClosure(c);
 862        ASSERT(isMPtr(c) || isCPtr(c));
 863     }
 864     //fprintf ( stderr, "completed sanity check\n" );
 865
 866
 867     /* Figure out how big each object will be in the evaluator's heap,
 868        and allocate space to put each in, but don't copy yet.  Record
 869        the heap address in the object.  Assumes that GC doesn't happen;
 870        reasonable since we use allocate().
 871     */
 872     asmAllocateHeapSpace();
 873
 874     /* Update name/tycon table closure entries with these new heap addrs. */
 875     for (cl = module(mod).codeList; nonNull(cl); cl=tl(cl)) {
 876        c = getNameOrTupleClosure(hd(cl));
 877        if (isMPtr(c))
 878           setNameOrTupleClosureCPtr (
 879              hd(cl), asmGetClosureOfObject(mptrOf(c)) );
 880     }
 881
 882     /* Copy out of mallocville into the heap, resolving references on
 883        the way.
 884     */
 885     asmCopyAndLink();
 886
 887     /* Free up the malloc'd memory. */
 888     asmShutdown();
 889 }
 890
 891
 892 /* --------------------------------------------------------------------------
 893  * Code Generator control:
 894  * ------------------------------------------------------------------------*/
 895
 896 Void codegen(what)
 897 Int what; {
 898     switch (what) {
 899        case PREPREL:
 900        case RESET:
 901        case MARK:
 902        case POSTPREL:
 903           break;
 904     }
 905     liftControl(what);
 906 }
 907
 908 /*-------------------------------------------------------------------------*/