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.
/* -----------------------------------------------------------------------------
- * $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.
*
* 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;
* 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 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
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
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));
* 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"
return GetProcAddress(instance,symbol);
}
+Bool stdcallAllowed ( void )
+{
+ return TRUE;
+}
+
+
+
+
+
+
#elif HAVE_DLFCN_H /* eg LINUX, SOLARIS, ULTRIX */
#include <stdio.h>
EEND;
}
+Bool stdcallAllowed ( void )
+{
+ return FALSE;
+}
+
+
+
+
+
+
#elif HAVE_DL_H /* eg HPUX */
#include <dl.h>
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 */
#endif
}
+Bool stdcallAllowed ( void )
+{
+ return FALSE;
+}
+
#endif /* Dynamic loading not available */
-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));
* 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"
static Text textExport, textDynamic, textUUExport;
static Text textUnsafe, textUUAll;
+Text textCcall; /* ccall */
+Text textStdcall; /* stdcall */
+
Text textNum; /* Num */
Text textPrelude; /* Prelude */
Text textPlus; /* (+) */
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;
textInstImport = findText("__instimport");
textExport = findText("export");
textDynamic = findText("dynamic");
+ textCcall = findText("ccall");
+ textStdcall = findText("stdcall");
textUUExport = findText("__export");
textImport = findText("import");
textHiding = findText("hiding");
-- debugging hacks
--,ST(..)
+ ,primIntToAddr
) where
-- Standard value bindings {Prelude} ----------------------------------------
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:
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
* 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 $
* ------------------------------------------------------------------------*/
%{
%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 -------------------------------------*/
/*- 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;}
;
* 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"
* 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; {
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 */
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; {
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 */
* 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"
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;
* 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 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
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;
};
* 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"
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"); */
}
/* --------------------------------------------------------------------------
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! */
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)) {
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))),
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;
*
* \ 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
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;
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;
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);
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;
-- debugging hacks
--,ST(..)
+ ,primIntToAddr
) where
-- Standard value bindings {Prelude} ----------------------------------------
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:
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
* 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.
, { "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 }
/* 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 )
/* -----------------------------------------------------------------------------
- * $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
*
#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 */
* 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"
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:
* 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"
{
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;
}
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(
/* -----------------------------------------------------------------------------
- * $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.
*
* 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
* 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];
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 );
/* ----------------------------------------------------------------*
- * 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
break;
default:
barf(
- "unpackArgsAndCallHaskell_x86_ccall: unexpected arg type rep");
+ "unpackArgsAndCallHaskell_x86_nocallconv: "
+ "unexpected arg type rep");
}
argp++;
}
sstat = rts_eval ( node, &nodeOut );
if (sstat != Success)
- barf ("unpackArgsAndCallHaskell_x86_ccall: eval failed");
+ barf ("unpackArgsAndCallHaskell_x86_nocallconv: eval failed");
return nodeOut;
}
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.
*/
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.
*/
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
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;
*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;
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;
}
* ----------------------------------------------------------------*/
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
}
/* -----------------------------------------------------------------------------
- * $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
*
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 );
* 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"
#endif
#if i386_TARGET_ARCH
+
.globl universal_call_c_x86_ccall
universal_call_c_x86_ccall:
pushl %ebp
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
projects / ghc-hetmet.git / commitdiff