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