path: root/ghc/interpreter/codegen.c

/* --------------------------------------------------------------------------
 * Code generator
 *
 * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
 * Yale Haskell Group, and the Oregon Graduate Institute of Science and
 * Technology, 1994-1999, All rights reserved.  It is distributed as
 * free software under the license in the file "License", which is
 * included in the distribution.
 *
 * $RCSfile: codegen.c,v $
 * $Revision: 1.24 $
 * $Date: 2000/05/10 09:00:20 $
 * ------------------------------------------------------------------------*/

#include "hugsbasictypes.h"
#include "storage.h"
#include "connect.h"
#include "errors.h"

#include "Rts.h"       /* to make StgPtr visible in Assembler.h */
#include "Assembler.h"
#include "RtsFlags.h"

/*#define DEBUG_CODEGEN*/

/*  (JRS, 27 Apr 2000):

A total rewrite of the BCO assembler/linker, and rationalisation of
the code management and code generation phases of Hugs.

Problems with the old linker:

* Didn't have a clean way to insert a pointer to GHC code into a BCO.
  This meant CAF GC didn't work properly in combined mode.

* Leaked memory.  Each BCO, caf and constructor generated by Hugs had
  a corresponding malloc'd record used in its construction.  These
  records existed forever.  Pointers from the Hugs symbol tables into
  the runtime heap always went via these intermediates, for no apparent
  reason.

* A global variable holding a list of top-level stg trees was used
  during code generation.  It was hard to associate trees in this
  list with entries in the name/tycon tables.  Just too many
  mechanisms.

The New World Order is as follows:

* The global code list (stgGlobals) is gone.

* Each name in the name table has a .closure field.  This points
  to the top-level code for that name.  Before bytecode generation
  this points to a STG tree.  During bytecode generation but before
  bytecode linking it is a MPtr pointing to a malloc'd intermediate
  structure (an AsmObject).  After linking, it is a real live pointer
  into the execution heap (CPtr) which is treated as a root during GC.

  Because tuples do not have name table entries, tycons which are
  tuples also have a .closure field, which is treated identically
  to those of name table entries.

* Each module has a code list -- a list of names and tuples.  If you
  are a name or tuple and you have something (code, CAF or Con) which
  needs to wind up in the execution heap, you MUST be on your module's
  code list.  Otherwise you won't get code generated.

* Lambda lifting generates new name table entries, which of course
  also wind up on the code list.

* The initial phase of code generation for a module m traverses m's
  code list.  The stg trees referenced in the .closure fields are
  code generated, creating AsmObject (AsmBCO, AsmCAF, AsmCon) in
  mallocville.  The .closure fields then point to these AsmObjects.
  Since AsmObjects can be mutually recursive, they can contain
  references to:
     * Other AsmObjects            Asm_RefObject
     * Existing closures           Asm_RefNoOp
     * name/tycon table entries    Asm_RefHugs
  AsmObjects can also contain BCO insns and non-ptr words.

* A second copy-and-link phase copies the AsmObjects into the
  execution heap, resolves the Asm_Ref* items, and frees up
  the malloc'd entities.

* Minor cleanups in compile-time storage.  There are now 3 kinds of
  address-y things available:
     CPtr/mkCPtr/cptrOf    -- ptrs to Closures, probably in exec heap
                              ie anything which the exec GC knows about
     MPtr/mkMPtr/mptrOf    -- ptrs to mallocville, which the exec GC
                              knows nothing about
     Addr/mkAddr/addrOf    -- literal addresses (like literal ints)

* Many hacky cases removed from codegen.c.  Referencing code or
  data during code generation is a lot simpler, since an entity
  is either:
      a CPtr, in which case use it as is
      a MPtr -- stuff it into the AsmObject and the linker will fix it
      a name or tycon
             -- ditto

* I've checked, using Purify that, at least in standalone mode,
  no longer leaks mallocd memory.  Prior to this it would leak at
  the rate of about 300k per Prelude.

Still to do:

* Reinstate peephole optimisation for BCOs.

* Nuke magic number headers in AsmObjects, used for debugging.

* Profile and accelerate.  Code generation is slower because linking
  is slower.  Evaluation GC is slower because markHugsObjects has
  slowed down.

* Make setCurrentModule ignore name table entries created by the
  lambda-lifter.
*/


