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