[project @ 1999-08-20 13:12:18 by simonpj]

[ghc-hetmet.git] / ghc / interpreter / codegen.c

diff --git a/ghc/interpreter/codegen.c b/ghc/interpreter/codegen.c
index ca9b482..2b87d57 100644 (file)
--- a/ghc/interpreter/codegen.c
+++ b/ghc/interpreter/codegen.c
@@ -7,8 +7,8 @@
  * Hugs version 1.4, December 1997
  *
  * $RCSfile: codegen.c,v $
- * $Revision: 1.6 $
- * $Date: 1999/04/27 10:06:48 $
+ * $Revision: 1.8 $
+ * $Date: 1999/07/06 15:24:36 $
  * ------------------------------------------------------------------------*/
 
 #include "prelude.h"
@@ -54,6 +54,22 @@ 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,"%s_%s_closure", 
+               textToStr(mt), 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)));
@@ -106,15 +122,24 @@ 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 (!(isStgVar(v) || isCPtr(v))) {
+    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 )
@@ -124,7 +149,9 @@ static Void pushAtom( AsmBCO bco, StgAtom e )
             pushVar(bco,e);
             break;
     case NAME: 
-            pushVar(bco,name(e).stgVar);
+            if (nonNull(name(e).stgVar))
+               pushVar(bco,name(e).stgVar); else
+               pushVar(bco,cptrFromName(e));
             break;
     case CHARCELL: 
             asmConstChar(bco,charOf(e));
@@ -154,6 +181,9 @@ 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;
@@ -478,14 +508,31 @@ 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 (nonNull(stgVarBody(fun))
-                && whatIs(stgVarBody(fun)) == LAMBDA 
-                && length(stgLambdaArgs(stgVarBody(fun))) > length(args)) {
+
+            if (isCPtr(fun)) {
+               assert(isName(fun0));
+               itsaPAP = name(fun0).arity > length(args);
+fprintf ( stderr, "nativeCall: name %s, arity %d, args %d\n",
+               nameFromOPtr(cptrOf(fun)), name(fun0).arity, length(args) );
+            } else {
+               itsaPAP = FALSE;
+               if (nonNull(stgVarBody(fun))
+                   && whatIs(stgVarBody(fun)) == LAMBDA 
+                   && length(stgLambdaArgs(stgVarBody(fun))) > length(args)
+                  )
+                  itsaPAP = TRUE;
+            }
+
+            if (itsaPAP) {
                 AsmSp  start = asmBeginMkPAP(bco);
                 map1Proc(pushAtom,bco,reverse(args));
                 pushAtom(bco,fun);