/* --------------------------------------------------------------------------
 * Local function prototypes:
 * ------------------------------------------------------------------------*/

#define getPos(v)     intOf(stgVarInfo(v))
#define setPos(v,sp)  stgVarInfo(v) = mkInt(sp)
#define getObj(v)     mptrOf(stgVarInfo(v))
#define setObj(v,obj) stgVarInfo(v) = mkMPtr(obj)

#define repOf(x)      charOf(stgVarRep(x))

static void      cgBind       ( AsmBCO bco, StgVar v );
static Void      pushAtom     ( AsmBCO bco, StgAtom atom );
static Void      alloc        ( AsmBCO bco, StgRhs rhs );
static Void      build        ( AsmBCO bco, StgRhs rhs );
static Void      cgExpr       ( AsmBCO bco, AsmSp root, StgExpr e );
             
static AsmBCO    cgAlts       ( AsmSp root, AsmSp sp, List alts );
static void      testPrimPats ( AsmBCO bco, AsmSp root, List pats, StgExpr e );
static AsmBCO    cgLambda     ( StgExpr e );
static AsmBCO    cgRhs        ( StgRhs rhs );
static void      beginTop     ( StgVar v );
static AsmObject endTop       ( StgVar v );

static StgVar currentTop;

/* --------------------------------------------------------------------------
 * 
 * ------------------------------------------------------------------------*/

static void* /* StgClosure*/ cptrFromName ( Name n )
{
   char  buf[1000];
   void* p;
   Module m = name(n).mod;
   Text  mt = module(m).text;
   sprintf(buf, MAYBE_LEADING_UNDERSCORE_STR("%s_%s_closure"), 
                textToStr(mt), 
                textToStr( enZcodeThenFindText ( 
                   textToStr (name(n).text) ) ) );
   p = lookupOTabName ( m, buf );
   if (!p) {
      ERRMSG(0) "Can't find object symbol %s", buf
      EEND;
   }
   return p;
}

char* lookupHugsName( void* closure )
{
    extern Name nameHw;
    Name nm;
    for( nm = NAME_BASE_ADDR; 
         nm < NAME_BASE_ADDR+tabNameSz; ++nm ) 
       if (tabName[nm-NAME_BASE_ADDR].inUse) {
           Cell cl = name(nm).closure;
           if (isCPtr(cl) && cptrOf(cl) == closure)
               return textToStr(name(nm).text);
    }
    return NULL;
}

static void cgBindRep( AsmBCO bco, StgVar v, AsmRep rep )
{
    setPos(v,asmBind(bco,rep));
}

static void cgBind( AsmBCO bco, StgVar v )
{
    cgBindRep(bco,v,repOf(v));
}

static void cgAddPtrToObject ( AsmObject obj, Cell ptrish )
{
   switch (whatIs(ptrish)) {
      case CPTRCELL:
         asmAddRefNoOp ( obj, (StgPtr)cptrOf(ptrish) ); break;
      case MPTRCELL:
         asmAddRefObject ( obj, mptrOf(ptrish) ); break;
      default:
         internal("cgAddPtrToObject");
   }
}

