[project @ 1999-10-19 23:51:57 by andy]

Adding a generic version of universal call that
only works for specific argument patterns.

It allows ports to work on the Hugs Prelude immeduately,
even if univeral_call_c_<os/specific> is not ported.

Also, commented out (longstanding?) bug with incorrect call
to setCurrModule.

diff --git a/ghc/interpreter/hugs.c b/ghc/interpreter/hugs.c
index 5a25988..92e8a35 100644 (file)
--- a/ghc/interpreter/hugs.c
+++ b/ghc/interpreter/hugs.c
@@ -9,8 +9,8 @@
  * included in the distribution.
  *
  * $RCSfile: hugs.c,v $
- * $Revision: 1.13 $
- * $Date: 1999/10/15 22:35:04 $
+ * $Revision: 1.14 $
+ * $Date: 1999/10/19 23:51:57 $
  * ------------------------------------------------------------------------*/
 
 #include <setjmp.h>
@@ -1198,7 +1198,13 @@ if (numScripts==namesUpto) ppSmStack( "readscripts-final") ;
 
     { Int  m     = namesUpto-1;
       Text mtext = findText(scriptInfo[m].modName);
-      setCurrModule(mtext);
+      /* Commented out till we understand what
+       * this is trying to do.
+       * Problem, you cant find a module till later.
+       */
+#if 0
+       setCurrModule(findModule(mtext)); 
+#endif
       evalModule = mtext;
     }
 

diff --git a/ghc/interpreter/storage.c b/ghc/interpreter/storage.c
index a0d8ac5..ce11734 100644 (file)
--- a/ghc/interpreter/storage.c
+++ b/ghc/interpreter/storage.c
@@ -9,8 +9,8 @@
  * included in the distribution.
  *
  * $RCSfile: storage.c,v $
- * $Revision: 1.11 $
- * $Date: 1999/10/16 02:17:32 $
+ * $Revision: 1.12 $
+ * $Date: 1999/10/19 23:51:58 $
  * ------------------------------------------------------------------------*/
 
 #include "prelude.h"
@@ -319,10 +319,13 @@ Tycon tc; {
 
 static Void local hashTycon(tc)         /* Insert Tycon into hash table    */
 Tycon tc; {
-    Text  t = tycon(tc).text;
-    Int   h = tHash(t);
-    tycon(tc).nextTyconHash = tyconHash[h];
-    tyconHash[h]            = tc;
+  assert(isTycon(tc));
+   if (1) {
+     Text  t = tycon(tc).text;
+     Int   h = tHash(t);
+     tycon(tc).nextTyconHash = tyconHash[h];
+     tyconHash[h]            = tc;
+   }
 }
 
 Tycon findQualTycon(id) /*locate (possibly qualified) Tycon in tycon table */
@@ -975,6 +978,7 @@ printf ( "findQualifier %s\n", textToStr(t));
 Void setCurrModule(m)              /* set lookup tables for current module */
 Module m; {
     Int i;
+    assert(isModule(m));
     if (m!=currentModule) {
         currentModule = m; /* This is the only assignment to currentModule */
         for (i=0; i<TYCONHSZ; ++i)

diff --git a/ghc/interpreter/version.h b/ghc/interpreter/version.h
index 2834344..25499e9 100644 (file)
--- a/ghc/interpreter/version.h
+++ b/ghc/interpreter/version.h
@@ -2,7 +2,7 @@
  * Version number
  * ------------------------------------------------------------------------*/
 
-/* Define this as a 13 character string uniquely identifying the current 
+/* Define this as a 14 character string uniquely identifying the current 
  * version.
  * Major releases from Nottingham/Yale are of the form "<month><year>"
  * Minor releases from Nottingham/Yale are of the form "[Beta YYMMDD]"
@@ -11,8 +11,8 @@
 #define MAJOR_RELEASE 0
 
 #if MAJOR_RELEASE
-#define HUGS_VERSION "January 1998 "
+#define HUGS_VERSION "October 1999  "
 #else
-#define HUGS_VERSION "STG 27 Apr 99"
+#define HUGS_VERSION "991015 (STG)  "
 #endif
 

diff --git a/ghc/rts/ForeignCall.c b/ghc/rts/ForeignCall.c
index 32946ef..4d881d9 100644 (file)
--- a/ghc/rts/ForeignCall.c
+++ b/ghc/rts/ForeignCall.c
@@ -1,6 +1,6 @@
 
 /* -----------------------------------------------------------------------------
- * $Id: ForeignCall.c,v 1.6 1999/10/19 11:01:26 sewardj Exp $
+ * $Id: ForeignCall.c,v 1.7 1999/10/19 23:52:02 andy Exp $
  *
  * (c) The GHC Team 1994-1999.
  *
@@ -113,6 +113,55 @@ extern StgPtr PopPtr         ( void );
 
 
 /* --------------------------------------------------------------------------
+ * This is a generic version of universal call that
+ * only works for specific argument patterns.
+ * 
+ * It allows ports to work on the Hugs Prelude immeduately,
+ * even if univeral_call_c_<os/specific> is not ported.
+ * ------------------------------------------------------------------------*/
+
+void universal_call_c_x86_generic
+( int   n_args,
+  void* args, 
+  char* argstr, 
+  void* fun )
+{
+   unsigned int *p = (unsigned int*) args;
+
+#define ARG(n)  (p[n*2])
+#define CMP(str) ((n_args + 1 == strlen(str)) && \
+                 (!strncmp(str,argstr,n_args + 1)))
+
+#define CALL(retType,callTypes,callVals) \
+       ((retType(*)callTypes)(fun))callVals
+
+  if (CMP("i")) {
+    int res = CALL(int,(void),());
+    ARG(0) = res;
+  } else if (CMP("ii")) {
+    int arg1 = (int) ARG(1);
+    int res = CALL(int,(int),(arg1));
+    ARG(0) = res;
+  } else if (CMP("iii")) {
+    int arg1 = (int) ARG(1);
+    int arg2 = (int) ARG(2);
+    int res = CALL(int,(int,int),(arg1,arg2));
+    ARG(0) = res;
+  } else {
+    /* Do not have the generic call for this argument list. */
+    int i;
+    printf("Can not call external function at address %d\n",(int)fun);
+    printf("Argument string = '");
+    for(i=0;i<n_args;i++) {
+      printf("%c",(char)argstr[i]);
+    }
+    printf("' [%d arg(s)]\n",n_args);
+    assert(0);
+  }
+#undef CMP
+}
+
+/* --------------------------------------------------------------------------
  * Move args/results between STG stack and the above API's arg block
  * Returns 0 on success
  *         1 if too many args/results or non-handled type
@@ -204,8 +253,13 @@ int ccall ( CFunDescriptor* d, void (*fun)(void), StgBCO** bco )
    //fprintf(stderr, " argc=%d  arg_vec=%p  argd_vec=%p `%s' fun=%p\n", 
    //          d->num_args, arg_vec, argd_vec, argd_vec, fun );
 
+#if 1
    universal_call_c_x86_linux ( 
       d->num_args, (void*)arg_vec, argd_vec, fun );
+#else
+   universal_call_c_x86_generic ( 
+      d->num_args, (void*)arg_vec, argd_vec, fun );
+#endif
    LoadThreadState();
    *bco=(StgBCO*)PopPtr();
 
@@ -252,4 +306,5 @@ CFunDescriptor* mkDescriptor( char* as, char* rs )
     return d;
 }
 
+
 #endif /* INTERPRETER */