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