/* Get a pointer to atom e onto the stack. */
static Void pushAtom ( AsmBCO bco, StgAtom e )
{
    Cell info;
    Cell cl;
#   if 0
    printf ( "pushAtom: %d  ", e ); fflush(stdout);
    print(e,10);printf("\n");
#   endif
    switch (whatIs(e)) {
       case STGVAR:
           info = stgVarInfo(e);
           if (isInt(info)) {
              asmVar(bco,intOf(info),repOf(e));
           }
           else
           if (isCPtr(info)) { 
              asmPushRefNoOp(bco,cptrOf(info));
           }
           else
           if (isMPtr(info)) { 
              asmPushRefObject(bco,mptrOf(info));
           }
           else {
              internal("pushAtom: STGVAR");
           }
           break;
       case NAME:
       case TUPLE:
            cl = getNameOrTupleClosure(e);
            if (isStgVar(cl)) {
               /* a stg tree which hasn't yet been translated */
               asmPushRefHugs(bco,e);
            }
            else
            if (isCPtr(cl)) {
               /* a pointer to something in the heap */
               asmPushRefNoOp(bco,(StgPtr)cptrOf(cl));
            } 
            else
            if (isMPtr(cl)) {
               /* a pointer to an AsmBCO/AsmCAF/AsmCon object */
               asmPushRefObject(bco,mptrOf(cl));
            }
            else {
               StgClosure* addr; 
               ASSERT(isNull(cl));
               addr = cptrFromName(e);
#              if DEBUG_CODEGEN
               fprintf ( stderr, "nativeAtom: name %s\n", 
                                 nameFromOPtr(addr) );
#              endif
	       asmPushRefNoOp(bco,(StgPtr)addr);
            }
            break;
       case CHARCELL: 
            asmConstChar(bco,charOf(e));
            break;
       case INTCELL: 
            asmConstInt(bco,intOf(e));
            break;
       case ADDRCELL: 
            asmConstAddr(bco,addrOf(e));
            break;
       case BIGCELL:
            asmConstInteger(bco,bignumToString(e)); 
            break;
       case FLOATCELL: 
            asmConstDouble(bco,floatOf(e));
            break;
       case STRCELL: 
#           if USE_ADDR_FOR_STRINGS
            asmConstAddr(bco,textToStr(textOf(e)));
#           else
            asmClosure(bco,asmStringObj(textToStr(textOf(e))));
#           endif
            break;
       case CPTRCELL:
            asmPushRefNoOp(bco,cptrOf(e));
            break;
       case MPTRCELL: 
            asmPushRefObject(bco,mptrOf(e));
            break;
       default: 
            fprintf(stderr,"\nYoiks1: "); printExp(stderr,e);
            internal("pushAtom");
    }
}

static AsmBCO cgAlts( AsmSp root, AsmSp sp, List alts )
{
    AsmBCO bco = asmBeginContinuation(sp, alts);
    Bool omit_test
       = length(alts) == 2 &&
         isDefaultAlt(hd(tl(alts))) &&
         !isDefaultAlt(hd(alts));
    if (omit_test) {
       /* refine the condition */              
       Name con;
       Tycon t;
       omit_test = FALSE;
       con = stgCaseAltCon(hd(alts));

       /* special case: dictionary constructors */
       if (isName(con) && strncmp(":D",textToStr(name(con).text),2)==0) {
          omit_test = TRUE;
          goto xyzzy;
       }
       /* special case: Tuples */
       if (isTuple(con) || (isName(con) && con==nameUnit)) {
          omit_test = TRUE;
          goto xyzzy;
       }          

       t = name(con).parent;
       if (tycon(t).what == DATATYPE) {
          if (length(tycon(t).defn) == 1) omit_test = TRUE;
       }
    }

    xyzzy:

    for(; nonNull(alts); alts=tl(alts)) {
        StgCaseAlt alt  = hd(alts);
        if (isDefaultAlt(alt)) {
            cgBind(bco,stgDefaultVar(alt));
            cgExpr(bco,root,stgDefaultBody(alt));
            asmEndContinuation(bco);
            return bco; /* ignore any further alternatives */
        } else {
            StgDiscr con   = stgCaseAltCon(alt);
            List     vs    = stgCaseAltVars(alt);
            AsmSp    begin = asmBeginAlt(bco);
            AsmPc    fix;
            if (omit_test) fix=-1; else fix = asmTest(bco,stgDiscrTag(con)); 

	    asmBind(bco,PTR_REP); /* Adjust simulated sp to acct for return value */
            if (isBoxingCon(con)) {
                setPos(hd(vs),asmUnbox(bco,boxingConRep(con)));
            } else {
                asmBeginUnpack(bco);
                map1Proc(cgBind,bco,reverse(vs));
                asmEndUnpack(bco);
            }
            cgExpr(bco,root,stgCaseAltBody(alt));
            asmEndAlt(bco,begin);
            if (fix != -1) asmFixBranch(bco,fix);
        }
    }
    /* if we got this far and didn't match, panic! */
    asmPanic(bco);
    asmEndContinuation(bco);
    return bco;
}

