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.12 $
  13  * $Date: 1999/11/29 18:59:25 $
  14  * ------------------------------------------------------------------------*/
  15
  16 #include "prelude.h"
  17 #include "storage.h"
  18 #include "backend.h"
  19 #include "connect.h"
  20 #include "errors.h"
  21 #include "Assembler.h"
  22 #include "link.h"
  23
  24 #include "Rts.h"    /* IF_DEBUG */
  25 #include "RtsFlags.h"
  26
  27 /* --------------------------------------------------------------------------
  28  * Local function prototypes:
  29  * ------------------------------------------------------------------------*/
  30
  31 #define getPos(v)     intOf(stgVarInfo(v))
  32 #define setPos(v,sp)  stgVarInfo(v) = mkInt(sp)
  33 #define getObj(v)     ptrOf(stgVarInfo(v))
  34 #define setObj(v,obj) stgVarInfo(v) = mkPtr(obj)
  35
  36 #define repOf(x)      charOf(stgVarRep(x))
  37
  38 static void  cgBind        ( AsmBCO bco, StgVar v );
  39 static Void  pushVar       ( AsmBCO bco, StgVar v );
  40 static Void  pushAtom      ( AsmBCO bco, StgAtom atom );
  41 static Void  alloc         ( AsmBCO bco, StgRhs rhs );
  42 static Void  build         ( AsmBCO bco, StgRhs rhs );
  43 static Void  cgExpr        ( AsmBCO bco, AsmSp root, StgExpr e );
  44
  45 static AsmBCO cgAlts       ( AsmSp root, AsmSp sp, List alts );
  46 static void   testPrimPats ( AsmBCO bco, AsmSp root, List pats, StgExpr e );
  47 //static void   cgPrimAlt    ( AsmBCO bco, AsmSp root, List vs, StgExpr e );
  48 static AsmBCO cgLambda     ( StgExpr e );
  49 static AsmBCO cgRhs        ( StgRhs rhs );
  50 static void   beginTop     ( StgVar v );
  51 static void   endTop       ( StgVar v );
  52
  53 static StgVar currentTop;
  54
  55 /* --------------------------------------------------------------------------
  56  *
  57  * ------------------------------------------------------------------------*/
  58
  59 static Cell cptrFromName ( Name n )
  60 {
  61    char  buf[1000];
  62    void* p;
  63    Module m = name(n).mod;
  64    Text  mt = module(m).text;
  65    sprintf(buf,"%s_%s_closure",
  66                textToStr(mt),
  67                textToStr( enZcodeThenFindText ( textToStr (name(n).text) ) ) );
  68    p = lookupOTabName ( m, buf );
  69    if (!p) {
  70       ERRMSG(0) "Can't find object symbol %s", buf
  71       EEND;
  72    }
  73    return mkCPtr(p);
  74 }
  75
  76 static Bool varHasClosure( StgVar v )
  77 {
  78     return asmObjectHasClosure((AsmClosure*)ptrOf(stgVarInfo(v)));
  79 }
  80
  81 /* should be AsmClosure* */
  82 void* closureOfVar( StgVar v )
  83 {
  84     return asmClosureOfObject((AsmClosure*)ptrOf(stgVarInfo(v)));
  85 }
  86
  87 char* lookupHugsName( void* closure )
  88 {
  89     extern Name nameHw;
  90     Name nm;
  91     for( nm=NAMEMIN; nm<nameHw; ++nm ) {
  92         StgVar v  = name(nm).stgVar;
  93         if (isStgVar(v)
  94             && isPtr(stgVarInfo(v))
  95             && varHasClosure(v)
  96             && closureOfVar(v) == closure) {
  97             return textToStr(name(nm).text);
  98         }
  99     }
 100     return 0;
 101 }
 102
 103 /* called at the start of GC */
 104 void markHugsObjects( void )
 105 {
 106     extern Name nameHw;
 107     Name nm;
 108     for( nm=NAMEMIN; nm<nameHw; ++nm ) {
 109         StgVar v  = name(nm).stgVar;
 110         if (isStgVar(v) && isPtr(stgVarInfo(v))) {
 111             asmMarkObject((AsmClosure*)ptrOf(stgVarInfo(v)));
 112         }
 113     }
 114 }
 115
 116 static void cgBindRep( AsmBCO bco, StgVar v, AsmRep rep )
 117 {
 118     setPos(v,asmBind(bco,rep));
 119 }
 120
 121 static void cgBind( AsmBCO bco, StgVar v )
 122 {
 123     cgBindRep(bco,v,repOf(v));
 124 }
 125
 126 static Void pushVar( AsmBCO bco, StgVar v )
 127 {
 128     Cell info;
 129
 130     if (!(isStgVar(v) || isCPtr(v))) {
 131     assert(isStgVar(v) || isCPtr(v));
 132     }
 133
 134     if (isCPtr(v)) {
 135        asmGHCClosure(bco, cptrOf(v));
 136     } else {
 137        info = stgVarInfo(v);
 138        if (isPtr(info)) {
 139            asmClosure(bco,ptrOf(info));
 140        } else if (isInt(info)) {
 141            asmVar(bco,intOf(info),repOf(v));
 142        } else {
 143            internal("pushVar");
 144        }
 145     }
 146 }
 147
 148 static Void pushAtom( AsmBCO bco, StgAtom e )
 149 {
 150     switch (whatIs(e)) {
 151     case STGVAR:
 152             pushVar(bco,e);
 153             break;
 154     case NAME:
 155             if (nonNull(name(e).stgVar))
 156                pushVar(bco,name(e).stgVar); else
 157                pushVar(bco,cptrFromName(e));
 158             break;
 159     case CHARCELL:
 160             asmConstChar(bco,charOf(e));
 161             break;
 162     case INTCELL:
 163             asmConstInt(bco,intOf(e));
 164             break;
 165     case BIGCELL:
 166             asmConstInteger(bco,bignumToString(e));
 167             break;
 168     case FLOATCELL:
 169             asmConstDouble(bco,floatOf(e));
 170             break;
 171     case STRCELL:
 172 #if USE_ADDR_FOR_STRINGS
 173             asmConstAddr(bco,textToStr(textOf(e)));
 174 #else
 175             asmClosure(bco,asmStringObj(textToStr(textOf(e))));
 176 #endif
 177             break;
 178     case CPTRCELL:
 179             asmGHCClosure(bco,cptrOf(e));
 180             break;
 181     case PTRCELL:
 182             asmConstAddr(bco,ptrOf(e));
 183             break;
 184     default:
 185             fprintf(stderr,"\nYoiks: "); printExp(stderr,e);
 186             internal("pushAtom");
 187     }
 188 }
 189
 190 static AsmBCO cgAlts( AsmSp root, AsmSp sp, List alts )
 191 {
 192 #ifdef CRUDE_PROFILING
 193     AsmBCO bco = asmBeginContinuation(sp, currentTop + 1000000000);
 194 #else
 195     AsmBCO bco = asmBeginContinuation(sp, alts);
 196 #endif
 197     Bool omit_test
 198        = length(alts) == 2 &&
 199          isDefaultAlt(hd(tl(alts))) &&
 200          !isDefaultAlt(hd(alts));
 201     if (omit_test) {
 202        /* refine the condition */
 203        Name con;
 204        Tycon t;
 205        omit_test = FALSE;
 206        con = stgCaseAltCon(hd(alts));
 207
 208        /* special case: dictionary constructors */
 209        if (strncmp(":D",textToStr(name(con).text),2)==0) {
 210           omit_test = TRUE;
 211           goto xyzzy;
 212        }
 213        /* special case: Tuples */
 214        if (isTuple(con) || (isName(con) && con==nameUnit)) {
 215           omit_test = TRUE;
 216           goto xyzzy;
 217        }
 218
 219        t = name(con).parent;
 220        if (tycon(t).what == DATATYPE) {
 221           if (length(tycon(t).defn) == 1) omit_test = TRUE;
 222        }
 223     }
 224
 225     xyzzy:
 226
 227     for(; nonNull(alts); alts=tl(alts)) {
 228         StgCaseAlt alt  = hd(alts);
 229         if (isDefaultAlt(alt)) {
 230             cgBind(bco,stgDefaultVar(alt));
 231             cgExpr(bco,root,stgDefaultBody(alt));
 232             asmEndContinuation(bco);
 233             return bco; /* ignore any further alternatives */
 234         } else {
 235             StgDiscr con   = stgCaseAltCon(alt);
 236             List     vs    = stgCaseAltVars(alt);
 237             AsmSp    begin = asmBeginAlt(bco);
 238             AsmPc    fix;
 239             if (omit_test) fix=-1; else fix = asmTest(bco,stgDiscrTag(con));
 240
 241             asmBind(bco,PTR_REP); /* Adjust simulated sp to acct for return value */
 242             if (isBoxingCon(con)) {
 243                 setPos(hd(vs),asmUnbox(bco,boxingConRep(con)));
 244             } else {
 245                 asmBeginUnpack(bco);
 246                 map1Proc(cgBind,bco,reverse(vs));
 247                 asmEndUnpack(bco);
 248             }
 249             cgExpr(bco,root,stgCaseAltBody(alt));
 250             asmEndAlt(bco,begin);
 251             if (fix != -1) asmFixBranch(bco,fix);
 252         }
 253     }
 254     /* if we got this far and didn't match, panic! */
 255     asmPanic(bco);
 256     asmEndContinuation(bco);
 257     return bco;
 258 }
 259
 260 static void testPrimPats( AsmBCO bco, AsmSp root, List pats, StgExpr e )
 261 {
 262     if (isNull(pats)) {
 263         cgExpr(bco,root,e);
 264     } else {
 265         StgVar pat = hd(pats);
 266         if (isInt(stgVarBody(pat))) {
 267             /* asmTestInt leaves stack unchanged - so no need to adjust it */
 268             AsmPc tst = asmTestInt(bco,getPos(pat),intOf(stgVarBody(pat)));
 269             assert(repOf(pat) == INT_REP);
 270             testPrimPats(bco,root,tl(pats),e);
 271             asmFixBranch(bco,tst);
 272         } else {
 273             testPrimPats(bco,root,tl(pats),e);
 274         }
 275     }
 276 }
 277
 278 #if 0  /* appears to be unused */
 279 static void cgPrimAlt( AsmBCO bco, AsmSp root, List vs, StgExpr e )
 280 {
 281     assert(0); /* ToDo: test for patterns */
 282     map1Proc(cgBind,bco,vs); /* ToDo: are these in right order? */
 283     cgExpr(bco,root,e);
 284 }
 285 #endif
 286
 287
 288 static AsmBCO cgLambda( StgExpr e )
 289 {
 290     AsmBCO bco = asmBeginBCO(e);
 291
 292     AsmSp root = asmBeginArgCheck(bco);
 293     map1Proc(cgBind,bco,reverse(stgLambdaArgs(e)));
 294     asmEndArgCheck(bco,root);
 295
 296     /* ppStgExpr(e); */
 297     cgExpr(bco,root,stgLambdaBody(e));
 298
 299     asmEndBCO(bco);
 300     return bco;
 301 }
 302
 303 static AsmBCO cgRhs( StgRhs rhs )
 304 {
 305     AsmBCO bco = asmBeginBCO(rhs );
 306
 307     AsmSp root = asmBeginArgCheck(bco);
 308     asmEndArgCheck(bco,root);
 309
 310     /* ppStgExpr(rhs); */
 311     cgExpr(bco,root,rhs);
 312
 313     asmEndBCO(bco);
 314     return bco;
 315 }
 316
 317
 318 static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e )
 319 {
 320   //printf("cgExpr:");ppStgExpr(e);printf("\n");
 321     switch (whatIs(e)) {
 322     case LETREC:
 323         {
 324             List binds = stgLetBinds(e);
 325             map1Proc(alloc,bco,binds);
 326             map1Proc(build,bco,binds);
 327             cgExpr(bco,root,stgLetBody(e));
 328             break;
 329         }
 330     case LAMBDA:
 331         {
 332             AsmSp begin = asmBeginEnter(bco);
 333             asmClosure(bco,cgLambda(e));
 334             asmEndEnter(bco,begin,root);
 335             break;
 336         }
 337     case CASE:
 338         {
 339             List  alts     = stgCaseAlts(e);
 340             AsmSp sp       = asmBeginCase(bco);
 341             AsmSp caseroot = asmContinuation(bco,cgAlts(root,sp,alts));
 342             cgExpr(bco,caseroot,stgCaseScrut(e));
 343             asmEndCase(bco);
 344             break;
 345         }
 346     case PRIMCASE:
 347         {
 348             StgExpr scrut = stgPrimCaseScrut(e);
 349             List alts = stgPrimCaseAlts(e);
 350             if (whatIs(scrut) == STGPRIM) {  /* this is an optimisation */
 351
 352                 /* No need to use return address or to Slide */
 353                 AsmSp beginPrim = asmBeginPrim(bco);
 354                 map1Proc(pushAtom,bco,reverse(stgPrimArgs(scrut)));
 355                 asmEndPrim(bco,(AsmPrim*)name(stgPrimOp(scrut)).primop,beginPrim);
 356
 357                 for(; nonNull(alts); alts=tl(alts)) {
 358                     StgPrimAlt alt = hd(alts);
 359                     List    pats = stgPrimAltVars(alt);
 360                     StgExpr body = stgPrimAltBody(alt);
 361                     AsmSp altBegin = asmBeginAlt(bco);
 362                     map1Proc(cgBind,bco,reverse(pats));
 363                     testPrimPats(bco,root,pats,body);
 364                     asmEndAlt(bco,altBegin);
 365                 }
 366                 /* if we got this far and didn't match, panic! */
 367                 asmPanic(bco);
 368
 369             } else if (whatIs(scrut) == STGVAR) { /* another optimisation */
 370
 371                 /* No need to use return address or to Slide */
 372
 373                 /* only part different from primop code... todo */
 374                 AsmSp beginCase = asmBeginCase(bco);
 375                 pushVar(bco,scrut);
 376                 asmEndAlt(bco,beginCase); /* hack, hack -  */
 377
 378                 for(; nonNull(alts); alts=tl(alts)) {
 379                     StgPrimAlt alt = hd(alts);
 380                     List    pats = stgPrimAltVars(alt);
 381                     StgExpr body = stgPrimAltBody(alt);
 382                     AsmSp altBegin = asmBeginAlt(bco);
 383                     map1Proc(cgBind,bco,pats);
 384                     testPrimPats(bco,root,pats,body);
 385                     asmEndAlt(bco,altBegin);
 386                 }
 387                 /* if we got this far and didn't match, panic! */
 388                 asmPanic(bco);
 389
 390             } else {
 391                 /* ToDo: implement this code...  */
 392                 assert(0);
 393                 /* asmPushRet(bco,delayPrimAlt( stgPrimCaseVars(e),
 394                                                 stgPrimCaseBody(e))); */
 395                 /* cgExpr( bco,root,scrut ); */
 396             }
 397             break;
 398         }
 399     case STGAPP: /* Tail call */
 400         {
 401             AsmSp env = asmBeginEnter(bco);
 402             map1Proc(pushAtom,bco,reverse(stgAppArgs(e)));
 403             pushAtom(bco,stgAppFun(e));
 404             asmEndEnter(bco,env,root);
 405             break;
 406         }
 407     case NAME: /* Tail call (with no args) */
 408         {
 409             AsmSp env = asmBeginEnter(bco);
 410             pushVar(bco,name(e).stgVar);
 411             asmEndEnter(bco,env,root);
 412             break;
 413         }
 414     case STGVAR: /* Tail call (with no args), plus unboxed return */
 415             switch (repOf(e)) {
 416             case PTR_REP:
 417             case ALPHA_REP:
 418             case BETA_REP:
 419                 {
 420                     AsmSp env = asmBeginEnter(bco);
 421                     pushVar(bco,e);
 422                     asmEndEnter(bco,env,root);
 423                     break;
 424                 }
 425             case INT_REP:
 426                     assert(0);
 427                     /* cgTailCall(bco,singleton(e)); */
 428                     /* asmReturnInt(bco); */
 429                     break;
 430             default:
 431                     internal("cgExpr StgVar");
 432             }
 433             break;
 434     case STGPRIM: /* Tail call again */
 435         {
 436             AsmSp beginPrim = asmBeginPrim(bco);
 437             map1Proc(pushAtom,bco,reverse(stgPrimArgs(e)));
 438             asmEndPrim(bco,(AsmPrim*)name(e).primop,beginPrim);
 439             /* map1Proc(cgBind,bco,rs_vars); */
 440             assert(0); /* asmReturn_retty(); */
 441             break;
 442         }
 443     default:
 444             fprintf(stderr,"\nYoiks: "); printExp(stderr,e);
 445             internal("cgExpr");
 446     }
 447 }
 448
 449 #define M_ITBLNAMES 35000
 450
 451 void* itblNames[M_ITBLNAMES];
 452 int   nItblNames = 0;
 453
 454 /* allocate space for top level variable
 455  * any change requires a corresponding change in 'build'.
 456  */
 457 static Void alloc( AsmBCO bco, StgVar v )
 458 {
 459     StgRhs rhs = stgVarBody(v);
 460     assert(isStgVar(v));
 461     switch (whatIs(rhs)) {
 462     case STGCON:
 463         {
 464             StgDiscr con  = stgConCon(rhs);
 465             List     args = stgConArgs(rhs);
 466             if (isBoxingCon(con)) {
 467                 pushAtom(bco,hd(args));
 468                 setPos(v,asmBox(bco,boxingConRep(con)));
 469             } else {
 470
 471                 void* vv = stgConInfo(con);
 472                 if (!(nItblNames < (M_ITBLNAMES-2)))
 473                    internal("alloc -- M_ITBLNAMES too small");
 474                 if (isName(con)) {
 475                    itblNames[nItblNames++] = vv;
 476                    itblNames[nItblNames++] = textToStr(name(con).text);
 477                 } else
 478                 if (isTuple(con)) {
 479                    char* cc = malloc(10);
 480                    assert(cc);
 481                    sprintf(cc, "Tuple%d", tupleOf(con) );
 482                    itblNames[nItblNames++] = vv;
 483                    itblNames[nItblNames++] = cc;
 484                 } else
 485                 assert ( /* cant identify constructor name */ 0 );
 486
 487                 setPos(v,asmAllocCONSTR(bco, vv));
 488             }
 489             break;
 490         }
 491     case STGAPP: {
 492             Int  totSizeW = 0;
 493             List bs       = stgAppArgs(rhs);
 494             for (; nonNull(bs); bs=tl(bs)) {
 495                if (isName(hd(bs))) {
 496                   totSizeW += 1;
 497                } else {
 498                   ASSERT(whatIs(hd(bs))==STGVAR);
 499                   totSizeW += asmRepSizeW( charOf(stgVarRep(hd(bs))) );
 500                }
 501             }
 502             setPos(v,asmAllocAP(bco,totSizeW));
 503             //ORIGINALLY:setPos(v,asmAllocAP(bco,length(stgAppArgs(rhs))));
 504             break;
 505          }
 506     case LAMBDA: /* optimisation */
 507             setObj(v,cgLambda(rhs));
 508             break;
 509     default:
 510             setPos(v,asmAllocAP(bco,0));
 511             break;
 512     }
 513 }
 514
 515 static Void build( AsmBCO bco, StgVar v )
 516 {
 517     StgRhs rhs = stgVarBody(v);
 518     assert(isStgVar(v));
 519
 520     switch (whatIs(rhs)) {
 521     case STGCON:
 522         {
 523             StgDiscr con  = stgConCon(rhs);
 524             List     args = stgConArgs(rhs);
 525             if (isBoxingCon(con)) {
 526                 doNothing();  /* already done in alloc */
 527             } else {
 528                 AsmSp start = asmBeginPack(bco);
 529                 map1Proc(pushAtom,bco,reverse(args));
 530                 asmEndPack(bco,getPos(v),start,stgConInfo(con));
 531             }
 532             return;
 533         }
 534     case STGAPP:
 535         {
 536             Bool   itsaPAP;
 537             StgVar fun  = stgAppFun(rhs);
 538             StgVar fun0 = fun;
 539             List   args = stgAppArgs(rhs);
 540             if (isName(fun)) {
 541                 if (nonNull(name(fun).stgVar))
 542                    fun = name(fun).stgVar; else
 543                    fun = cptrFromName(fun);
 544             }
 545
 546             if (isCPtr(fun)) {
 547                assert(isName(fun0));
 548                itsaPAP = name(fun0).arity > length(args);
 549 fprintf ( stderr, "nativeCall: name %s, arity %d, args %d\n",
 550                nameFromOPtr(cptrOf(fun)), name(fun0).arity, length(args) );
 551             } else {
 552                itsaPAP = FALSE;
 553                if (nonNull(stgVarBody(fun))
 554                    && whatIs(stgVarBody(fun)) == LAMBDA
 555                    && length(stgLambdaArgs(stgVarBody(fun))) > length(args)
 556                   )
 557                   itsaPAP = TRUE;
 558             }
 559
 560             if (itsaPAP) {
 561                 AsmSp  start = asmBeginMkPAP(bco);
 562                 map1Proc(pushAtom,bco,reverse(args));
 563                 pushAtom(bco,fun);
 564                 asmEndMkPAP(bco,getPos(v),start); /* optimisation */
 565             } else {
 566                 AsmSp  start = asmBeginMkAP(bco);
 567                 map1Proc(pushAtom,bco,reverse(args));
 568                 pushAtom(bco,fun);
 569                 asmEndMkAP(bco,getPos(v),start);
 570             }
 571             return;
 572         }
 573     case LAMBDA: /* optimisation */
 574             doNothing(); /* already pushed in alloc */
 575             break;
 576
 577     /* These two cases look almost identical to the default but they're really
 578      * special cases of STGAPP.  The essential thing here is that we can't call
 579      * cgRhs(rhs) because that expects the rhs to have no free variables when,
 580      * in fact, the rhs is _always_ a free variable.
 581      *
 582      * ToDo: a simple optimiser would eliminate all examples
 583      * of this except "let x = x in ..."
 584      */
 585     case NAME:
 586             rhs = name(rhs).stgVar;
 587     case STGVAR:
 588         {
 589             AsmSp  start = asmBeginMkAP(bco);
 590             pushAtom(bco,rhs);
 591             asmEndMkAP(bco,getPos(v),start);
 592         }
 593         return;
 594     default:
 595         {
 596             AsmSp start = asmBeginMkAP(bco);   /* make it updateable! */
 597             asmClosure(bco,cgRhs(rhs));
 598             asmEndMkAP(bco,getPos(v),start);
 599             return;
 600         }
 601     }
 602 }
 603
 604 /* --------------------------------------------------------------------------
 605  * Top level variables
 606  *
 607  * ToDo: these should be handled by allocating a dynamic unentered CAF
 608  * for each top level variable - this should be simpler!
 609  * ------------------------------------------------------------------------*/
 610
 611 #if 0   /* appears to be unused */
 612 static void cgAddVar( AsmObject obj, StgAtom v )
 613 {
 614     if (isName(v)) {
 615         v = name(v).stgVar;
 616     }
 617     assert(isStgVar(v));
 618     asmAddPtr(obj,getObj(v));
 619 }
 620 #endif
 621
 622
 623 /* allocate AsmObject for top level variables
 624  * any change requires a corresponding change in endTop
 625  */
 626 static void beginTop( StgVar v )
 627 {
 628     StgRhs rhs;
 629     assert(isStgVar(v));
 630     currentTop = v;
 631     rhs = stgVarBody(v);
 632     switch (whatIs(rhs)) {
 633     case STGCON:
 634         {
 635             //List as = stgConArgs(rhs);
 636             setObj(v,asmBeginCon(stgConInfo(stgConCon(rhs))));
 637             break;
 638         }
 639     case LAMBDA:
 640 #ifdef CRUDE_PROFILING
 641             setObj(v,asmBeginBCO(currentTop));
 642 #else
 643             setObj(v,asmBeginBCO(rhs));
 644 #endif
 645             break;
 646     default:
 647             setObj(v,asmBeginCAF());
 648             break;
 649     }
 650 }
 651
 652 static void endTop( StgVar v )
 653 {
 654     StgRhs rhs = stgVarBody(v);
 655     currentTop = v;
 656     switch (whatIs(rhs)) {
 657     case STGCON:
 658         {
 659             List as = stgConArgs(rhs);
 660             AsmCon con = (AsmCon)getObj(v);
 661             for( ; nonNull(as); as=tl(as)) {
 662                 StgAtom a = hd(as);
 663                 switch (whatIs(a)) {
 664                 case STGVAR:
 665                         /* should be a delayed combinator! */
 666                         asmAddPtr(con,(AsmObject)getObj(a));
 667                         break;
 668                 case NAME:
 669                     {
 670                         StgVar var = name(a).stgVar;
 671                         assert(var);
 672                         asmAddPtr(con,(AsmObject)getObj(a));
 673                         break;
 674                     }
 675 #if !USE_ADDR_FOR_STRINGS
 676                 case STRCELL:
 677                         asmAddPtr(con,asmStringObj(textToStr(textOf(a))));
 678                         break;
 679 #endif
 680                 default:
 681                         /* asmAddPtr(con,??); */
 682                         assert(0);
 683                         break;
 684                 }
 685             }
 686             asmEndCon(con);
 687             break;
 688         }
 689     case LAMBDA: /* optimisation */
 690         {
 691             /* ToDo: merge this code with cgLambda */
 692             AsmBCO bco = (AsmBCO)getObj(v);
 693             AsmSp root = asmBeginArgCheck(bco);
 694             map1Proc(cgBind,bco,reverse(stgLambdaArgs(rhs)));
 695             asmEndArgCheck(bco,root);
 696
 697             cgExpr(bco,root,stgLambdaBody(rhs));
 698
 699             asmEndBCO(bco);
 700             break;
 701         }
 702     default:   /* updateable caf */
 703         {
 704             AsmCAF caf = (AsmCAF)getObj(v);
 705             asmEndCAF(caf,cgRhs(rhs));
 706             break;
 707         }
 708     }
 709 }
 710
 711 static void zap( StgVar v )
 712 {
 713   // ToDo: reinstate
 714   //    stgVarBody(v) = NIL;
 715 }
 716
 717 /* external entry point */
 718 Void cgBinds( List binds )
 719 {
 720     List b;
 721     int i;
 722
 723 #if 0
 724     if (lastModule() != modulePrelude) {
 725         printf("\n\ncgBinds: before ll\n\n" );
 726         for (b=binds; nonNull(b); b=tl(b)) {
 727            printStg ( stdout, hd(b) ); printf("\n\n");
 728         }
 729     }
 730 #endif
 731
 732     binds = liftBinds(binds);
 733
 734 #if 0
 735     if (lastModule() != modulePrelude) {
 736         printf("\n\ncgBinds: after ll\n\n" );
 737         for (b=binds; nonNull(b); b=tl(b)) {
 738            printStg ( stdout, hd(b) ); printf("\n\n");
 739         }
 740     }
 741 #endif
 742
 743     for (b=binds,i=0; nonNull(b); b=tl(b),i++) {
 744        beginTop(hd(b));
 745     }
 746
 747     for (b=binds,i=0; nonNull(b); b=tl(b),i++) {
 748       //printf("endTop %s\n", maybeName(hd(b)));
 749        endTop(hd(b));
 750     }
 751
 752     //mapProc(zap,binds);
 753 }
 754
 755 /* --------------------------------------------------------------------------
 756  * Code Generator control:
 757  * ------------------------------------------------------------------------*/
 758
 759 Void codegen(what)
 760 Int what; {
 761     switch (what) {
 762     case INSTALL:
 763             /* deliberate fall though */
 764     case RESET:
 765             break;
 766     case MARK:
 767             break;
 768     }
 769     liftControl(what);
 770 }
 771
 772 /*-------------------------------------------------------------------------*/