X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Finterpreter%2Fcodegen.c;h=ef123983909bb5b2b1344456f04d7b4eaae13982;hb=066dbe7804d1e0ca710d996f43628e88e0321be6;hp=9bc719e72e7b570014d4c93173d6bb5d9513b0a3;hpb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;p=ghc-hetmet.git

diff --git a/ghc/interpreter/codegen.c b/ghc/interpreter/codegen.c
index 9bc719e..ef12398 100644
--- a/ghc/interpreter/codegen.c
+++ b/ghc/interpreter/codegen.c
@@ -1,26 +1,28 @@
-/* -*- mode: hugs-c; -*- */
+
 /* --------------------------------------------------------------------------
  * Code generator
  *
- * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
- * All rights reserved. See NOTICE for details and conditions of use etc...
- * Hugs version 1.4, December 1997
+ * 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.2 $
- * $Date: 1998/12/02 13:21:59 $
+ * $Revision: 1.22 $
+ * $Date: 2000/04/12 09:37:19 $
  * ------------------------------------------------------------------------*/
 
-#include "prelude.h"
+#include "hugsbasictypes.h"
 #include "storage.h"
 #include "connect.h"
 #include "errors.h"
-#include "stg.h"
+
 #include "Assembler.h"
-#include "lift.h"
-#include "link.h"
-#include "pp.h"
-#include "codegen.h"
+#include "Rts.h"    /* IF_DEBUG */
+#include "RtsFlags.h"
+
+/*#define DEBUG_CODEGEN*/
 
 /* --------------------------------------------------------------------------
  * Local function prototypes:
@@ -42,16 +44,35 @@ 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 void   cgPrimAlt    ( AsmBCO bco, AsmSp root, List vs, StgExpr e );
 static AsmBCO cgLambda     ( StgExpr e );
 static AsmBCO cgRhs        ( StgRhs rhs );
 static void   beginTop     ( StgVar v );
 static void   endTop       ( StgVar v );
 
+static StgVar currentTop;
+
 /* --------------------------------------------------------------------------
  * 
  * ------------------------------------------------------------------------*/
 