static void testPrimPats( AsmBCO bco, AsmSp root, List pats, StgExpr e )
{
    if (isNull(pats)) {
        cgExpr(bco,root,e);
    } else {
        StgVar pat = hd(pats);
        if (isInt(stgVarBody(pat))) {
            /* asmTestInt leaves stack unchanged - so no need to adjust it */
            AsmPc tst = asmTestInt(bco,getPos(pat),intOf(stgVarBody(pat)));
            assert(repOf(pat) == INT_REP);
            testPrimPats(bco,root,tl(pats),e);
            asmFixBranch(bco,tst);
        } else {
            testPrimPats(bco,root,tl(pats),e);
        }
    }
}


static AsmBCO cgLambda( StgExpr e )
{
    AsmBCO bco = asmBeginBCO(e);

    AsmSp root = asmBeginArgCheck(bco);
    map1Proc(cgBind,bco,reverse(stgLambdaArgs(e)));
    asmEndArgCheck(bco,root);

    /* ppStgExpr(e); */
    cgExpr(bco,root,stgLambdaBody(e));

    asmEndBCO(bco);
    return bco;
}

static AsmBCO cgRhs( StgRhs rhs )
{
    AsmBCO bco = asmBeginBCO(rhs );

    AsmSp root = asmBeginArgCheck(bco);
    asmEndArgCheck(bco,root);

    /* ppStgExpr(rhs); */
    cgExpr(bco,root,rhs);

    asmEndBCO(bco);
    return bco;
}


