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