[project @ 1999-10-26 17:27:25 by sewardj]

Add foreign import/export implementations for x86 stdcall convention.

Make parser notice calling conventions on f-i and f-x declarations,
check they are supported on the platform Hugs is compiled on.  Pass
them all the way through the code generator to the interpreter.

Allow f-i/f-x decls to omit the calling convention, in which case
ccall is used.  Remove calling convention from all such decls
in the Prelude so it will work on any platform.

19 files changed, 474 insertions, 202 deletions

diff --git a/ghc/includes/Assembler.h b/ghc/includes/Assembler.h
index 36669ca1ce..2cc9dd1625 100644
--- a/ghc/includes/Assembler.h
+++ b/ghc/includes/Assembler.h
@@ -1,6 +1,6 @@
 
 /* -----------------------------------------------------------------------------
- * $Id: Assembler.h,v 1.9 1999/10/19 11:41:35 sewardj Exp $
+ * $Id: Assembler.h,v 1.10 1999/10/26 17:27:35 sewardj Exp $
  *
  * (c) The GHC Team 1994-1998.
  *
@@ -243,8 +243,10 @@ extern void   asmEndMkPAP      ( AsmBCO bco, AsmVar v, AsmSp start );
  * C-call and H-call
  * ------------------------------------------------------------------------*/
 