static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e )
{
#if 0
    printf("cgExpr:");ppStgExpr(e);printf("\n");
#endif
    switch (whatIs(e)) {
    case LETREC:
        {
            List binds = stgLetBinds(e);
            map1Proc(alloc,bco,binds);
            map1Proc(build,bco,binds);
            cgExpr(bco,root,stgLetBody(e));
            break;
        }
    case LAMBDA:
        {
            AsmSp begin = asmBeginEnter(bco);
            asmPushRefObject(bco,cgLambda(e));
            asmEndEnter(bco,begin,root);
            break;
        }
    case CASE:
        {
            List  alts     = stgCaseAlts(e);
            AsmSp sp       = asmBeginCase(bco);
            AsmSp caseroot = asmContinuation(bco,cgAlts(root,sp,alts));
            cgExpr(bco,caseroot,stgCaseScrut(e));
            asmEndCase(bco);
            break;
        }
    case PRIMCASE:
        {
            StgExpr scrut = stgPrimCaseScrut(e);
            List alts = stgPrimCaseAlts(e);
            if (whatIs(scrut) == STGPRIM) {  /* this is an optimisation */

                /* No need to use return address or to Slide */
                AsmSp beginPrim = asmBeginPrim(bco);
                map1Proc(pushAtom,bco,reverse(stgPrimArgs(scrut)));
                asmEndPrim(bco,(AsmPrim*)name(stgPrimOp(scrut)).primop,beginPrim);

                for(; nonNull(alts); alts=tl(alts)) {
                    StgPrimAlt alt = hd(alts);
                    List    pats = stgPrimAltVars(alt);
                    StgExpr body = stgPrimAltBody(alt);
                    AsmSp altBegin = asmBeginAlt(bco);
                    map1Proc(cgBind,bco,reverse(pats));
                    testPrimPats(bco,root,pats,body);
                    asmEndAlt(bco,altBegin);
                }
                /* if we got this far and didn't match, panic! */
                asmPanic(bco);
                
            } else if (whatIs(scrut) == STGVAR) { /* another optimisation */

                /* No need to use return address or to Slide */

                /* only part different from primop code... todo */
                AsmSp beginCase = asmBeginCase(bco);
                pushAtom /*pushVar*/ (bco,scrut);
                asmEndAlt(bco,beginCase); /* hack, hack -  */

                for(; nonNull(alts); alts=tl(alts)) {
                    StgPrimAlt alt = hd(alts);
                    List    pats = stgPrimAltVars(alt);
                    StgExpr body = stgPrimAltBody(alt);
                    AsmSp altBegin = asmBeginAlt(bco);
                    map1Proc(cgBind,bco,pats);
                    testPrimPats(bco,root,pats,body);
                    asmEndAlt(bco,altBegin);
                }
                /* if we got this far and didn't match, panic! */
                asmPanic(bco);
                                
            } else {
                /* ToDo: implement this code...  */
                assert(0);
                /* asmPushRet(bco,delayPrimAlt( stgPrimCaseVars(e), 
                                                stgPrimCaseBody(e))); */
                /* cgExpr( bco,root,scrut ); */
            }
            break;
        }
    case STGAPP: /* Tail call */
        {
            AsmSp env = asmBeginEnter(bco);
            map1Proc(pushAtom,bco,reverse(stgAppArgs(e)));
            pushAtom(bco,stgAppFun(e));
            asmEndEnter(bco,env,root);
            break;
        }
    case TUPLE:
    case NAME: /* Tail call (with no args) */
        {
            AsmSp env = asmBeginEnter(bco);
            /* JRS 000112: next line used to be: pushVar(bco,name(e).stgVar); */
            pushAtom(bco,e);
            asmEndEnter(bco,env,root);
            break;
        }
    case STGVAR: /* Tail call (with no args), plus unboxed return */
            switch (repOf(e)) {
            case PTR_REP:
            case ALPHA_REP:
            case BETA_REP:
                {
                    AsmSp env = asmBeginEnter(bco);
                    pushAtom /*pushVar*/ (bco,e);
                    asmEndEnter(bco,env,root);
                    break;
                }
            case INT_REP:
                    assert(0);
                    /* cgTailCall(bco,singleton(e)); */
                    /* asmReturnInt(bco); */
                    break;
            default:
                    internal("cgExpr StgVar");
            }
            break;
    case STGPRIM: /* Tail call again */
        {
            AsmSp beginPrim = asmBeginPrim(bco);
            map1Proc(pushAtom,bco,reverse(stgPrimArgs(e)));
            asmEndPrim(bco,(AsmPrim*)name(e).primop,beginPrim);
            /* map1Proc(cgBind,bco,rs_vars); */
            assert(0); /* asmReturn_retty(); */
            break;
        }
    default:
            fprintf(stderr,"\nYoiks2: "); printExp(stderr,e);
            internal("cgExpr");
    }
}

/* allocate space for top level variable
 * any change requires a corresponding change in 'build'.
 */
static Void alloc( AsmBCO bco, StgVar v )
{
    StgRhs rhs = stgVarBody(v);
    assert(isStgVar(v));
#if 0
    printf("alloc: ");ppStgExpr(v);
#endif
    switch (whatIs(rhs)) {
    case STGCON:
        {
            StgDiscr con  = stgConCon(rhs);
            List     args = stgConArgs(rhs);
            if (isBoxingCon(con)) {
                pushAtom(bco,hd(args));
                setPos(v,asmBox(bco,boxingConRep(con)));
            } else {
                setPos(v,asmAllocCONSTR(bco,stgConInfo(con)));
            }
            break;
        }
    case STGAPP: {
            Int  totSizeW = 0;
            List bs       = stgAppArgs(rhs);
            for (; nonNull(bs); bs=tl(bs)) {
               if (isName(hd(bs))) {
                  totSizeW += 1;
               } else {
                  ASSERT(whatIs(hd(bs))==STGVAR);
                  totSizeW += asmRepSizeW( charOf(stgVarRep(hd(bs))) );
               }
            }
            setPos(v,asmAllocAP(bco,totSizeW));
            break;
         }
    case LAMBDA: /* optimisation */
            setObj(v,cgLambda(rhs));
            break;
    default: 
            setPos(v,asmAllocAP(bco,0));
            break;
    }
}