+static Cell 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 mkCPtr(p);
+}
+
 static Bool varHasClosure( StgVar v )
 {
     return asmObjectHasClosure((AsmClosure*)ptrOf(stgVarInfo(v)));
@@ -67,31 +88,20 @@ char* lookupHugsName( void* closure )
 {
     extern Name nameHw;
     Name nm;
-    for( nm=NAMEMIN; nm<nameHw; ++nm ) {
-        StgVar v  = name(nm).stgVar;
-        if (isStgVar(v) 
-            && isPtr(stgVarInfo(v)) 
-            && varHasClosure(v)
-            && closureOfVar(v) == closure) {
-            return textToStr(name(nm).text);
-        }
+    for( nm = NAME_BASE_ADDR; 
+         nm < NAME_BASE_ADDR+tabNameSz; ++nm ) 
+       if (tabName[nm-NAME_BASE_ADDR].inUse) {
+           StgVar v  = name(nm).stgVar;
+           if (isStgVar(v) 
+               && isPtr(stgVarInfo(v)) 
+               && varHasClosure(v)
+               && closureOfVar(v) == closure) {
+               return textToStr(name(nm).text);
+           }
     }
     return 0;
 }
 
-/* called at the start of GC */
-void markHugsObjects( void )
-{
-    extern Name nameHw;
-    Name nm;
-    for( nm=NAMEMIN; nm<nameHw; ++nm ) {
-        StgVar v  = name(nm).stgVar;
-        if (isStgVar(v) && isPtr(stgVarInfo(v))) {
-            asmMarkObject((AsmClosure*)ptrOf(stgVarInfo(v)));
-        }
-    }
-}
-
 static void cgBindRep( AsmBCO bco, StgVar v, AsmRep rep )
 {
     setPos(v,asmBind(bco,rep));
@@ -104,25 +114,48 @@ static void cgBind( AsmBCO bco, StgVar v )
 
 static Void pushVar( AsmBCO bco, StgVar v )
 {
-    Cell info = stgVarInfo(v);
-    assert(isStgVar(v));
-    if (isPtr(info)) {
-        asmClosure(bco,ptrOf(info));
-    } else if (isInt(info)) {
-        asmVar(bco,intOf(info),repOf(v));
+    Cell info;
+#if 0
+printf ( "pushVar:  %d  ", v ); fflush(stdout);
+print(v,10);printf("\n");
+#endif
+    assert(isStgVar(v) || isCPtr(v));
+
+    if (isCPtr(v)) {
+       asmGHCClosure(bco, cptrOf(v));
     } else {
-        internal("pushVar");
-    }        
+       info = stgVarInfo(v);
+       if (isPtr(info)) {
+           asmClosure(bco,ptrOf(info));
+       } else if (isInt(info)) {
+           asmVar(bco,intOf(info),repOf(v));
+       } else {
+           internal("pushVar");
+       }        
+    }
 }
 
 static Void pushAtom( AsmBCO bco, StgAtom e )
 {
+#if 0
+printf ( "pushAtom: %d  ", e ); fflush(stdout);
+print(e,10);printf("\n");
+#endif
     switch (whatIs(e)) {
     case STGVAR: 
             pushVar(bco,e);
             break;
     case NAME: 
-            pushVar(bco,name(e).stgVar);
+            if (nonNull(name(e).stgVar)) {
+	       pushVar(bco,name(e).stgVar);
+            } else {
+               Cell /*CPtr*/ addr = cptrFromName(e);
+#              if DEBUG_CODEGEN
+               fprintf ( stderr, "nativeAtom: name %s\n", 
+                                 nameFromOPtr(cptrOf(addr)) );
+#              endif
+	       pushVar(bco,addr);
+            }
             break;
     case CHARCELL: 
             asmConstChar(bco,charOf(e));
@@ -130,29 +163,12 @@ static Void pushAtom( AsmBCO bco, StgAtom e )
     case INTCELL: 
             asmConstInt(bco,intOf(e));
             break;
-#if BIGNUM_IS_INTEGER
     case BIGCELL:
             asmConstInteger(bco,bignumToString(e)); 
             break;
-#elif BIGNUM_IS_INT64
-    case BIGCELL:
-            asmConstInt64(bco,bignumOf(e)); 
-            break;
-#else
-#warning What is BIGNUM?
-#endif
     case FLOATCELL: 
-#if 0
-            asmConstFloat(bco,e); /* ToDo: support both float and double! */
-#else
             asmConstDouble(bco,floatOf(e));
-#endif
             break;
-#if DOUBLES
-    case DOUBLECELL: 
-            asmConstDouble(bco,doubleOf(e));
-            break;
-#endif
     case STRCELL: 
 #if USE_ADDR_FOR_STRINGS
             asmConstAddr(bco,textToStr(textOf(e)));
@@ -160,35 +176,70 @@ static Void pushAtom( AsmBCO bco, StgAtom e )
             asmClosure(bco,asmStringObj(textToStr(textOf(e))));
 #endif
             break;
+    case CPTRCELL:
+            asmGHCClosure(bco,cptrOf(e));
+            break;
     case PTRCELL: 
             asmConstAddr(bco,ptrOf(e));
             break;
     default: 
-            fprintf(stderr,"\nYoiks: "); printExp(stderr,e);
+            fprintf(stderr,"\nYoiks1: "); printExp(stderr,e);
             internal("pushAtom");
     }
 }
 
 static AsmBCO cgAlts( AsmSp root, AsmSp sp, List alts )
 {
-    AsmBCO bco = asmBeginContinuation(sp);
-    /* ppStgAlts(alts); */
+#ifdef CRUDE_PROFILING
+    AsmBCO bco = asmBeginContinuation(sp, currentTop + 1000000000);
+#else
+    AsmBCO bco = asmBeginContinuation(sp, alts);
+#endif
+    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);
-        StgPat     pat  = stgCaseAltPat(alt);
-        StgExpr    body = stgCaseAltBody(alt);
-        if (isDefaultPat(pat)) {
-            AsmSp      begin = asmBeginAlt(bco);
-            cgBind(bco,pat);
-            cgExpr(bco,root,body);
+        if (isDefaultAlt(alt)) {
+            cgBind(bco,stgDefaultVar(alt));
+            cgExpr(bco,root,stgDefaultBody(alt));
             asmEndContinuation(bco);
             return bco; /* ignore any further alternatives */
         } else {
-            StgDiscr con = stgPatDiscr(pat);
-            List     vs  = stgPatVars(pat);
+            StgDiscr con   = stgCaseAltCon(alt);
+            List     vs    = stgCaseAltVars(alt);
             AsmSp    begin = asmBeginAlt(bco);
-            AsmPc    fix = asmTest(bco,stgDiscrTag(con)); /* ToDo: omit in single constructor types! */
-            cgBind(bco,pat);
+            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 {
@@ -196,9 +247,9 @@ static AsmBCO cgAlts( AsmSp root, AsmSp sp, List alts )
                 map1Proc(cgBind,bco,reverse(vs));
                 asmEndUnpack(bco);
             }
-            cgExpr(bco,root,body);
+            cgExpr(bco,root,stgCaseAltBody(alt));
             asmEndAlt(bco,begin);
-            asmFixBranch(bco,fix);
+            if (fix != -1) asmFixBranch(bco,fix);
         }
     }
     /* if we got this far and didn't match, panic! */
@@ -212,7 +263,7 @@ static void testPrimPats( AsmBCO bco, AsmSp root, List pats, StgExpr e )
     if (isNull(pats)) {
         cgExpr(bco,root,e);
     } else {
-        StgPrimPat pat = hd(pats);
+        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)));
@@ -225,16 +276,10 @@ static void testPrimPats( AsmBCO bco, AsmSp root, List pats, StgExpr e )
     }
 }
 