-extern const AsmPrim ccall_Id;
-extern const AsmPrim ccall_IO;
+extern const AsmPrim ccall_ccall_Id;
+extern const AsmPrim ccall_ccall_IO;
+extern const AsmPrim ccall_stdcall_Id;
+extern const AsmPrim ccall_stdcall_IO;
 
 typedef struct {
   unsigned int  num_args;
diff --git a/ghc/interpreter/connect.h b/ghc/interpreter/connect.h
index 0864ba8951..426d84c189 100644
--- a/ghc/interpreter/connect.h
+++ b/ghc/interpreter/connect.h
@@ -8,8 +8,8 @@
  * included in the distribution.
  *
  * $RCSfile: connect.h,v $
- * $Revision: 1.12 $
- * $Date: 1999/10/20 02:15:59 $
+ * $Revision: 1.13 $
+ * $Date: 1999/10/26 17:27:41 $
  * ------------------------------------------------------------------------*/
 
 /* --------------------------------------------------------------------------
@@ -78,6 +78,9 @@ extern Name  namePrint;                 /* printing primitive              */
 extern Name  nameCreateAdjThunk;        /* f-x-dyn: create adjustor thunk  */
 extern Text  textPrelude;
 extern Text  textNum;                   /* used to process default decls   */
+extern Text  textCcall;                 /* used to process foreign import  */
+extern Text  textStdcall;               /*         ... and foreign export  */
+
 #if    NPLUSK
 extern Text  textPlus;                  /* Used to recognise n+k patterns  */
 #endif
@@ -474,10 +477,10 @@ extern Type typeException;
 extern Type typeIO;
 extern Type typeST;
 
-extern  Void   foreignImport    Args((Cell,Pair,Cell,Cell));
+extern  Void   foreignImport    Args((Cell,Text,Pair,Cell,Cell));
 extern List  foreignImports;            /* foreign import declarations     */
 extern  Void   implementForeignImport Args((Name));
-extern  Void   foreignExport   Args((Cell,Cell,Cell,Cell));
+extern  Void   foreignExport   Args((Cell,Text,Cell,Cell,Cell));
 extern List  foreignExports;            /* foreign export declarations     */
 extern  Void   implementForeignExport Args((Name));
 
diff --git a/ghc/interpreter/dynamic.c b/ghc/interpreter/dynamic.c
index 23d939e0e6..21447066c4 100644
--- a/ghc/interpreter/dynamic.c
+++ b/ghc/interpreter/dynamic.c
@@ -9,8 +9,8 @@
  * included in the distribution.
  *
  * $RCSfile: dynamic.c,v $
- * $Revision: 1.9 $
- * $Date: 1999/10/22 10:00:19 $
+ * $Revision: 1.10 $
+ * $Date: 1999/10/26 17:27:39 $
  * ------------------------------------------------------------------------*/
 
 #include "prelude.h"
@@ -52,6 +52,16 @@ String symbol; {
     return GetProcAddress(instance,symbol);
 }
 
+Bool stdcallAllowed ( void )
+{
+   return TRUE;
+}
+
+
+
+
+
+
 #elif HAVE_DLFCN_H /* eg LINUX, SOLARIS, ULTRIX */
 
 #include <stdio.h>
@@ -91,6 +101,16 @@ String symbol; {
     EEND;
 }
 
+Bool stdcallAllowed ( void )
+{
+   return FALSE;
+}
+
+
+
+
+
+
 #elif HAVE_DL_H /* eg HPUX */
 
 #include <dl.h>
@@ -107,6 +127,16 @@ String symbol; {
     return (0 == shl_findsym(&instance,symbol,TYPE_PROCEDURE,&r)) ? r : 0;
 }
 
+Bool stdcallAllowed ( void )
+{
+   return FALSE;
+}
+
+
+
+
+
+
 #else /* Dynamic loading not available */
 
 void* getDLLSymbol(dll,symbol)  /* load dll and lookup symbol */
@@ -120,5 +150,10 @@ String symbol; {
 #endif
 }
 
+Bool stdcallAllowed ( void )
+{
+   return FALSE;
+}
+
 #endif /* Dynamic loading not available */
 
diff --git a/ghc/interpreter/dynamic.h b/ghc/interpreter/dynamic.h
index 85e1736f20..61612a0031 100644
--- a/ghc/interpreter/dynamic.h
+++ b/ghc/interpreter/dynamic.h
@@ -1,5 +1,6 @@
-void* getDLLSymbol Args((String,String));
-void* lookupSymbol Args((ObjectFile file, String symbol));
-ObjectFile loadLibrary Args((String fn));
 
+extern void*      getDLLSymbol   Args((String,String));
+extern void*      lookupSymbol   Args((ObjectFile file, String symbol));
+extern ObjectFile loadLibrary    Args((String fn));
+extern Bool       stdcallAllowed Args((void));
 
diff --git a/ghc/interpreter/input.c b/ghc/interpreter/input.c
index 071ceb2b64..922e98b2b6 100644
--- a/ghc/interpreter/input.c
+++ b/ghc/interpreter/input.c
@@ -9,8 +9,8 @@
  * included in the distribution.
  *
  * $RCSfile: input.c,v $
- * $Revision: 1.9 $
- * $Date: 1999/10/15 23:52:00 $
+ * $Revision: 1.10 $
+ * $Date: 1999/10/26 17:27:39 $
  * ------------------------------------------------------------------------*/
 
 #include "prelude.h"
@@ -136,6 +136,9 @@ static Text textHiding,  textQualified, textAsMod;
 static Text textExport,  textDynamic,   textUUExport;
 static Text textUnsafe,  textUUAll;
 
+Text   textCcall;                       /* ccall                           */
+Text   textStdcall;                     /* stdcall                         */
+
 Text   textNum;                         /* Num                             */
 Text   textPrelude;                     /* Prelude                         */
 Text   textPlus;                        /* (+)                             */
@@ -1493,6 +1496,8 @@ static Int local yylex() {             /* Read next input token ...        */
         if (it==textImport)            return IMPORT;
         if (it==textExport)            return EXPORT;
         if (it==textDynamic)           return DYNAMIC;
+        if (it==textCcall)             return CCALL;
+        if (it==textStdcall)           return STDCALL;
         if (it==textUUExport)          return UUEXPORT;
         if (it==textHiding)            return HIDING;
         if (it==textQualified)         return QUALIFIED;
@@ -1709,6 +1714,8 @@ Int what; {
                        textInstImport = findText("__instimport");
                        textExport     = findText("export");
                        textDynamic    = findText("dynamic");
+                       textCcall      = findText("ccall");
+                       textStdcall    = findText("stdcall");
                        textUUExport   = findText("__export");
                        textImport     = findText("import");
                        textHiding     = findText("hiding");
diff --git a/ghc/interpreter/lib/Prelude.hs b/ghc/interpreter/lib/Prelude.hs
index 21b9aa9114..dd5f825156 100644
--- a/ghc/interpreter/lib/Prelude.hs
+++ b/ghc/interpreter/lib/Prelude.hs
@@ -114,6 +114,7 @@ module Prelude (
 
     -- debugging hacks
     --,ST(..)
+    ,primIntToAddr
   ) where
 
 -- Standard value bindings {Prelude} ----------------------------------------
@@ -1549,11 +1550,11 @@ primPmFail        = error "Pattern Match Failure"
 primMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
 primMkIO = ST
 
-primCreateAdjThunk :: (a -> b) -> String -> IO Addr
-primCreateAdjThunk fun typestr 
+primCreateAdjThunk :: (a -> b) -> String -> Char -> IO Addr
+primCreateAdjThunk fun typestr callconv
    = do sp <- makeStablePtr fun
         p  <- copy_String_to_cstring typestr  -- is never freed
-        a  <- primCreateAdjThunkARCH sp p
+        a  <- primCreateAdjThunkARCH sp p callconv
         return a
 
 -- The following primitives are only needed if (n+k) patterns are enabled:
@@ -1702,24 +1703,24 @@ data IOResult  = IOResult  deriving (Show)
 
 type FILE_STAR = Int   -- FILE *
 
-foreign import stdcall "nHandle.so" "nh_stdin"  nh_stdin  :: IO FILE_STAR
-foreign import stdcall "nHandle.so" "nh_stdout" nh_stdout :: IO FILE_STAR
-foreign import stdcall "nHandle.so" "nh_stderr" nh_stderr :: IO FILE_STAR
-foreign import stdcall "nHandle.so" "nh_write"  nh_write  :: FILE_STAR -> Int -> IO ()
-foreign import stdcall "nHandle.so" "nh_read"   nh_read   :: FILE_STAR -> IO Int
-foreign import stdcall "nHandle.so" "nh_open"   nh_open   :: Addr -> Int -> IO FILE_STAR
-foreign import stdcall "nHandle.so" "nh_flush"  nh_flush  :: FILE_STAR -> IO ()
-foreign import stdcall "nHandle.so" "nh_close"  nh_close  :: FILE_STAR -> IO ()
-foreign import stdcall "nHandle.so" "nh_errno"  nh_errno  :: IO Int
-
-foreign import stdcall "nHandle.so" "nh_malloc" nh_malloc :: Int -> IO Addr
-foreign import stdcall "nHandle.so" "nh_free"   nh_free   :: Addr -> IO ()
-foreign import stdcall "nHandle.so" "nh_store"  nh_store  :: Addr -> Int -> IO ()
-foreign import stdcall "nHandle.so" "nh_load"   nh_load   :: Addr -> IO Int
-
-foreign import stdcall "nHandle.so" "nh_argc"   nh_argc   :: IO Int
-foreign import stdcall "nHandle.so" "nh_argvb"  nh_argvb  :: Int -> Int -> IO Int
-foreign import stdcall "nHandle.so" "nh_getenv" nh_getenv :: Addr -> IO Addr
+foreign import "nHandle.so" "nh_stdin"  nh_stdin  :: IO FILE_STAR
+foreign import "nHandle.so" "nh_stdout" nh_stdout :: IO FILE_STAR
+foreign import "nHandle.so" "nh_stderr" nh_stderr :: IO FILE_STAR
+foreign import "nHandle.so" "nh_write"  nh_write  :: FILE_STAR -> Int -> IO ()
+foreign import "nHandle.so" "nh_read"   nh_read   :: FILE_STAR -> IO Int
+foreign import "nHandle.so" "nh_open"   nh_open   :: Addr -> Int -> IO FILE_STAR
+foreign import "nHandle.so" "nh_flush"  nh_flush  :: FILE_STAR -> IO ()
+foreign import "nHandle.so" "nh_close"  nh_close  :: FILE_STAR -> IO ()
+foreign import "nHandle.so" "nh_errno"  nh_errno  :: IO Int
+
+foreign import "nHandle.so" "nh_malloc" nh_malloc :: Int -> IO Addr
+foreign import "nHandle.so" "nh_free"   nh_free   :: Addr -> IO ()
+foreign import "nHandle.so" "nh_store"  nh_store  :: Addr -> Int -> IO ()
+foreign import "nHandle.so" "nh_load"   nh_load   :: Addr -> IO Int
+
+foreign import "nHandle.so" "nh_argc"   nh_argc   :: IO Int
+foreign import "nHandle.so" "nh_argvb"  nh_argvb  :: Int -> Int -> IO Int
+foreign import "nHandle.so" "nh_getenv" nh_getenv :: Addr -> IO Addr
 
 copy_String_to_cstring :: String -> IO Addr
 copy_String_to_cstring s
diff --git a/ghc/interpreter/parser.y b/ghc/interpreter/parser.y
index 0d787cf937..a836cd60a6 100644
--- a/ghc/interpreter/parser.y
+++ b/ghc/interpreter/parser.y
@@ -12,8 +12,8 @@
  * included in the distribution.
  *
  * $RCSfile: parser.y,v $
- * $Revision: 1.11 $
- * $Date: 1999/10/20 02:16:02 $
+ * $Revision: 1.12 $
+ * $Date: 1999/10/26 17:27:37 $
  * ------------------------------------------------------------------------*/
 
 %{
@@ -97,7 +97,7 @@ static Void   local noIP	 Args((String));
 %token '['        ';'        ']'        '`'        '.'
 %token TMODULE    IMPORT     HIDING     QUALIFIED  ASMOD
 %token EXPORT     UUEXPORT   INTERFACE  REQUIRES   UNSAFE     
-%token INSTIMPORT DYNAMIC
+%token INSTIMPORT DYNAMIC    CCALL      STDCALL
 
 %%
 /*- Top level script/module structure -------------------------------------*/
@@ -631,12 +631,14 @@ derivs    : derivs ',' qconid           {$$ = gc3(cons($3,$1));}
 /*- Processing definitions of primitives ----------------------------------*/
 
 topDecl   : FOREIGN IMPORT callconv ext_loc ext_name unsafe_flag var COCO type 
-                                        {foreignImport($1,pair($4,$5),$7,$9); sp-=9;}
+                            {foreignImport($1,$3,pair($4,$5),$7,$9); sp-=9;}
           | FOREIGN EXPORT callconv DYNAMIC qvarid COCO type 
-                                        {foreignExport($1,$4,$5,$7); sp-=7;}
+                            {foreignExport($1,$3,$4,$5,$7); sp-=7;}
 	  ;
 
-callconv  : var                  {$$ = gc1(NIL); /* ignored */ }
+callconv  : CCALL                {$$ = gc1(textCcall);}
+          | STDCALL              {$$ = gc1(textStdcall);}
+          | /* empty */          {$$ = gc0(NIL);}
           ;
 ext_loc   : STRINGLIT            {$$ = $1;}
           ;
diff --git a/ghc/interpreter/static.c b/ghc/interpreter/static.c
index f2a949e5b6..7a61668f34 100644
--- a/ghc/interpreter/static.c
+++ b/ghc/interpreter/static.c
@@ -9,8 +9,8 @@
  * included in the distribution.
  *
  * $RCSfile: static.c,v $
- * $Revision: 1.12 $
- * $Date: 1999/10/19 12:05:27 $
+ * $Revision: 1.13 $
+ * $Date: 1999/10/26 17:27:45 $
  * ------------------------------------------------------------------------*/
 
 #include "prelude.h"
@@ -3138,8 +3138,10 @@ static Void local checkDefaultDefns() { /* check that default types are    */
  * what "foreign export static" would mean in an interactive setting.
  * ------------------------------------------------------------------------*/
 
-Void foreignImport(line,extName,intName,type) /* Handle foreign imports    */
+Void foreignImport(line,callconv,extName,intName,type) 
+                                              /* Handle foreign imports    */
 Cell line;
+Text callconv;
 Pair extName;
 Cell intName;
 Cell type; {
@@ -3153,10 +3155,11 @@ Cell type; {
         ERRMSG(l) "Redeclaration of foreign \"%s\"", textToStr(t)
         EEND;
     }
-    name(n).line = l;
-    name(n).defn = extName;
-    name(n).type = type;
-    foreignImports = cons(n,foreignImports);
+    name(n).line     = l;
+    name(n).defn     = extName;
+    name(n).type     = type;
+    name(n).callconv = callconv;
+    foreignImports   = cons(n,foreignImports);
 }
 
 static Void local checkForeignImport(p)   /* Check foreign import          */
@@ -3173,8 +3176,10 @@ Name p; {
     implementForeignImport(p);
 }
 
-Void foreignExport(line,extName,intName,type)/* Handle foreign exports    */
+Void foreignExport(line,callconv,extName,intName,type)
+                                              /* Handle foreign exports    */
 Cell line;
+Text callconv;
 Cell extName;
 Cell intName;
 Cell type; {
@@ -3188,10 +3193,11 @@ Cell type; {
         ERRMSG(l) "Redeclaration of foreign \"%s\"", textToStr(t)
         EEND;
     }
-    name(n).line = l;
-    name(n).defn = NIL;  /* nothing to say */
-    name(n).type = type;
-    foreignExports = cons(n,foreignExports);
+    name(n).line     = l;
+    name(n).defn     = NIL;  /* nothing to say */
+    name(n).type     = type;
+    name(n).callconv = callconv;
+    foreignExports   = cons(n,foreignExports);
 }
 
 static Void local checkForeignExport(p)       /* Check foreign export      */
diff --git a/ghc/interpreter/storage.c b/ghc/interpreter/storage.c
index e08b3e7dbd..72e9a19878 100644
--- a/ghc/interpreter/storage.c
+++ b/ghc/interpreter/storage.c
@@ -9,8 +9,8 @@
  * included in the distribution.
  *
  * $RCSfile: storage.c,v $
- * $Revision: 1.13 $
- * $Date: 1999/10/20 02:16:05 $
+ * $Revision: 1.14 $
+ * $Date: 1999/10/26 17:27:43 $
  * ------------------------------------------------------------------------*/
 
 #include "prelude.h"
@@ -438,6 +438,7 @@ Cell parent; {
     name(nameHw).inlineMe     = FALSE;
     name(nameHw).simplified   = FALSE;
     name(nameHw).isDBuilder   = FALSE;
+    name(nameHw).callconv     = NIL;
     name(nameHw).type         = NIL;
     name(nameHw).primop       = 0;
     name(nameHw).mod          = currentModule;
diff --git a/ghc/interpreter/storage.h b/ghc/interpreter/storage.h
index da74ecb2bf..342e983886 100644
--- a/ghc/interpreter/storage.h
+++ b/ghc/interpreter/storage.h
@@ -10,8 +10,8 @@
  * included in the distribution.
  *
  * $RCSfile: storage.h,v $
- * $Revision: 1.10 $
- * $Date: 1999/10/16 02:17:25 $
+ * $Revision: 1.11 $
+ * $Date: 1999/10/26 17:27:42 $
  * ------------------------------------------------------------------------*/
 
 /* --------------------------------------------------------------------------
@@ -555,6 +555,7 @@ struct strName {
     Bool   inlineMe;      /* self-evident    */
     Bool   simplified;    /* TRUE => already simplified */
     Bool   isDBuilder;    /* TRUE => is a dictionary builder */
+    Text   callconv;      /* for foreign import/export */
     const void*  primop;  /* really StgPrim* */
     Name   nextNameHash;
 };
diff --git a/ghc/interpreter/translate.c b/ghc/interpreter/translate.c
index 72dd432548..2c2717ed81 100644
--- a/ghc/interpreter/translate.c
+++ b/ghc/interpreter/translate.c
@@ -10,8 +10,8 @@
  * included in the distribution.
  *
  * $RCSfile: translate.c,v $
- * $Revision: 1.10 $
- * $Date: 1999/10/19 11:01:24 $
+ * $Revision: 1.11 $
+ * $Date: 1999/10/26 17:27:36 $
  * ------------------------------------------------------------------------*/
 
 #include "prelude.h"
@@ -529,7 +529,7 @@ List scs; {                             /* in incr order of strict comps.  */
     name(c).inlineMe = TRUE;
     name(c).stgSize = stgSize(stgVarBody(name(c).stgVar));
     stgGlobals = cons(pair(c,name(c).stgVar),stgGlobals); 
-    //printStg(stderr, name(c).stgVar); fprintf(stderr,"\n\n");
+    /* printStg(stderr, name(c).stgVar); fprintf(stderr,"\n\n"); */
 }
 
 /* --------------------------------------------------------------------------
@@ -570,6 +570,7 @@ static Cell foreignTy ( Bool outBound, Type t )
     else if (t == typeAddr)   return mkChar(ADDR_REP);
     else if (t == typeFloat)  return mkChar(FLOAT_REP);
     else if (t == typeDouble) return mkChar(DOUBLE_REP);
+    else if (t == typeStable) return mkChar(STABLE_REP);
 #ifdef PROVIDE_FOREIGN
     else if (t == typeForeign)return mkChar(FOREIGN_REP); 
          /* ToDo: argty only! */
@@ -705,7 +706,6 @@ static StgRhs unboxVars( String reps, List b_args, List u_args, StgExpr e )
     if (nonNull(b_args)) {
         StgVar b_arg = hd(b_args); /* boxed arg   */
         StgVar u_arg = hd(u_args); /* unboxed arg */
-        //StgRep k     = mkStgRep(*reps);
         Name   box   = repToBox(*reps);
         e = unboxVars(reps+1,tl(b_args),tl(u_args),e);
         if (isNull(box)) {
@@ -853,11 +853,25 @@ Void implementForeignImport ( Name n )
     descriptor = mkDescriptor(charListToString(argTys),
                               charListToString(resultTys));
     if (!descriptor) {
-       ERRMSG(0) "Can't allocate memory for call descriptor"
+       ERRMSG(name(n).line) "Can't allocate memory for call descriptor"
        EEND;
     }
 
-    name(n).primop = addState ? &ccall_IO : &ccall_Id;
+    /* ccall is the default convention, if it wasn't specified */
+    if (isNull(name(n).callconv)
+        || name(n).callconv == textCcall) {
+       name(n).primop = addState ? &ccall_ccall_IO : &ccall_ccall_Id;
+    } 
+    else if (name(n).callconv == textStdcall) {
+       if (!stdcallAllowed()) {
+          ERRMSG(name(n).line) "stdcall is not supported on this platform"
+          EEND;
+       }
+       name(n).primop = addState ? &ccall_stdcall_IO : &ccall_stdcall_Id;
+    }
+    else
+       internal ( "implementForeignImport: unknown calling convention");
+
     {
         Pair    extName = name(n).defn;
         void*   funPtr  = getDLLSymbol(textToStr(textOf(fst(extName))),
@@ -867,7 +881,7 @@ Void implementForeignImport ( Name n )
                                  descriptor->result_tys);
         StgVar v   = mkStgVar(rhs,NIL);
         if (funPtr == 0) {
-            ERRMSG(0) "Could not find foreign function \"%s\" in \"%s\"", 
+            ERRMSG(name(n).line) "Could not find foreign function \"%s\" in \"%s\"", 
                 textToStr(textOf(snd(extName))),
                 textToStr(textOf(fst(extName)))
             EEND;
@@ -886,7 +900,8 @@ Void implementForeignImport ( Name n )
  *
  * \ fun s0 ->
      let e1 = A# "...."
-     in  primMkAdjThunk fun s0 e1
+         e3 = C# 'c' -- (ccall), or 's' (stdcall)
+     in  primMkAdjThunk fun e1 e3 s0
 
    we require, and check that,
      fun :: prim_arg* -> IO prim_result
@@ -896,11 +911,12 @@ Void implementForeignExport ( Name n )
     Type t         = name(n).type;
     List argTys    = NIL;
     List resultTys = NIL;
+    Char cc_char;
 
     if (getHead(t)==typeArrow && argCount==2) {
        t = arg(fun(t));
     } else {
-        ERRMSG(0) "foreign export has illegal type" ETHEN
+        ERRMSG(name(n).line) "foreign export has illegal type" ETHEN
         ERRTEXT " \"" ETHEN ERRTYPE(t);
         ERRTEXT "\""
         EEND;        
@@ -918,7 +934,7 @@ Void implementForeignExport ( Name n )
         assert(length(resultTys) == 1);
         resultTys = hd(resultTys);
     } else {
-        ERRMSG(0) "foreign export doesn't return an IO type" ETHEN
+        ERRMSG(name(n).line) "foreign export doesn't return an IO type" ETHEN
         ERRTEXT " \"" ETHEN ERRTYPE(t);
         ERRTEXT "\""
         EEND;        
@@ -927,11 +943,27 @@ Void implementForeignExport ( Name n )
 
     mapOver(foreignInboundTy,argTys);
 
+    /* ccall is the default convention, if it wasn't specified */
+    if (isNull(name(n).callconv)
+        || name(n).callconv == textCcall) {
+        cc_char = 'c';
+    } 
+    else if (name(n).callconv == textStdcall) {
+       if (!stdcallAllowed()) {
+          ERRMSG(name(n).line) "stdcall is not supported on this platform"
+          EEND;
+       }
+       cc_char = 's';
+    }
+    else
+       internal ( "implementForeignExport: unknown calling convention");
+
+
     {
     List     tdList;
     Text     tdText;
     List     args;
-    StgVar   e1, e2, v;
+    StgVar   e1, e2, e3, v;
     StgExpr  fun;
 
     tdList = cons(mkChar(':'),argTys);
@@ -944,24 +976,27 @@ Void implementForeignExport ( Name n )
                 mkStgCon(nameMkA,singleton(ap(STRCELL,tdText))),
                 NIL
              );
-     e2    = mkStgVar(
+    e2     = mkStgVar(
                 mkStgApp(nameUnpackString,singleton(e1)),
                 NIL
              );
-
+    e3     = mkStgVar(
+                mkStgCon(nameMkC,singleton(mkChar(cc_char))),
+                NIL
+             );
     fun    = mkStgLambda(
                 args,
                 mkStgLet(
-                   doubleton(e1,e2),
+                   tripleton(e1,e2,e3),
                    mkStgApp(
                       nameCreateAdjThunk,
-                      tripleton(hd(args),e2,hd(tl(args)))
+                      cons(hd(args),cons(e2,cons(e3,cons(hd(tl(args)),NIL))))
                    )
                 )
              );
 
     v = mkStgVar(fun,NIL);
-    /* ppStg(v); */
+    ppStg(v);
 
     name(n).defn     = NIL;    
     name(n).stgVar   = v;
diff --git a/ghc/lib/hugs/Prelude.hs b/ghc/lib/hugs/Prelude.hs
index 21b9aa9114..dd5f825156 100644
--- a/ghc/lib/hugs/Prelude.hs
+++ b/ghc/lib/hugs/Prelude.hs
@@ -114,6 +114,7 @@ module Prelude (
 
     -- debugging hacks
     --,ST(..)
+    ,primIntToAddr
   ) where
 
 -- Standard value bindings {Prelude} ----------------------------------------
@@ -1549,11 +1550,11 @@ primPmFail        = error "Pattern Match Failure"
 primMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
 primMkIO = ST
 
-primCreateAdjThunk :: (a -> b) -> String -> IO Addr
-primCreateAdjThunk fun typestr 
+primCreateAdjThunk :: (a -> b) -> String -> Char -> IO Addr
+primCreateAdjThunk fun typestr callconv
    = do sp <- makeStablePtr fun
         p  <- copy_String_to_cstring typestr  -- is never freed
-        a  <- primCreateAdjThunkARCH sp p
+        a  <- primCreateAdjThunkARCH sp p callconv
         return a
 
 -- The following primitives are only needed if (n+k) patterns are enabled:
@@ -1702,24 +1703,24 @@ data IOResult  = IOResult  deriving (Show)
 
 type FILE_STAR = Int   -- FILE *
 
-foreign import stdcall "nHandle.so" "nh_stdin"  nh_stdin  :: IO FILE_STAR
-foreign import stdcall "nHandle.so" "nh_stdout" nh_stdout :: IO FILE_STAR
-foreign import stdcall "nHandle.so" "nh_stderr" nh_stderr :: IO FILE_STAR
-foreign import stdcall "nHandle.so" "nh_write"  nh_write  :: FILE_STAR -> Int -> IO ()
-foreign import stdcall "nHandle.so" "nh_read"   nh_read   :: FILE_STAR -> IO Int
-foreign import stdcall "nHandle.so" "nh_open"   nh_open   :: Addr -> Int -> IO FILE_STAR
-foreign import stdcall "nHandle.so" "nh_flush"  nh_flush  :: FILE_STAR -> IO ()
-foreign import stdcall "nHandle.so" "nh_close"  nh_close  :: FILE_STAR -> IO ()
-foreign import stdcall "nHandle.so" "nh_errno"  nh_errno  :: IO Int
-
-foreign import stdcall "nHandle.so" "nh_malloc" nh_malloc :: Int -> IO Addr
-foreign import stdcall "nHandle.so" "nh_free"   nh_free   :: Addr -> IO ()
-foreign import stdcall "nHandle.so" "nh_store"  nh_store  :: Addr -> Int -> IO ()
-foreign import stdcall "nHandle.so" "nh_load"   nh_load   :: Addr -> IO Int
-
-foreign import stdcall "nHandle.so" "nh_argc"   nh_argc   :: IO Int
-foreign import stdcall "nHandle.so" "nh_argvb"  nh_argvb  :: Int -> Int -> IO Int
-foreign import stdcall "nHandle.so" "nh_getenv" nh_getenv :: Addr -> IO Addr
+foreign import "nHandle.so" "nh_stdin"  nh_stdin  :: IO FILE_STAR
+foreign import "nHandle.so" "nh_stdout" nh_stdout :: IO FILE_STAR
+foreign import "nHandle.so" "nh_stderr" nh_stderr :: IO FILE_STAR
+foreign import "nHandle.so" "nh_write"  nh_write  :: FILE_STAR -> Int -> IO ()
+foreign import "nHandle.so" "nh_read"   nh_read   :: FILE_STAR -> IO Int
+foreign import "nHandle.so" "nh_open"   nh_open   :: Addr -> Int -> IO FILE_STAR
+foreign import "nHandle.so" "nh_flush"  nh_flush  :: FILE_STAR -> IO ()
+foreign import "nHandle.so" "nh_close"  nh_close  :: FILE_STAR -> IO ()
+foreign import "nHandle.so" "nh_errno"  nh_errno  :: IO Int
+
+foreign import "nHandle.so" "nh_malloc" nh_malloc :: Int -> IO Addr
+foreign import "nHandle.so" "nh_free"   nh_free   :: Addr -> IO ()
+foreign import "nHandle.so" "nh_store"  nh_store  :: Addr -> Int -> IO ()
+foreign import "nHandle.so" "nh_load"   nh_load   :: Addr -> IO Int
+
+foreign import "nHandle.so" "nh_argc"   nh_argc   :: IO Int
+foreign import "nHandle.so" "nh_argvb"  nh_argvb  :: Int -> Int -> IO Int
+foreign import "nHandle.so" "nh_getenv" nh_getenv :: Addr -> IO Addr
 
 copy_String_to_cstring :: String -> IO Addr
 copy_String_to_cstring s
diff --git a/ghc/rts/Assembler.c b/ghc/rts/Assembler.c
index b4decda338..acef38c196 100644
--- a/ghc/rts/Assembler.c
+++ b/ghc/rts/Assembler.c
@@ -5,8 +5,8 @@
  * Copyright (c) 1994-1998.
  *
  * $RCSfile: Assembler.c,v $
- * $Revision: 1.10 $
- * $Date: 1999/10/15 11:02:58 $
+ * $Revision: 1.11 $
+ * $Date: 1999/10/26 17:27:28 $
  *
  * This module provides functions to construct BCOs and other closures
  * required by the bytecode compiler.
@@ -1366,7 +1366,7 @@ const AsmPrim asmPrimOps[] = {
     , { "primFreeStablePtr",         "s", "",    MONAD_IO, i_PRIMOP2, i_freeStablePtr }
 
     /* foreign export dynamic support */
-    , { "primCreateAdjThunkARCH",    "sA", "A",  MONAD_IO, i_PRIMOP2, i_createAdjThunkARCH }
+    , { "primCreateAdjThunkARCH",    "sAC","A",  MONAD_IO, i_PRIMOP2, i_createAdjThunkARCH }
 
 #ifdef PROVIDE_PTREQUALITY
     , { "primReallyUnsafePtrEquality", "aa", "B",MONAD_Id, i_PRIMOP2, i_reallyUnsafePtrEquality }
@@ -1389,11 +1389,17 @@ const AsmPrim asmPrimOps[] = {
 
     /* Ccall is polyadic - so it's excluded from this table */
 
-    , { 0,0,0,0 }
+    , { 0,0,0,0,0,0 }
 };
 
-const AsmPrim ccall_Id = { "ccall", 0, 0, MONAD_IO, i_PRIMOP2, i_ccall_Id };
-const AsmPrim ccall_IO = { "ccall", 0, 0, MONAD_IO, i_PRIMOP2, i_ccall_IO };
+const AsmPrim ccall_ccall_Id
+   = { "ccall", 0, 0, MONAD_IO, i_PRIMOP2, i_ccall_ccall_Id };
+const AsmPrim ccall_ccall_IO
+   = { "ccall", 0, 0, MONAD_IO, i_PRIMOP2, i_ccall_ccall_IO };
+const AsmPrim ccall_stdcall_Id 
+   = { "ccall", 0, 0, MONAD_IO, i_PRIMOP2, i_ccall_stdcall_Id };
+const AsmPrim ccall_stdcall_IO 
+   = { "ccall", 0, 0, MONAD_IO, i_PRIMOP2, i_ccall_stdcall_IO };
 
 
 const AsmPrim* asmFindPrim( char* s )
diff --git a/ghc/rts/Bytecodes.h b/ghc/rts/Bytecodes.h
index f277d598f9..c52d51c4ec 100644
--- a/ghc/rts/Bytecodes.h
+++ b/ghc/rts/Bytecodes.h
@@ -1,6 +1,6 @@
 
 /* -----------------------------------------------------------------------------
- * $Id: Bytecodes.h,v 1.7 1999/10/15 11:02:59 sewardj Exp $
+ * $Id: Bytecodes.h,v 1.8 1999/10/26 17:27:30 sewardj Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -426,14 +426,16 @@ typedef enum
 #endif
 
     /* CCall! */
-    , i_ccall_Id
-    , i_ccall_IO
+    , i_ccall_ccall_Id
+    , i_ccall_ccall_IO
+    , i_ccall_stdcall_Id
+    , i_ccall_stdcall_IO
 
     /* If you add a new primop to this table, check you don't
      * overflow the 256 limit.  That is MAX_Primop2 <= 255.
      * Current value (30/10/98) = 0x42
      */
-    , MAX_Primop2 = i_ccall_IO
+    , MAX_Primop2 = i_ccall_stdcall_IO
 } Primop2;
 
 typedef unsigned int InstrPtr; /* offset of instruction within BCO */
diff --git a/ghc/rts/Disassembler.c b/ghc/rts/Disassembler.c
index e3590ae69d..cbf36acc81 100644
--- a/ghc/rts/Disassembler.c
+++ b/ghc/rts/Disassembler.c
@@ -5,8 +5,8 @@
  * Copyright (c) 1994-1998.
  *
  * $RCSfile: Disassembler.c,v $
- * $Revision: 1.8 $
- * $Date: 1999/10/15 11:03:01 $
+ * $Revision: 1.9 $
+ * $Date: 1999/10/26 17:27:31 $
  * ---------------------------------------------------------------------------*/
 
 #include "Rts.h"
@@ -369,10 +369,14 @@ InstrPtr disInstr( StgBCO *bco, InstrPtr pc )
             switch (op) {
             case i_INTERNAL_ERROR2:
                     return disNone(bco,pc,"INTERNAL_ERROR2");
-            case i_ccall_Id:
-                    return disNone(bco,pc,"ccall_Id");
-            case i_ccall_IO:
-                    return disNone(bco,pc,"ccall_IO");
+            case i_ccall_ccall_Id:
+                    return disNone(bco,pc,"ccall_ccall_Id");
+            case i_ccall_ccall_IO:
+                    return disNone(bco,pc,"ccall_ccall_IO");
+            case i_ccall_stdcall_Id:
+                    return disNone(bco,pc,"ccall_stdcall_Id");
+            case i_ccall_stdcall_IO:
+                    return disNone(bco,pc,"ccall_stdcall_IO");
             case i_raise:
                     return disNone(bco,pc,"primRaise");
             default:
diff --git a/ghc/rts/Evaluator.c b/ghc/rts/Evaluator.c
index a898471cfe..6dd91fa37b 100644
--- a/ghc/rts/Evaluator.c
+++ b/ghc/rts/Evaluator.c
@@ -5,8 +5,8 @@
  * Copyright (c) 1994-1998.
  *
  * $RCSfile: Evaluator.c,v $
- * $Revision: 1.21 $
- * $Date: 1999/10/22 15:58:22 $
+ * $Revision: 1.22 $
+ * $Date: 1999/10/26 17:27:25 $
  * ---------------------------------------------------------------------------*/
 
 #include "Rts.h"
@@ -2883,7 +2883,8 @@ static void* enterBCO_primop2 ( int primop2code,
             {
                 StgStablePtr stableptr = PopTaggedStablePtr();
                 StgAddr      typestr   = PopTaggedAddr();
-                StgAddr      adj_thunk = createAdjThunk(stableptr,typestr);
+                StgChar      callconv  = PopTaggedChar();
+                StgAddr      adj_thunk = createAdjThunk(stableptr,typestr,callconv);
                 PushTaggedAddr(adj_thunk);
                 break;
             }     
@@ -3036,13 +3037,18 @@ off the stack.
                 ASSERT(0);
                 break;
 #endif /* PROVIDE_CONCURRENT */
-        case i_ccall_Id:
-        case i_ccall_IO:
+        case i_ccall_ccall_Id:
+        case i_ccall_ccall_IO:
+        case i_ccall_stdcall_Id:
+        case i_ccall_stdcall_IO:
             {
                 int r;
                 CFunDescriptor* descriptor = PopTaggedAddr();
                 void (*funPtr)(void)       = PopTaggedAddr();
-                r = ccall(descriptor,funPtr,bco);
+                char cc = (primop2code == i_ccall_stdcall_Id ||
+                           primop2code == i_ccall_stdcall_IO)
+                          ? 's' : 'c';
+                r = ccall(descriptor,funPtr,bco,cc);
                 if (r == 0) break;
                 if (r == 1) 
                    return makeErrorCall(
diff --git a/ghc/rts/ForeignCall.c b/ghc/rts/ForeignCall.c
index 5b1e64ff46..5bf75ad46b 100644
--- a/ghc/rts/ForeignCall.c
+++ b/ghc/rts/ForeignCall.c
@@ -1,6 +1,6 @@
 
 /* -----------------------------------------------------------------------------
- * $Id: ForeignCall.c,v 1.9 1999/10/22 15:58:21 sewardj Exp $
+ * $Id: ForeignCall.c,v 1.10 1999/10/26 17:27:30 sewardj Exp $
  *
  * (c) The GHC Team 1994-1999.
  *
@@ -153,16 +153,19 @@ CFunDescriptor* mkDescriptor( char* as, char* rs )
  * External  refs for the assembly routines.
  * ----------------------------------------------------------------*/
 
-extern void universal_call_c_x86_ccall  ( int, void*, char*, void* );
-static void universal_call_c_generic    ( int, void*, char*, void* );
-
+#if i386_TARGET_ARCH
+extern void universal_call_c_x86_stdcall  ( int, void*, char*, void* );
+extern void universal_call_c_x86_ccall    ( int, void*, char*, void* );
+#else
+static void universal_call_c_generic      ( int, void*, char*, void* );
+#endif
 
 /* ----------------------------------------------------------------*
  * This is a generic version of universal call that
  * only works for specific argument patterns.
  * 
  * It allows ports to work on the Hugs Prelude immediately,
- * even if univeral_call_c_arch_callingconvention is not available.
+ * even if universal_call_c_arch_callingconvention is not available.
  * ----------------------------------------------------------------*/
 
 static void universal_call_c_generic
@@ -221,7 +224,11 @@ static void universal_call_c_generic
  * This code attempts to be architecture neutral (viz, generic).
  * ----------------------------------------------------------------*/
 
-int ccall ( CFunDescriptor* d, void (*fun)(void), StgBCO** bco )
+int ccall ( CFunDescriptor*  d, 
+            void             (*fun)(void), 
+            StgBCO**         bco,
+            char             cc
+          )
 {
    double         arg_vec [31];
    char           argd_vec[31];
@@ -306,9 +313,14 @@ int ccall ( CFunDescriptor* d, void (*fun)(void), StgBCO** bco )
    PushPtr((StgPtr)(*bco));
    SaveThreadState();
 
-#if 1
-   universal_call_c_x86_ccall ( 
-      d->num_args, (void*)arg_vec, argd_vec, fun );
+#if i386_TARGET_ARCH
+   if (cc == 'c')
+      universal_call_c_x86_ccall ( 
+         d->num_args, (void*)arg_vec, argd_vec, fun );
+   else if (cc == 's')
+      universal_call_c_x86_stdcall ( 
+         d->num_args, (void*)arg_vec, argd_vec, fun );
+   else barf ( "ccall(i386): unknown calling convention" );
 #else
    universal_call_c_generic ( 
       d->num_args, (void*)arg_vec, argd_vec, fun );
@@ -367,13 +379,13 @@ extern void* getHugs_AsmObject_for ( char* s );
 
 
 /* ----------------------------------------------------------------*
- * The implementation for x86_ccall.
+ * The implementation for x86_ccall and x86_stdcall.
  * ----------------------------------------------------------------*/
 
 static 
 HaskellObj
-unpackArgsAndCallHaskell_x86_ccall_wrk ( StgStablePtr stableptr, 
-                                         char* tydesc, char* args)
+unpackArgsAndCallHaskell_x86_nocallconv_wrk ( StgStablePtr stableptr, 
+                                              char* tydesc, char* args)
 {
    /* Copy args out of the C stack frame in an architecture
       dependent fashion, under the direction of the type description
@@ -437,7 +449,8 @@ unpackArgsAndCallHaskell_x86_ccall_wrk ( StgStablePtr stableptr,
             break;
          default:
             barf(
-               "unpackArgsAndCallHaskell_x86_ccall: unexpected arg type rep");
+               "unpackArgsAndCallHaskell_x86_nocallconv: "
+               "unexpected arg type rep");
       }
       argp++;
    }
@@ -448,7 +461,7 @@ unpackArgsAndCallHaskell_x86_ccall_wrk ( StgStablePtr stableptr,
 
    sstat = rts_eval ( node, &nodeOut );
    if (sstat != Success)
-      barf ("unpackArgsAndCallHaskell_x86_ccall: eval failed");
+      barf ("unpackArgsAndCallHaskell_x86_nocallconv: eval failed");
 
    return nodeOut;
 }
@@ -456,11 +469,14 @@ unpackArgsAndCallHaskell_x86_ccall_wrk ( StgStablePtr stableptr,
 
 static 
 double
-unpackArgsAndCallHaskell_x86_ccall_DOUBLE ( StgStablePtr stableptr, 
-                                            char* tydesc, char* args)
+unpackArgsAndCallHaskell_x86_nocallconv_DOUBLE ( 
+      StgStablePtr stableptr, char* tydesc, char* args
+   )
 {
    HaskellObj nodeOut
-      = unpackArgsAndCallHaskell_x86_ccall_wrk ( stableptr, tydesc, args );
+      = unpackArgsAndCallHaskell_x86_nocallconv_wrk ( 
+           stableptr, tydesc, args 
+        );
    /* Return a double.  This return will go into %st(0), which 
       is unmodified by the adjustor thunk.
    */
@@ -471,11 +487,14 @@ unpackArgsAndCallHaskell_x86_ccall_DOUBLE ( StgStablePtr stableptr,
 
 static 
 float
-unpackArgsAndCallHaskell_x86_ccall_FLOAT ( StgStablePtr stableptr, 
-                                           char* tydesc, char* args)
+unpackArgsAndCallHaskell_x86_nocallconv_FLOAT ( 
+      StgStablePtr stableptr, char* tydesc, char* args
+   )
 {
    HaskellObj nodeOut
-      = unpackArgsAndCallHaskell_x86_ccall_wrk ( stableptr, tydesc, args );
+      = unpackArgsAndCallHaskell_x86_nocallconv_wrk ( 
+           stableptr, tydesc, args 
+        );
    /* Probably could be merged with the double case, since %st(0) is
       still the return register.
    */
@@ -486,11 +505,14 @@ unpackArgsAndCallHaskell_x86_ccall_FLOAT ( StgStablePtr stableptr,
 
 static 
 unsigned long
-unpackArgsAndCallHaskell_x86_ccall_INTISH ( StgStablePtr stableptr, 
-                                            char* tydesc, char* args)
+unpackArgsAndCallHaskell_x86_nocallconv_INTISH ( 
+      StgStablePtr stableptr, char* tydesc, char* args
+   )
 {
    HaskellObj nodeOut
-      = unpackArgsAndCallHaskell_x86_ccall_wrk ( stableptr, tydesc, args );
+      = 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
@@ -506,56 +528,108 @@ unpackArgsAndCallHaskell_x86_ccall_INTISH ( StgStablePtr stableptr,
       case STABLE_REP: return (unsigned long)rts_getStablePtr(nodeOut);
       default:
          barf(
-            "unpackArgsAndCallHaskell_x86_ccall: unexpected res type rep");
+            "unpackArgsAndCallHaskell_x86_nocallconv: "
+            "unexpected res type rep");
    }
 }
 
 
+/* This is a bit subtle, since it can deal with both stdcall
+   and ccall.  There are two call transitions to consider:
+
+   1.  The call to "here".  If it's a ccall, we can return
+       using 'ret 0' and let the caller remove the args.
+       If stdcall, we have to return with 'ret N', where
+       N is the size of the args passed.  N has to be 
+       determined by inspecting the type descriptor string
+       typestr.
+
+   2.  The call to unpackArgsAndCallHaskell_x86_anycallconv_*.
+       Whether these are done with stdcall or ccall depends on
+       the conventions applied by the compiler that translated
+       those procedures.  Fortunately, we can sidestep what it
+       did by saving esp (in ebx), pushing the three args,
+       calling unpack..., and restoring esp from ebx.  This
+       trick assumes that ebx is a callee-saves register, so
+       its value will be preserved across the unpack... call.
+*/
 static
-StgAddr createAdjThunk_x86_ccall ( StgStablePtr stableptr,
-                                   StgAddr      typestr )
+StgAddr createAdjThunk_x86 ( StgStablePtr stableptr,
+                             StgAddr      typestr,
+                             char         callconv )
 {
    unsigned char* codeblock;
    unsigned char* cp;
-   unsigned int ts = (unsigned int)typestr;
-   unsigned int sp = (unsigned int)stableptr;
-   unsigned int ch;
+   unsigned int   ch;
+   unsigned int   nwords;
+
+   unsigned char* argp = (unsigned char*)typestr;
+   unsigned int   ts   = (unsigned int)typestr;
+   unsigned int   sp   = (unsigned int)stableptr;
 
    if (((char*)typestr)[0] == DOUBLE_REP)
-      ch = (unsigned int)&unpackArgsAndCallHaskell_x86_ccall_DOUBLE;
+      ch = (unsigned int)
+              &unpackArgsAndCallHaskell_x86_nocallconv_DOUBLE;
    else if (((char*)typestr)[0] == FLOAT_REP)
-      ch = (unsigned int)&unpackArgsAndCallHaskell_x86_ccall_FLOAT;
+      ch = (unsigned int)
+              &unpackArgsAndCallHaskell_x86_nocallconv_FLOAT;
    else
-      ch = (unsigned int)&unpackArgsAndCallHaskell_x86_ccall_INTISH;
-
-   codeblock = malloc ( 1 + 0x22 );
-   if (!codeblock) {
-      fprintf ( stderr, 
-                "createAdjThunk_x86_ccall (foreign export dynamic):\n"
-                "\tfatal: can't alloc mem\n" );
-      exit(1);
+      ch = (unsigned int)
+              &unpackArgsAndCallHaskell_x86_nocallconv_INTISH;
+
+   codeblock = malloc ( 0x26 );
+   if (!codeblock)
+      barf ( "createAdjThunk_x86: can't malloc memory\n");
+
+   if (callconv == 's') {
+      nwords = 0;
+      if (*argp != ':') argp++;
+      ASSERT( *argp == ':' );
+      argp++;
+      while (*argp) {
+         switch (*argp) {
+            case CHAR_REP: case INT_REP: case WORD_REP: 
+            case ADDR_REP: case STABLE_REP: case FLOAT_REP:
+               nwords += 4; break;
+            case DOUBLE_REP:
+               nwords += 8; break;
+            default:
+               barf("createAdjThunk_x86: unexpected type descriptor");
+         }
+         argp++;
+      }
+   } else
+   if (callconv == 'c') {
+      nwords = 0;
+   } else {
+      barf ( "createAdjThunk_x86: unknown calling convention\n");
    }
+
    cp = codeblock;
-   /* Generate the following:
-      0000 53           pushl %ebx
+   /*
+      0000 53           pushl %ebx        # save caller's registers
       0001 51           pushl %ecx
       0002 56           pushl %esi
       0003 57           pushl %edi
       0004 55           pushl %ebp
       0005 89E0         movl %esp,%eax    # sp -> eax
       0007 83C018       addl $24,%eax     # move eax back over 5 saved regs + retaddr
-      000a 50           pushl %eax        # push arg-block addr
-      000b 6844332211   pushl $0x11223344 # push addr of type descr string
-      0010 6877665544   pushl $0x44556677 # push stableptr to closure
-      0015 E8BBAA9988   call 0x8899aabb   # SEE COMMENT BELOW
-      001a 83C40C       addl $12,%esp     # pop 3 args
-      001d 5D           popl %ebp
-      001e 5F           popl %edi
-      001f 5E           popl %esi
-      0020 59           popl %ecx
-      0021 5B           popl %ebx
-      0022 C3           ret
-    */
+      000a 89E3         movl %esp,%ebx    # remember sp before pushing args
+      000c 50           pushl %eax        # push arg-block addr
+      000d 6844332211   pushl $0x11223344 # push addr of type descr string
+      0012 6877665544   pushl $0x44556677 # push stableptr to closure
+      0017 E8BBAA9988   call 0x8899aabb   # SEE COMMENT BELOW
+                                          # return value is in %eax, or %eax:%edx, 
+                                          # or %st(0), so don't trash these regs 
+                                          # between here and 'ret'
+      001c 89DC         movl %ebx,%esp    # restore sp from remembered value
+      001e 5D           popl %ebp         # restore caller's registers
+      001f 5F           popl %edi
+      0020 5E           popl %esi
+      0021 59           popl %ecx
+      0022 5B           popl %ebx
+      0023 C27766       ret  $0x6677      # return, clearing args if stdcall
+   */
    *cp++ = 0x53;
    *cp++ = 0x51;
    *cp++ = 0x56;
@@ -563,6 +637,7 @@ StgAddr createAdjThunk_x86_ccall ( StgStablePtr stableptr,
    *cp++ = 0x55;
    *cp++ = 0x89; *cp++ = 0xE0;
    *cp++ = 0x83; *cp++ = 0xC0; *cp++ = 0x18;
+   *cp++ = 0x89; *cp++ = 0xE3;
    *cp++ = 0x50;
    *cp++ = 0x68; *cp++=ts;ts>>=8; *cp++=ts;ts>>=8; *cp++=ts;ts>>=8; *cp++=ts;
    *cp++ = 0x68; *cp++=sp;sp>>=8; *cp++=sp;sp>>=8; *cp++=sp;sp>>=8; *cp++=sp;
@@ -571,13 +646,13 @@ StgAddr createAdjThunk_x86_ccall ( StgStablePtr stableptr,
    ch = ch - ( ((unsigned int)cp) + 5);
    *cp++ = 0xE8; *cp++=ch;ch>>=8; *cp++=ch;ch>>=8; *cp++=ch;ch>>=8; *cp++=ch;
 
-   *cp++ = 0x83; *cp++ = 0xC4; *cp++ = 0x0C;
+   *cp++ = 0x89; *cp++ = 0xDC;
    *cp++ = 0x5D;
    *cp++ = 0x5F;
    *cp++ = 0x5E;
    *cp++ = 0x59;
    *cp++ = 0x5B;
-   *cp++ = 0xC3;
+   *cp++ = 0xC2; *cp++=nwords;nwords>>=8; *cp++=nwords;
 
    return codeblock;
 }
@@ -589,9 +664,16 @@ StgAddr createAdjThunk_x86_ccall ( StgStablePtr stableptr,
  * ----------------------------------------------------------------*/
 
 StgAddr createAdjThunk ( StgStablePtr stableptr,
-                         StgAddr      typestr )
+                         StgAddr      typestr,
+                         StgChar      callconv )
 {
-   return createAdjThunk_x86_ccall ( stableptr, typestr );
+   return 
+#if i386_TARGET_ARCH
+      createAdjThunk_x86 ( stableptr, typestr, callconv );
+#else
+      0;
+      #warn foreign export not implemented on this architecture
+#endif
 }
 
 
diff --git a/ghc/rts/ForeignCall.h b/ghc/rts/ForeignCall.h
index f4df3fc21d..5bff124625 100644
--- a/ghc/rts/ForeignCall.h
+++ b/ghc/rts/ForeignCall.h
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: ForeignCall.h,v 1.6 1999/10/22 15:58:21 sewardj Exp $
+ * $Id: ForeignCall.h,v 1.7 1999/10/26 17:27:30 sewardj Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -11,8 +11,10 @@ typedef int StablePtr;
 
 extern int ccall ( CFunDescriptor* descriptor, 
                    void            (*fun)(void), 
-                   StgBCO**        bco 
+                   StgBCO**        bco,
+                   char            callconv
                  );
 
 extern StgAddr createAdjThunk ( StgStablePtr stableptr,
-                                StgAddr      typestr );
+                                StgAddr      typestr,
+                                StgChar      callconv );
diff --git a/ghc/rts/universal_call_c.S b/ghc/rts/universal_call_c.S
index 3f03ff3188..e34af9f0de 100644
--- a/ghc/rts/universal_call_c.S
+++ b/ghc/rts/universal_call_c.S
@@ -5,8 +5,8 @@
  * Copyright (c) 1994-1999.
  *
  * $RCSfile: universal_call_c.S,v $
- * $Revision: 1.3 $
- * $Date: 1999/10/22 15:58:26 $
+ * $Revision: 1.4 $
+ * $Date: 1999/10/26 17:27:31 $
  * ------------------------------------------------------------------------*/
 	
 #include "config.h"
@@ -66,6 +66,7 @@
 #endif
 	
 #if i386_TARGET_ARCH
+
 .globl universal_call_c_x86_ccall
 universal_call_c_x86_ccall:
 	pushl %ebp
@@ -77,61 +78,135 @@ universal_call_c_x86_ccall:
 	movl 16(%ebp),%edi
 	movl 8(%ebp),%ebx
 	testl %ebx,%ebx
-	jle docall
+	jle cdocall
 	
-looptop:
+clooptop:
 	cmpb $105,(%ebx,%edi)	# 'i'
-	jne .L6
+	jne .Lc6
 	pushl (%esi,%ebx,8)
-	jmp looptest
-.L6:
+	jmp clooptest
+.Lc6:
 	cmpb $73,(%ebx,%edi)	# 'I'
-	jne .L8
+	jne .Lc8
 	pushl 4(%esi,%ebx,8)
 	pushl (%esi,%ebx,8)
-	jmp looptest
-.L8:
+	jmp clooptest
+.Lc8:
 	cmpb $102,(%ebx,%edi)	# 'f'
-	jne .L10
+	jne .Lc10
 	movl (%esi,%ebx,8),%eax
 	pushl %eax
-	jmp looptest
-.L10:
+	jmp clooptest
+.Lc10:
 	cmpb $70,(%ebx,%edi)	# 'F'
-	jne looptest
+	jne clooptest
 	movl 4(%esi,%ebx,8),%eax
 	movl (%esi,%ebx,8),%edx
 	pushl %eax
 	pushl %edx
-looptest:
+clooptest:
 	decl %ebx
         testl %ebx,%ebx
-	jg looptop
+	jg clooptop
 
-docall:	
+cdocall:	
 	call *20(%ebp)
 	
 	cmpb $102,(%edi)	# 'f'
-	je float32
+	je cfloat32
 	cmpb $70,(%edi)		# 'F'
-	je float64
-iorI:
+	je cfloat64
+ciorI:
 	movl %eax,0(%esi)
 	movl %edx,4(%esi)
-	jmp bye
-float32:
+	jmp cbye
+cfloat32:
 	fstps 0(%esi)
-	jmp bye
-float64:
+	jmp cbye
+cfloat64:
 	fstpl 0(%esi)
-	jmp bye	
-bye:
+	jmp cbye	
+cbye:
 	leal -12(%ebp),%esp
 	popl %ebx
 	popl %esi
 	popl %edi
 	leave
 	ret
+
+
+	
+# Almost identical to the above piece of code
+# see comments near end for differences 
+	
+.globl universal_call_c_x86_stdcall
+universal_call_c_x86_stdcall:
+	pushl %ebp
+	movl %esp,%ebp
+	pushl %edi
+	pushl %esi
+	pushl %ebx
+	movl 12(%ebp),%esi
+	movl 16(%ebp),%edi
+	movl 8(%ebp),%ebx
+	testl %ebx,%ebx
+	jle sdocall
+	
+slooptop:
+	cmpb $105,(%ebx,%edi)	# 'i'
+	jne .Ls6
+	pushl (%esi,%ebx,8)
+	jmp slooptest
+.Ls6:
+	cmpb $73,(%ebx,%edi)	# 'I'
+	jne .Ls8
+	pushl 4(%esi,%ebx,8)
+	pushl (%esi,%ebx,8)
+	jmp slooptest
+.Ls8:
+	cmpb $102,(%ebx,%edi)	# 'f'
+	jne .Ls10
+	movl (%esi,%ebx,8),%eax
+	pushl %eax
+	jmp slooptest
+.Ls10:
+	cmpb $70,(%ebx,%edi)	# 'F'
+	jne slooptest
+	movl 4(%esi,%ebx,8),%eax
+	movl (%esi,%ebx,8),%edx
+	pushl %eax
+	pushl %edx
+slooptest:
+	decl %ebx
+        testl %ebx,%ebx
+	jg slooptop
+
+sdocall:	
+	call *20(%ebp)
+	
+	cmpb $102,(%edi)	# 'f'
+	je sfloat32
+	cmpb $70,(%edi)		# 'F'
+	je sfloat64
+siorI:
+	movl %eax,0(%esi)
+	movl %edx,4(%esi)
+	jmp sbye
+sfloat32:
+	fstps 0(%esi)
+	jmp sbye
+sfloat64:
+	fstpl 0(%esi)
+	jmp sbye	
+sbye:
+	## don_t clear the args -- the callee does it
+	## leal -12(%ebp),%esp
+	popl %ebx
+	popl %esi
+	popl %edi
+	leave
+	ret $16       # but we have to clear our own!
+
 #endif /* i386_TARGET_ARCH */
 	
 #endif /* INTERPRETER */
\ No newline at end of file