static Void build( AsmBCO bco, StgVar v )
{
    StgRhs rhs = stgVarBody(v);
    assert(isStgVar(v));
    //ppStg(v);
    switch (whatIs(rhs)) {
    case STGCON:
        {
            StgDiscr con  = stgConCon(rhs);
            List     args = stgConArgs(rhs);
            if (isBoxingCon(con)) {
                doNothing();  /* already done in alloc */
            } else {
                AsmSp start = asmBeginPack(bco);
                map1Proc(pushAtom,bco,reverse(args));
                asmEndPack(bco,getPos(v),start,stgConInfo(con));
            }
            return;
        }
    case STGAPP: 
        {
            Bool   itsaPAP;
            StgVar fun  = stgAppFun(rhs);
            List   args = stgAppArgs(rhs);

            if (isName(fun)) {
               itsaPAP = name(fun).arity > length(args);
            } else
            if (isStgVar(fun)) {
               itsaPAP = FALSE;
               if (nonNull(stgVarBody(fun))
                   && whatIs(stgVarBody(fun)) == LAMBDA 
                   && length(stgLambdaArgs(stgVarBody(fun))) > length(args)
                  )
                  itsaPAP = TRUE;
            }
            else
               internal("build: STGAPP");

            if (itsaPAP) {
                AsmSp  start = asmBeginMkPAP(bco);
                map1Proc(pushAtom,bco,reverse(args));
                pushAtom(bco,fun);
                asmEndMkPAP(bco,getPos(v),start); /* optimisation */
            } else {
                AsmSp  start = asmBeginMkAP(bco);
                map1Proc(pushAtom,bco,reverse(args));
                pushAtom(bco,fun);
                asmEndMkAP(bco,getPos(v),start);
            }
            return;
        }
    case LAMBDA: /* optimisation */
            doNothing(); /* already pushed in alloc */
            break;

    /* These two cases look almost identical to the default but they're really
     * special cases of STGAPP.  The essential thing here is that we can't call
     * cgRhs(rhs) because that expects the rhs to have no free variables when, 
     * in fact, the rhs is _always_ a free variable.
     *
     * ToDo: a simple optimiser would eliminate all examples
     * of this except "let x = x in ..."
     */
    case NAME:
    case STGVAR:
        {
            AsmSp  start = asmBeginMkAP(bco);
            pushAtom(bco,rhs);
            asmEndMkAP(bco,getPos(v),start);
        }
        return;
    default:
        {
            AsmSp start = asmBeginMkAP(bco);   /* make it updateable! */
            asmPushRefObject(bco,cgRhs(rhs));
            asmEndMkAP(bco,getPos(v),start);
            return;
        }
    }
}

/* --------------------------------------------------------------------------
 * Top level variables
 *
 * ToDo: these should be handled by allocating a dynamic unentered CAF
 * for each top level variable - this should be simpler!
 * ------------------------------------------------------------------------*/

/* allocate AsmObject for top level variables
 * any change requires a corresponding change in endTop
 */
static void beginTop( StgVar v )
{
    StgRhs rhs;
    assert(isStgVar(v));
    currentTop = v;
    rhs = stgVarBody(v);
    switch (whatIs(rhs)) {
       case STGCON:
          setObj(v,asmBeginCon(stgConInfo(stgConCon(rhs))));
          break;
       case LAMBDA:
          setObj(v,asmBeginBCO(rhs));
          break;
       default:
          setObj(v,asmBeginCAF());
          break;
    }
}