-static void cgPrimAlt( AsmBCO bco, AsmSp root, List vs, StgExpr e )
-{
-    assert(0); /* ToDo: test for patterns */
-    map1Proc(cgBind,bco,vs); /* ToDo: are these in right order? */
-    cgExpr(bco,root,e);
-}
 
 static AsmBCO cgLambda( StgExpr e )
 {
-    AsmBCO bco = asmBeginBCO();
+    AsmBCO bco = asmBeginBCO(e);
 
     AsmSp root = asmBeginArgCheck(bco);
     map1Proc(cgBind,bco,reverse(stgLambdaArgs(e)));
@@ -249,7 +294,7 @@ static AsmBCO cgLambda( StgExpr e )
 
 static AsmBCO cgRhs( StgRhs rhs )
 {
-    AsmBCO bco = asmBeginBCO( );
+    AsmBCO bco = asmBeginBCO(rhs );
 
     AsmSp root = asmBeginArgCheck(bco);
     asmEndArgCheck(bco,root);
@@ -261,8 +306,12 @@ static AsmBCO cgRhs( StgRhs rhs )
     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:
         {
@@ -301,7 +350,7 @@ static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e )
 
                 for(; nonNull(alts); alts=tl(alts)) {
                     StgPrimAlt alt = hd(alts);
-                    List    pats = stgPrimAltPats(alt);
+                    List    pats = stgPrimAltVars(alt);
                     StgExpr body = stgPrimAltBody(alt);
                     AsmSp altBegin = asmBeginAlt(bco);
                     map1Proc(cgBind,bco,reverse(pats));
@@ -322,7 +371,7 @@ static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e )
 
                 for(; nonNull(alts); alts=tl(alts)) {
                     StgPrimAlt alt = hd(alts);
-                    List    pats = stgPrimAltPats(alt);
+                    List    pats = stgPrimAltVars(alt);
                     StgExpr body = stgPrimAltBody(alt);
                     AsmSp altBegin = asmBeginAlt(bco);
                     map1Proc(cgBind,bco,pats);
@@ -335,7 +384,8 @@ static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e )
             } else {
                 /* ToDo: implement this code...  */
                 assert(0);
-                /* asmPushRet(bco,delayPrimAlt( stgPrimCaseVars(e), stgPrimCaseBody(e))); */
+                /* asmPushRet(bco,delayPrimAlt( stgPrimCaseVars(e), 
+                                                stgPrimCaseBody(e))); */
                 /* cgExpr( bco,root,scrut ); */
             }
             break;
@@ -351,7 +401,8 @@ static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e )
     case NAME: /* Tail call (with no args) */
         {
             AsmSp env = asmBeginEnter(bco);
-            pushVar(bco,name(e).stgVar);
+            /* JRS 000112: next line used to be: pushVar(bco,name(e).stgVar); */
+            pushAtom(bco,e);
             asmEndEnter(bco,env,root);
             break;
         }
