[project @ 2000-04-24 22:05:08 by panne]

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

diff --git a/ghc/rts/ForeignCall.c b/ghc/rts/ForeignCall.c
index 5bf75ad..38158ce 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.14 2000/04/11 16:49:20 sewardj 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) \
@@ -227,7 +228,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 +237,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 +248,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 +314,10 @@ int ccall ( CFunDescriptor*  d,
    }
  
    PushPtr((StgPtr)(*bco));
-   SaveThreadState();
+   cap->rCurrentTSO->sp    = MainRegTable.rSp;
+   cap->rCurrentTSO->su    = MainRegTable.rSu;
+   cap->rCurrentTSO->splim = MainRegTable.rSpLim;
+   token = suspendThread(cap);
 
 #if i386_TARGET_ARCH
    if (cc == 'c')
@@ -325,7 +331,11 @@ 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;
+   MainRegTable.rSpLim = cap->rCurrentTSO->splim;
    *bco=(StgBCO*)PopPtr();
 
    /* INT, WORD, ADDR, STABLE don't need to do a word-size check
@@ -376,7 +386,7 @@ int ccall ( CFunDescriptor*  d,
    for a given function by name.  Useful but a hack.  Sigh.
  */
 extern void* getHugs_AsmObject_for ( char* s );
-
+extern int /*Bool*/ combined;
 
 /* ----------------------------------------------------------------*
  * The implementation for x86_ccall and x86_stdcall.
@@ -455,11 +465,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 ( 
+                asmClosureOfObject(getHugs_AsmObject_for("primRunST")), 
+                node );
+      sstat = rts_eval ( node, &nodeOut );
+   }
 
-   sstat = rts_eval ( node, &nodeOut );
    if (sstat != Success)
       barf ("unpackArgsAndCallHaskell_x86_nocallconv: eval failed");
 
@@ -509,10 +523,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 +686,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
 }