static AsmObject endTop( StgVar v )
{
    StgRhs rhs = stgVarBody(v);
    currentTop = v;
    switch (whatIs(rhs)) {
       case STGCON: {
          List as = stgConArgs(rhs);
          AsmCon con = (AsmCon)getObj(v);
          for ( ; nonNull(as); as=tl(as)) {
             StgAtom a = hd(as);
             switch (whatIs(a)) {
                case STGVAR: 
                   /* should be a delayed combinator! */
                   asmAddRefObject(con,(AsmObject)getObj(a));
                   break;
                case NAME: {
                   StgVar var = name(a).closure;
                   cgAddPtrToObject(con,var);
                   break;
                }
#               if !USE_ADDR_FOR_STRINGS
                case STRCELL:
                   asmAddPtr(con,asmStringObj(textToStr(textOf(a))));
                   break;
#               endif
                default: 
                   /* asmAddPtr(con,??); */
                   assert(0);
                   break;
             }
          }
          asmEndCon(con);
          return con;
       }
       case LAMBDA: { /* optimisation */
          /* ToDo: merge this code with cgLambda */
          AsmBCO bco = (AsmBCO)getObj(v);
          AsmSp root = asmBeginArgCheck(bco);
          map1Proc(cgBind,bco,reverse(stgLambdaArgs(rhs)));
          asmEndArgCheck(bco,root);
            
          cgExpr(bco,root,stgLambdaBody(rhs));
         
          asmEndBCO(bco);
          return bco;
       }
       default: {  /* updateable caf */
          AsmCAF caf = (AsmCAF)getObj(v);
          asmAddRefObject ( caf, cgRhs(rhs) );
          asmEndCAF(caf);
          return caf;
       }
    }
}


/* --------------------------------------------------------------------------
 * The external entry points for the code generator.
 * ------------------------------------------------------------------------*/

Void cgModule ( Module mod )
{
    List cl;
    Cell c;
    int i;

    /* Lambda-lift, by traversing the code list of this module.  
       This creates more name-table entries, which are duly added
       to the module's code list.
    */
    liftModule ( mod );

    /* Initialise the BCO linker subsystem. */
    asmInitialise();

    /* Generate BCOs, CAFs and Constructors into mallocville.  
       At this point, the .closure values of the names/tycons on
       the codelist contain StgVars, ie trees.  The call to beginTop
       converts them to MPtrs to AsmObjects.
    */
    for (cl=module(mod).codeList; nonNull(cl); cl=tl(cl)) {
       c = getNameOrTupleClosure(hd(cl));
       if (isCPtr(c)) continue;
#      if 0
       if (isName(hd(cl))) {
          printStg( stdout, name(hd(cl)).closure ); printf( "\n\n"); 
       }
#      endif
       beginTop ( c );
    }

    for (cl=module(mod).codeList; nonNull(cl); cl=tl(cl)) {
       c = getNameOrTupleClosure(hd(cl));
       if (isCPtr(c)) continue;
#      if 0
       if (isName(hd(cl))) {
          printStg( stdout, name(hd(cl)).closure ); printf( "\n\n"); 
       }
#      endif
       setNameOrTupleClosure ( hd(cl), mkMPtr(endTop(c)) );
    }

    //fprintf ( stderr, "\nstarting sanity check\n" );
    for (cl = module(mod).codeList; nonNull(cl); cl=tl(cl)) {
       Cell c = hd(cl);
       ASSERT(isName(c) || isTuple(c));
       c = getNameOrTupleClosure(c);
       ASSERT(isMPtr(c) || isCPtr(c));
    }
    //fprintf ( stderr, "completed sanity check\n" );


    /* Figure out how big each object will be in the evaluator's heap,
       and allocate space to put each in, but don't copy yet.  Record
       the heap address in the object.  Assumes that GC doesn't happen;
       reasonable since we use allocate().
    */
    asmAllocateHeapSpace();

    /* Update name/tycon table closure entries with these new heap addrs. */
    for (cl = module(mod).codeList; nonNull(cl); cl=tl(cl)) {
       c = getNameOrTupleClosure(hd(cl));
       if (isMPtr(c))
          setNameOrTupleClosureCPtr ( 
             hd(cl), asmGetClosureOfObject(mptrOf(c)) );
    }

    /* Copy out of mallocville into the heap, resolving references on
       the way.
    */
    asmCopyAndLink();

    /* Free up the malloc'd memory. */
    asmShutdown();
}


/* --------------------------------------------------------------------------
 * Code Generator control:
 * ------------------------------------------------------------------------*/

Void codegen(what)
Int what; {
    switch (what) {
       case PREPREL:
       case RESET: 
       case MARK: 
       case POSTPREL:
          break;
    }
    liftControl(what);
}

/*-------------------------------------------------------------------------*/