/* -----------------------------------------------------------------------------
- * $Id: ForeignCall.c,v 1.6 1999/10/19 11:01:26 sewardj Exp $
+ * $Id: ForeignCall.c,v 1.16 2000/05/12 11:59:39 sewardj Exp $
*
* (c) The GHC Team 1994-1999.
*
- * Foreign Function calls
- *
+ * Implementation of foreign import and foreign export.
* ---------------------------------------------------------------------------*/
#include "Rts.h"
#ifdef INTERPRETER
-#include "Assembler.h" /* for CFun stuff */
+#include "RtsUtils.h" /* barf :-) */
+#include "Assembler.h" /* for CFun stuff */
+#include "Schedule.h"
#include "Evaluator.h"
#include "ForeignCall.h"
+/* Exports of this file:
+ mkDescriptor
+ ccall
+ createAdjThunk
+ Everything else is local, I think.
+*/
+
+/* ----------------------------------------------------------------------
+ * Some misc-ery to begin with.
+ * --------------------------------------------------------------------*/
+
+CFunDescriptor* mkDescriptor( char* as, char* rs )
+{
+ /* ToDo: don't use malloc */
+ CFunDescriptor *d = malloc(sizeof(CFunDescriptor));
+ if (d == NULL) return d;
+ d->arg_tys = as;
+ d->result_tys = rs;
+ d->num_args = strlen(as);
+ d->num_results = strlen(rs);
+ return d;
+}
+
+
+/* ----------------------------------------------------------------------
+ * Part the first: CALLING OUT -- foreign import
+ * --------------------------------------------------------------------*/
-/* --------------------------------------------------------------------------
+/* SOME NOTES ABOUT PARAMETERISATION.
+
+ These pertain equally to foreign import and foreign export.
+
+ Implementations for calling in and out are very architecture
+ dependent. After some consideration, it appears that the two
+ important factors are the instruction set, and the calling
+ convention used. Factors like the OS and compiler are not
+ directly relevant.
+
+ So: routines which are architecture dependent are have
+ _instructionsetname_callingconventionname attached to the
+ the base name. For example, code specific to the ccall
+ convention on x86 would be suffixed _x86_ccall.
+
+ A third possible dimension of parameterisation relates to the
+ split between callee and caller saves registers. For example,
+ x86_ccall code needs to assume a split, and different splits
+ using ccall on x86 need different code. However, that does not
+ yet seem an issue, so it is ignored here.
+*/
+
+
+/* ------------------------------------------------------------------
* Calling out to C: a simple, universal calling API
- * ------------------------------------------------------------------------*/
+ * ----------------------------------------------------------------*/
/* The universal call-C API supplies a single function:
have to be handwritten assembly. The above design is intended
to make that assembly as simple as possible, at the expense
of a small amount of complication for the API's user.
-*/
-/* ToDo: move these to the Right Place */
-extern StgInt PopTaggedInt ( void ) ;
-extern StgDouble PopTaggedDouble ( void ) ;
-extern StgFloat PopTaggedFloat ( void ) ;
-extern StgChar PopTaggedChar ( void ) ;
-extern StgAddr PopTaggedAddr ( void ) ;
+ These architecture-dependent assembly routines are in
+ rts/universal_call_c.S.
+*/
-extern void PushTaggedInt ( StgInt );
-extern void PushTaggedDouble ( StgDouble );
-extern void PushTaggedFloat ( StgFloat );
-extern void PushTaggedChar ( StgChar );
-extern void PushTaggedAddr ( StgAddr );
-extern void PushPtr ( StgPtr );
-extern StgPtr PopPtr ( void );
+/* ----------------------------------------------------------------*
+ * External refs for the assembly routines.
+ * ----------------------------------------------------------------*/
+
+#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 universal_call_c_arch_callingconvention is not available.
+ * ----------------------------------------------------------------*/
+
+static void universal_call_c_generic
+( int n_args,
+ void* args,
+ char* argstr,
+ void* fun )
+{
+ unsigned int *p = (unsigned int*) args;
+
+#define ARG(n) (p[n*2])
+#define CMP(str) ((n_args + 1 == (int)strlen(str)) && \
+ (!strncmp(str,argstr,n_args + 1)))
+
+#define CALL(retType,callTypes,callVals) \
+ ((retType(*)callTypes)(fun))callVals
+
+ if (CMP("i")) {
+ int res = CALL(int,(void),());
+ ARG(0) = res;
+ } else if (CMP("ii")) {
+ int arg1 = (int) ARG(1);
+ int res = CALL(int,(int),(arg1));
+ ARG(0) = res;
+ } else if (CMP("iii")) {
+ int arg1 = (int) ARG(1);
+ int arg2 = (int) ARG(2);
+ int res = CALL(int,(int,int),(arg1,arg2));
+ ARG(0) = res;
+ } else {
+ /* Do not have the generic call for this argument list. */
+ int i;
+ printf("Can not call external function at address %d\n",(int)fun);
+ printf("Argument string = '");
+ for(i=0;i<n_args;i++) {
+ printf("%c",(char)argstr[i]);
+ }
+ printf("' [%d arg(s)]\n",n_args);
+ assert(0);
+ }
+#undef CALL
+#undef CMP
+#undef ARG
+}
-/* --------------------------------------------------------------------------
+/* ----------------------------------------------------------------*
* Move args/results between STG stack and the above API's arg block
* Returns 0 on success
* 1 if too many args/results or non-handled type
* 2 if config error on this platform
* Tries to automatically handle 32-vs-64 bit differences.
- * ------------------------------------------------------------------------*/
-
-int ccall ( CFunDescriptor* d, void (*fun)(void), StgBCO** bco )
+ * Assumes an LP64 programming model for 64 bit:
+ * sizeof(long)==sizeof(void*)==64 on a 64 bit platform
+ * sizeof(int)==32 on a 64 bit platform
+ * This code attempts to be architecture neutral (viz, generic).
+ * ----------------------------------------------------------------*/
+
+int ccall ( CFunDescriptor* d,
+ void (*fun)(void),
+ StgBCO** bco,
+ char cc,
+ Capability* cap
+ )
{
double arg_vec [31];
char argd_vec[31];
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))
+ || (sizeof(void*) != 4 && sizeof(void*) != 8)
+ || (sizeof(unsigned long) != sizeof(void*)))
return 2;
if (d->num_args > 30 || d->num_results > 1)
return 1; /* unlikely, but ... */
- //fprintf ( stderr, "ccall: `%s' %d -> `%s' %d\n",
- // d-> arg_tys, d->num_args, d->result_tys, d->num_results );
-
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 CHAR_REP: {
- int j = (int)PopTaggedChar();
- *p++ = j; *p++ = 0;
- argd_vec[i+1] = 'i';
- break;
- }
- case INT_REP: {
- int j = PopTaggedInt();
- *p++ = j; *p++ = 0;
- argd_vec[i+1] = 'i';
- break;
- }
- case ADDR_REP: {
- void* a = PopTaggedAddr();
+
+ case INT_REP:
+ ul = (unsigned long)PopTaggedInt();
+ goto common_int32_or_64;
+ case WORD_REP:
+ ul = (unsigned long)PopTaggedWord();
+ goto common_int32_or_64;
+ case ADDR_REP:
+ ul = (unsigned long)(PopTaggedAddr());
+ goto common_int32_or_64;
+ case STABLE_REP:
+ ul = (unsigned long)PopTaggedStablePtr();
+ common_int32_or_64:
if (sizeof(void*) == 4) {
- *(void**)p = a; p++; *p++ = 0;
+ *(unsigned long *)p = ul; p++; *p++ = 0;
argd_vec[i+1] = 'i';
} else {
- *(void**)p = a;
+ *(unsigned long *)p = ul;
p += 2;
argd_vec[i+1] = 'I';
}
break;
+
+ case CHAR_REP: {
+ int j = (int)PopTaggedChar();
+ *p++ = j; *p++ = 0;
+ argd_vec[i+1] = 'i';
+ break;
}
case FLOAT_REP: {
float f = PopTaggedFloat();
argd_vec[0] = 'i';
} else {
switch (d->result_tys[0]) {
- case CHAR_REP: case INT_REP:
- argd_vec[0] = 'i'; break;
- case ADDR_REP:
+ case INT_REP: case WORD_REP: case ADDR_REP: case STABLE_REP:
argd_vec[0] = (sizeof(void*)==4) ? 'i' : 'I'; break;
+ case CHAR_REP:
+ argd_vec[0] = 'i'; break;
case FLOAT_REP:
argd_vec[0] = 'f'; break;
case DOUBLE_REP:
}
PushPtr((StgPtr)(*bco));
- SaveThreadState();
-
- //fprintf(stderr, " argc=%d arg_vec=%p argd_vec=%p `%s' fun=%p\n",
- // d->num_args, arg_vec, argd_vec, argd_vec, fun );
-
- universal_call_c_x86_linux (
+ 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')
+ 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 );
- LoadThreadState();
+#endif
+
+ 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
+ since the result is in the bytes starting at p regardless. */
+
if (d->num_results > 0) {
p = (unsigned int*) &arg_vec[0];
switch (d->result_tys[0]) {
- case CHAR_REP:
- PushTaggedChar ( (StgChar) p[0]);
- break;
+
case INT_REP:
PushTaggedInt ( ((StgInt*)p) [0] );
break;
+ case WORD_REP:
+ PushTaggedWord ( ((StgWord*)p) [0] );
+ break;
case ADDR_REP:
- if (sizeof(void*) == 4)
- PushTaggedAddr ( ((StgAddr*)p) [0] );
- else
- PushTaggedAddr ( ((StgAddr*)p) [0] );
+ PushTaggedAddr ( ((StgAddr*)p) [0] );
+ break;
+ case STABLE_REP:
+ PushTaggedStablePtr ( ((StgStablePtr*)p) [0] );
+ break;
+
+ case CHAR_REP:
+ PushTaggedChar ( (StgChar) p[0]);
break;
case FLOAT_REP:
PushTaggedFloat ( ((StgFloat*)p) [0] );
case DOUBLE_REP:
PushTaggedDouble ( ((StgDouble*)p) [0] );
break;
+
default:
return 1;
}
-CFunDescriptor* mkDescriptor( char* as, char* rs )
-{
- /* ToDo: don't use malloc */
- CFunDescriptor *d = malloc(sizeof(CFunDescriptor));
- if (d == NULL) return d;
- d->arg_tys = as;
- d->result_tys = rs;
- d->num_args = strlen(as);
- d->num_results = strlen(rs);
- return d;
+/* ----------------------------------------------------------------------
+ * Part the second: CALLING IN -- foreign export {dynamic}
+ * --------------------------------------------------------------------*/
+
+/* Make it possible for the evaluator to get hold of bytecode
+ for a given function by name. Useful but a hack. Sigh.
+ */
+extern void* /* StgClosure* */ getHugs_BCO_cptr_for ( char* s );
+extern int /*Bool*/ combined;
+
+/* ----------------------------------------------------------------*
+ * The implementation for x86_ccall and x86_stdcall.
+ * ----------------------------------------------------------------*/
+
+static
+HaskellObj
+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
+ string tydesc. Dereference the stable pointer, giving the
+ Haskell function to call. Build an application of this to
+ the arguments, and finally wrap primRunST round the whole
+ thing, since we know it returns an IO type. Then evaluate
+ the whole, which leaves nodeOut as the evaluated 'a', where
+ the type of the function called is .... -> IO a.
+
+ We can't immediately unpack the results and return, since
+ int results need to return in a different register (%eax and
+ possibly %edx) from float things (%st(0)). So return nodeOut
+ to the relevant wrapper function, which knows enough about
+ the return type to do the Right Thing.
+
+ There's no getting round it: this is most heinous hack.
+ */
+
+ HaskellObj node;
+ HaskellObj nodeOut;
+ SchedulerStatus sstat;
+
+ char* resp = tydesc;
+ char* argp = tydesc;
+
+ node = (HaskellObj)deRefStablePtr(stableptr);
+
+ if (*argp != ':') argp++;
+ ASSERT( *argp == ':' );
+ argp++;
+ while (*argp) {
+ switch (*argp) {
+ case CHAR_REP:
+ node = rts_apply ( node, rts_mkChar ( *(char*)args ) );
+ args += 4;
+ break;
+ case INT_REP:
+ node = rts_apply ( node, rts_mkInt ( *(int*)args ) );
+ args += 4;
+ break;
+ case WORD_REP:
+ node = rts_apply ( node, rts_mkWord ( *(unsigned int*)args ) );
+ args += 4;
+ break;
+ case ADDR_REP:
+ node = rts_apply ( node, rts_mkAddr ( *(void**)args ) );
+ args += 4;
+ break;
+ case STABLE_REP:
+ node = rts_apply ( node, rts_mkStablePtr ( *(int*)args ) );
+ args += 4;
+ break;
+ case FLOAT_REP:
+ node = rts_apply ( node, rts_mkFloat ( *(float*)args ) );
+ args += 4;
+ break;
+ case DOUBLE_REP:
+ node = rts_apply ( node, rts_mkDouble ( *(double*)args ) );
+ args += 8;
+ break;
+ default:
+ barf(
+ "unpackArgsAndCallHaskell_x86_nocallconv: "
+ "unexpected arg type rep");
+ }
+ argp++;
+ }
+
+ if (combined) {
+ sstat = rts_evalIO ( node, &nodeOut );
+ } else {
+ node = rts_apply (
+ getHugs_BCO_cptr_for("runST"),
+ node );
+ sstat = rts_eval ( node, &nodeOut );
+ }
+
+ if (sstat != Success)
+ barf ("unpackArgsAndCallHaskell_x86_nocallconv: eval failed");
+
+ return nodeOut;
+}
+
+
+static
+double
+unpackArgsAndCallHaskell_x86_nocallconv_DOUBLE (
+ StgStablePtr stableptr, char* tydesc, char* args
+ )
+{
+ HaskellObj nodeOut
+ = unpackArgsAndCallHaskell_x86_nocallconv_wrk (
+ stableptr, tydesc, args
+ );
+ /* Return a double. This return will go into %st(0), which
+ is unmodified by the adjustor thunk.
+ */
+ ASSERT(tydesc[0] == DOUBLE_REP);
+ return rts_getDouble(nodeOut);
+}
+
+
+static
+float
+unpackArgsAndCallHaskell_x86_nocallconv_FLOAT (
+ StgStablePtr stableptr, char* tydesc, char* args
+ )
+{
+ HaskellObj nodeOut
+ = unpackArgsAndCallHaskell_x86_nocallconv_wrk (
+ stableptr, tydesc, args
+ );
+ /* Probably could be merged with the double case, since %st(0) is
+ still the return register.
+ */
+ ASSERT(tydesc[0] == FLOAT_REP);
+ return rts_getFloat(nodeOut);
+}
+
+
+static
+unsigned long
+unpackArgsAndCallHaskell_x86_nocallconv_INTISH (
+ StgStablePtr stableptr, char* tydesc, char* 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
+ (C-world) caller without modifying %eax or %edx, so the
+ original caller will be a Happy Bunny.
+ */
+ switch (*tydesc) {
+ case ':': return 0;
+ case CHAR_REP: return (unsigned long)rts_getChar(nodeOut);
+ case INT_REP: return (unsigned long)rts_getInt(nodeOut);
+ case WORD_REP: return (unsigned long)rts_getWord(nodeOut);
+ case ADDR_REP: return (unsigned long)rts_getAddr(nodeOut);
+ case STABLE_REP: return (unsigned long)rts_getStablePtr(nodeOut);
+ default:
+ barf(
+ "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 ( StgStablePtr stableptr,
+ StgAddr typestr,
+ char callconv )
+{
+ unsigned char* codeblock;
+ unsigned char* cp;
+ 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_nocallconv_DOUBLE;
+ else if (((char*)typestr)[0] == FLOAT_REP)
+ ch = (unsigned int)
+ &unpackArgsAndCallHaskell_x86_nocallconv_FLOAT;
+ else
+ 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;
+ /*
+ 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 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++ = 0x57;
+ *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;
+
+ /* call address needs to be: displacement relative to next insn */
+ ch = ch - ( ((unsigned int)cp) + 5);
+ *cp++ = 0xE8; *cp++=ch;ch>>=8; *cp++=ch;ch>>=8; *cp++=ch;ch>>=8; *cp++=ch;
+
+ *cp++ = 0x89; *cp++ = 0xDC;
+ *cp++ = 0x5D;
+ *cp++ = 0x5F;
+ *cp++ = 0x5E;
+ *cp++ = 0x59;
+ *cp++ = 0x5B;
+ *cp++ = 0xC2; *cp++=nwords;nwords>>=8; *cp++=nwords;
+
+ return codeblock;
+}
+
+
+/* ----------------------------------------------------------------*
+ * The only function involved in foreign-export that needs to be
+ * visible outside this file.
+ * ----------------------------------------------------------------*/
+
+StgAddr createAdjThunk ( StgStablePtr stableptr,
+ StgAddr typestr,
+ StgChar callconv )
+{
+ return
+#if i386_TARGET_ARCH
+ createAdjThunk_x86 ( stableptr, typestr, callconv );
+#else
+ 0;
+#warning foreign export not implemented on this architecture
+#endif
}
+
#endif /* INTERPRETER */
+
projects / ghc-hetmet.git / blobdiff