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