@@ -385,7 +436,7 @@ static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e )
             break;
         }
     default:
-            fprintf(stderr,"\nYoiks: "); printExp(stderr,e);
+            fprintf(stderr,"\nYoiks2: "); printExp(stderr,e);
             internal("cgExpr");
     }
 }
@@ -397,6 +448,9 @@ 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:
         {
@@ -410,9 +464,20 @@ static Void alloc( AsmBCO bco, StgVar v )
             }
             break;
         }
-    case STGAPP: 
-            setPos(v,asmAllocAP(bco,length(stgAppArgs(rhs))));
+    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;
@@ -426,6 +491,7 @@ static Void build( AsmBCO bco, StgVar v )
 {
     StgRhs rhs = stgVarBody(v);
     assert(isStgVar(v));
+    //ppStg(v);
     switch (whatIs(rhs)) {
     case STGCON:
         {
@@ -442,14 +508,34 @@ static Void build( AsmBCO bco, StgVar v )
         }
     case STGAPP: 
         {
+            Bool   itsaPAP;
             StgVar fun  = stgAppFun(rhs);
+            StgVar fun0 = fun;
             List   args = stgAppArgs(rhs);
             if (isName(fun)) {
-                fun = name(fun).stgVar;
+                if (nonNull(name(fun).stgVar))
+                   fun = name(fun).stgVar; else
+                   fun = cptrFromName(fun);
+            }
+
+            if (isCPtr(fun)) {
+               assert(isName(fun0));
+               itsaPAP = name(fun0).arity > length(args);
+#              if DEBUG_CODEGEN
+               fprintf ( stderr, "nativeCall: name %s, arity %d, args %d\n",
+                         nameFromOPtr(cptrOf(fun)), name(fun0).arity,
+                         length(args) );
+#              endif
+            } else {
+               itsaPAP = FALSE;
+               if (nonNull(stgVarBody(fun))
+                   && whatIs(stgVarBody(fun)) == LAMBDA 
+                   && length(stgLambdaArgs(stgVarBody(fun))) > length(args)
+                  )
+                  itsaPAP = TRUE;
             }
-            if (nonNull(stgVarBody(fun))
-                && whatIs(stgVarBody(fun)) == LAMBDA 
-                && length(stgLambdaArgs(stgVarBody(fun))) > length(args)) {
+
+            if (itsaPAP) {
                 AsmSp  start = asmBeginMkPAP(bco);
                 map1Proc(pushAtom,bco,reverse(args));
                 pushAtom(bco,fun);
@@ -475,7 +561,10 @@ static Void build( AsmBCO bco, StgVar v )
      * of this except "let x = x in ..."
      */
     case NAME:
-            rhs = name(rhs).stgVar;
+        if (nonNull(name(rhs).stgVar))
+           rhs = name(rhs).stgVar; else
+           rhs = cptrFromName(rhs);
+        /* fall thru */
     case STGVAR:
         {
             AsmSp  start = asmBeginMkAP(bco);
@@ -500,6 +589,7 @@ static Void build( AsmBCO bco, StgVar v )
  * for each top level variable - this should be simpler!
  * ------------------------------------------------------------------------*/
 
+#if 0   /* appears to be unused */
 static void cgAddVar( AsmObject obj, StgAtom v )
 {
     if (isName(v)) {
@@ -508,6 +598,8 @@ static void cgAddVar( AsmObject obj, StgAtom v )
     assert(isStgVar(v));
     asmAddPtr(obj,getObj(v));
 }
+#endif
+
 
 /* allocate AsmObject for top level variables
  * any change requires a corresponding change in endTop
@@ -516,16 +608,21 @@ static void beginTop( StgVar v )
 {
     StgRhs rhs;
     assert(isStgVar(v));
+    currentTop = v;
     rhs = stgVarBody(v);
     switch (whatIs(rhs)) {
     case STGCON:
         {
-            List as = stgConArgs(rhs);
+	    //List as = stgConArgs(rhs);
             setObj(v,asmBeginCon(stgConInfo(stgConCon(rhs))));
             break;
         }
     case LAMBDA:
-            setObj(v,asmBeginBCO());
+#ifdef CRUDE_PROFILING
+            setObj(v,asmBeginBCO(currentTop));
+#else
+            setObj(v,asmBeginBCO(rhs));
+#endif
             break;
     default:
             setObj(v,asmBeginCAF());
@@ -536,7 +633,7 @@ static void beginTop( StgVar v )
 static void endTop( StgVar v )
 {
     StgRhs rhs = stgVarBody(v);
-    ppStgRhs(rhs);
+    currentTop = v;
     switch (whatIs(rhs)) {
     case STGCON:
         {
@@ -594,16 +691,64 @@ static void endTop( StgVar v )
 
 static void zap( StgVar v )
 {
-    stgVarBody(v) = NIL;
+  // ToDo: reinstate
+  //    stgVarBody(v) = NIL;
 }
 
 /* external entry point */
 Void cgBinds( List binds )
 {
+    List b;
+    int i;
+
+#if 0
+    if (lastModule() != modulePrelude) {
+        printf("\n\ncgBinds: before ll\n\n" );
+        for (b=binds; nonNull(b); b=tl(b)) {
+           printStg ( stdout, hd(b) ); printf("\n\n");
+        }
+    }
+#endif
+
     binds = liftBinds(binds);
-    mapProc(beginTop,binds);
-    mapProc(endTop,binds);
-    mapProc(zap,binds);
+
+#if 0
+    if (lastModule() != modulePrelude) {
+        printf("\n\ncgBinds: after ll\n\n" );
+        for (b=binds; nonNull(b); b=tl(b)) {
+           printStg ( stdout, hd(b) ); printf("\n\n");
+        }
+    }
+#endif
+
+    for (b=binds,i=0; nonNull(b); b=tl(b),i++) {
+       /* printStg( stdout, hd(b) ); printf( "\n\n"); */
+       beginTop(hd(b));
+    }
+
+    for (b=binds,i=0; nonNull(b); b=tl(b),i++) {
+       /* printStg( stdout, hd(b) ); printf( "\n\n"); */
+       endTop(hd(b));
+    }
+
+    /* mapProc(zap,binds); */
+}
+
+/* Called by the evaluator's GC to tell Hugs to mark stuff in the
+   run-time heap.
+*/
+void markHugsObjects( void )
+{
+    extern Name nameHw;
+    Name nm;
+    for ( nm = NAME_BASE_ADDR; 
+          nm < NAME_BASE_ADDR+tabNameSz; ++nm )
+       if (tabName[nm-NAME_BASE_ADDR].inUse) {
+           StgVar v  = name(nm).stgVar;
+           if (isStgVar(v) && isPtr(stgVarInfo(v))) {
+               asmMarkObject(ptrOf(stgVarInfo(v)));
+           }
+       }
 }
 
 /* --------------------------------------------------------------------------
@@ -613,12 +758,11 @@ Void cgBinds( List binds )
 Void codegen(what)
 Int what; {
     switch (what) {
-    case INSTALL:
-            /* deliberate fall though */
-    case RESET: 
-            break;
-    case MARK: 
-            break;
+       case PREPREL:
+       case RESET: 
+       case MARK: 
+       case POSTPREL:
+          break;
     }
     liftControl(what);
 }