[project @ 2001-02-11 17:51:07 by simonmar]

[ghc-hetmet.git] / ghc / rts / ForeignCall.c

diff --git a/ghc/rts/ForeignCall.c b/ghc/rts/ForeignCall.c
index 5bf75ad..7dc5661 100644 (file)
--- a/ghc/rts/ForeignCall.c
+++ b/ghc/rts/ForeignCall.c
@@ -1,6 +1,6 @@
 
 /* -----------------------------------------------------------------------------
- * $Id: ForeignCall.c,v 1.10 1999/10/26 17:27:30 sewardj Exp $
+ * $Id: ForeignCall.c,v 1.19 2000/10/09 10:28:33 daan Exp $
  *
  * (c) The GHC Team 1994-1999.
  *
@@ -13,6 +13,7 @@
 
 #include "RtsUtils.h"    /* barf :-) */
 #include "Assembler.h"   /* for CFun stuff */
+#include "Schedule.h"
 #include "Evaluator.h"
 #include "ForeignCall.h"
 
@@ -177,7 +178,7 @@ static void universal_call_c_generic
   unsigned int *p = (unsigned int*) args;
 
 #define ARG(n)  (p[n*2])
-#define CMP(str) ((n_args + 1 == strlen(str)) && \
+#define CMP(str) ((n_args + 1 == (int)strlen(str)) && \
                  (!strncmp(str,argstr,n_args + 1)))
 
 #define CALL(retType,callTypes,callVals) \
@@ -204,7 +205,8 @@ static void universal_call_c_generic
       printf("%c",(char)argstr[i]);
     }
     printf("' [%d arg(s)]\n",n_args);
-    assert(0);
+    barf("aborting");
+    ASSERT(0);
   }
 #undef CALL
 #undef CMP
@@ -227,7 +229,8 @@ static void universal_call_c_generic
 int ccall ( CFunDescriptor*  d, 
             void             (*fun)(void), 
             StgBCO**         bco,
-            char             cc
+            char             cc,
+            Capability*      cap
           )
 {
    double         arg_vec [31];
@@ -235,6 +238,7 @@ int ccall ( CFunDescriptor*  d,
    unsigned int*  p;
    int            i;
    unsigned long  ul;
+   unsigned int   token;
 
    if (sizeof(int) != 4 || sizeof(double) != 8 || sizeof(float) != 4
        || (sizeof(void*) != 4 && sizeof(void*) != 8)
@@ -245,7 +249,7 @@ int ccall ( CFunDescriptor*  d,
       return 1; /* unlikely, but ... */
 
    p = (unsigned int*) &arg_vec[1];
-   for (i = 0; i < d->num_args; i++) {
+   for (i = 0; i < (int)(d->num_args); i++) {
       switch (d->arg_tys[i]) {
 
          case INT_REP:
@@ -311,7 +315,9 @@ int ccall ( CFunDescriptor*  d,
    }
  
    PushPtr((StgPtr)(*bco));
-   SaveThreadState();
+   cap->rCurrentTSO->sp    = MainRegTable.rSp;
+   cap->rCurrentTSO->su    = MainRegTable.rSu;
+   token = suspendThread(cap);
 
 #if i386_TARGET_ARCH
    if (cc == 'c')
@@ -325,7 +331,10 @@ int ccall ( CFunDescriptor*  d,
    universal_call_c_generic ( 
       d->num_args, (void*)arg_vec, argd_vec, fun );
 #endif
-   LoadThreadState();
+
+   cap = resumeThread(token);
+   MainRegTable.rSp    = cap->rCurrentTSO->sp;
+   MainRegTable.rSu    = cap->rCurrentTSO->su;
    *bco=(StgBCO*)PopPtr();
 
    /* INT, WORD, ADDR, STABLE don't need to do a word-size check
@@ -375,8 +384,8 @@ int ccall ( CFunDescriptor*  d,
 /* Make it possible for the evaluator to get hold of bytecode
    for a given function by name.  Useful but a hack.  Sigh.
  */
-extern void* getHugs_AsmObject_for ( char* s );
-
+extern void* /* StgClosure* */ getHugs_BCO_cptr_for ( char* s );
+extern int /*Bool*/ combined;
 
 /* ----------------------------------------------------------------*
  * The implementation for x86_ccall and x86_stdcall.
@@ -420,7 +429,7 @@ unpackArgsAndCallHaskell_x86_nocallconv_wrk ( StgStablePtr stableptr,
    while (*argp) {
       switch (*argp) {
          case CHAR_REP:
-            node = rts_apply ( node, rts_mkChar ( *(char*)args ) );
+            node = rts_apply ( node, rts_mkChar ( *(unsigned int*)args ) );
             args += 4;
             break;
          case INT_REP:
@@ -455,11 +464,15 @@ unpackArgsAndCallHaskell_x86_nocallconv_wrk ( StgStablePtr stableptr,
       argp++;
    }
 
-   node = rts_apply ( 
-             asmClosureOfObject(getHugs_AsmObject_for("primRunST")), 
-             node );
+   if (combined) {
+      sstat = rts_evalIO ( node, &nodeOut );
+   } else {
+      node = rts_apply ( 
+                getHugs_BCO_cptr_for("runST"), 
+                node );
+      sstat = rts_eval ( node, &nodeOut );
+   }
 
-   sstat = rts_eval ( node, &nodeOut );
    if (sstat != Success)
       barf ("unpackArgsAndCallHaskell_x86_nocallconv: eval failed");
 
@@ -509,10 +522,10 @@ unpackArgsAndCallHaskell_x86_nocallconv_INTISH (
       StgStablePtr stableptr, char* tydesc, char* args
    )
 {
-   HaskellObj nodeOut
-      = unpackArgsAndCallHaskell_x86_nocallconv_wrk ( 
-           stableptr, tydesc, args 
-        );
+   HaskellObj nodeOut;
+   nodeOut = unpackArgsAndCallHaskell_x86_nocallconv_wrk ( 
+                stableptr, tydesc, args 
+             );
    /* A complete hack.  We know that all these returns will be
       put into %eax (and %edx, if it is a 64-bit return), and
       the adjustor thunk will then itself return to the original
@@ -672,7 +685,7 @@ StgAddr createAdjThunk ( StgStablePtr stableptr,
       createAdjThunk_x86 ( stableptr, typestr, callconv );
 #else
       0;
-      #warn foreign export not implemented on this architecture
+#warning foreign export not implemented on this architecture
 #endif
 }