/* -----------------------------------------------------------------------------
- * $Id: ForeignCall.c,v 1.5 1999/10/15 11:03:06 sewardj Exp $
+ * $Id: ForeignCall.c,v 1.6 1999/10/19 11:01:26 sewardj Exp $
*
* (c) The GHC Team 1994-1999.
*
#include "Evaluator.h"
#include "ForeignCall.h"
-/* the assymetry here seem to come from the caller-allocates
- * calling convention. But does the caller really allocate
- * result??
- */
-void hcall( HFunDescriptor* d, StablePtr fun, void* as, void* rs)
-{
-#if 0
- /* out of date - ADR */
- marshall(d->arg_tys,as);
- prim_hcall(fun);
- unmarshall(d->result_tys,rs);
-#else
- assert(0);
-#endif
-}
+/* --------------------------------------------------------------------------
+ * Calling out to C: a simple, universal calling API
+ * ------------------------------------------------------------------------*/
-#if 0
-/* By experiment on an x86 box, we found that gcc's
- * __builtin_apply(fun,as,size) expects *as to look like this:
- * as[0] = &first arg = &as[1]
- * as[1] = arg1
- * as[2] = arg2
- * ...
- *
- * on an x86, it returns a pointer to a struct containing an
- * int/int64/ptr in its first 4-8 bytes and a float/double in the next
- * 8 bytes.
- *
- * On a sparc:
- * as[0] = &first arg = &as[2]
- * as[1] = where structures should be returned
- * as[2] = arg1
- * as[3] = arg2
- * ...
- *
- * This is something of a hack - but seems to be more portable than
- * hacking it up in assembly language which is how I did it before - ADR
- */
-void ccall( CFunDescriptor* d, void (*fun)(void) )
-{
- void *rs;
- char* tys = d->arg_tys;
- /* ToDo: the use of ARG_SIZE is based on the assumption that Hugs
- * obeys the same alignment restrictions as C.
- * But this is almost certainly wrong!
- * We could use gcc's __va_rounded_size macro (see varargs.h) to do a
- * better job.
- */
-#if i386_TARGET_ARCH
- void *as=alloca(4 + d->arg_size);
- StgWord* args = (StgWord*) as;
- *(void**)(args++) = 4 + (char*)as; /* incoming args ptr */
- for(; *tys; ++tys) {
- args += unmarshall(*tys,args);
- }
- rs = __builtin_apply(fun,as,(char*)args-(char*)as-4);
-#elif sparc_TARGET_ARCH
- void *as=alloca(8 + d->arg_size);
- StgWord* args = (StgWord*) as;
- int argcount;
- *(void**)(args++) = (char*)as; /* incoming args ptr */
- *(void**)(args++) = 0; /* structure value address - I think this is the address of a block of memory where structures are returned - in which case we should initialise with rs or something like that*/
- for(; *tys; ++tys) {
- args += unmarshall(*tys,args);
- }
- argcount = ((void*)args - as);
- ASSERT(8 + d->arg_size == argcount);
- if (argcount <= 8) {
- argcount = 0;
- } else {
- argcount -= 4;
- }
- rs = __builtin_apply(fun,as,argcount);
-#else
-#error Cant do ccall for this architecture
-#endif
-
- /* ToDo: can't handle multiple return values at the moment
- * - it's hard enough to get single return values working
- */
- if (*(d->result_tys)) {
- char ty = *(d->result_tys);
- ASSERT(d->result_tys[1] == '\0');
- switch (ty) {
- case 'F':
- case 'D':
- /* ToDo: is this right? */
- marshall(ty,(char*)rs+8);
- return;
- default:
- marshall(ty,rs);
- return;
- }
- }
-}
-#endif
+/* The universal call-C API supplies a single function:
+
+ void universal_call_c ( int n_args,
+ void* args,
+ char* argstr,
+ void* fun )
+
+ PRECONDITIONS
+
+ args points to the start of a block of memory containing the
+ arguments. This block is an array of 8-byte entities,
+ containing (n_args+1) slots. The zeroth slot is where the
+ return result goes. Slots [1 .. n_args] contain the arguments,
+ presented left-to-right.
+
+ Arguments are stored in the host's byte ordering inside
+ the slots. Only 4 or 8 byte entities are allowed.
+ 4-byte entities are stored in the half-slot with lower
+ addresses.
+
+ For example, a 32-bit value 0xAABBCCDD would be stored, on
+ a little-endian, as
+
+ DD CC BB AA 0 0 0 0
+
+ whereas on a big-endian would expect
+
+ AA BB CC DD 0 0 0 0
+
+ Clients do not need to fill in the zero bytes; they are there
+ only for illustration.
+
+ argstr is a simplified argument descriptor string. argstr
+ has one character for each (notional) argument slot of
+ args. That means the first byte of argstr describes the
+ return type. args should be allocated by the caller to hold
+ as many slots as implied by argstr.
+
+ argstr always specifies a return type. If the function to
+ be called returns no result, you must specify a bogus
+ return type in argstr[0]; a 32-bit int seems like a good bet.
+ Characters in argstr specify the result and argument types:
+ i 32-bit integral
+ I 64-bit integral
+ f 32-bit floating
+ F 64-bit floating
+ Pointers should travel as integral entities. At the moment
+ there are no descriptors for entities smaller than 32 bits
+ since AFAIK all calling conventions expand smaller entities
+ to 32 bits anyway. Users of this routine need to handle
+ packing/unpacking of 16 and 8 bit quantities themselves.
-#if 1
-/* HACK alert (red alert) */
+ If the preconditions are not met, behaviour of
+ universal_call_c is entirely undefined.
+
+
+ POSTCONDITION
+
+ The function specified by fun is called with arguments
+ in args as specified by argstr. The result of the call
+ is placed in the first 8 bytes of args, again as specified
+ by the first byte of argstr. Calling and returning is to
+ be done using the correct calling convention for the
+ architecture.
+
+ It's clear that implementations of universal_call_c will
+ 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 ) ;
-extern void PushTaggedInt ( StgInt );
-extern void PushTaggedAddr ( StgAddr );
+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 );
-int seqNr = 0;
-#define IF(sss) if (strcmp(sss,cdesc)==0)
-#define STS PushPtr((StgPtr)(*bco));SaveThreadState()
-#define LTS LoadThreadState();*bco=(StgBCO*)PopPtr();
-#define LTS_RET LoadThreadState();*bco=(StgBCO*)PopPtr(); return
-#define RET return
-void ccall( CFunDescriptor* d, void (*fun)(void), StgBCO** bco )
+/* --------------------------------------------------------------------------
+ * 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 )
{
- int i;
- char cdesc[100];
- strcpy(cdesc, d->result_tys);
- strcat(cdesc, ":");
- strcat(cdesc, d->arg_tys);
- for (i = 0; cdesc[i] != 0; i++) {
- switch (cdesc[i]) {
- case 'x': cdesc[i] = 'A'; break;
- default: break;
+ double arg_vec [31];
+ char argd_vec[31];
+ unsigned int* p;
+ int i;
+
+ if (sizeof(int) != 4 || sizeof(double) != 8 || sizeof(float) != 4
+ || (sizeof(void*) != 4 && sizeof(void*) != 8))
+ 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++) {
+ 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();
+ if (sizeof(void*) == 4) {
+ *(void**)p = a; p++; *p++ = 0;
+ argd_vec[i+1] = 'i';
+ } else {
+ *(void**)p = a;
+ p += 2;
+ argd_vec[i+1] = 'I';
+ }
+ break;
+ }
+ case FLOAT_REP: {
+ float f = PopTaggedFloat();
+ *(float*)p = f; p++; *p++ = 0;
+ argd_vec[i+1] = 'f';
+ break;
+ }
+ case DOUBLE_REP: {
+ double d = PopTaggedDouble();
+ *(double*)p = d; p+=2;
+ argd_vec[i+1] = 'F';
+ break;
+ }
+ default:
+ return 1;
}
}
- //fprintf(stderr, "ccall: %d cdesc = `%s'\n", seqNr++, cdesc);
-
- IF(":") { STS; ((void(*)(void))(fun))(); LTS_RET; };
-
- IF(":I") { int a1=PopTaggedInt();
- STS; ((void(*)(int))(fun))(a1); LTS_RET; };
- IF(":A") { void* a1=PopTaggedAddr();
- STS; ((void(*)(void*))(fun))(a1); LTS_RET; };
-
- IF("I:") { int r;
- STS; r= ((int(*)(void))(fun))(); LTS;
- PushTaggedInt(r); RET ;};
-
- IF(":II") { int a1=PopTaggedInt(); int a2=PopTaggedInt();
- STS; ((void(*)(int,int))(fun))(a1,a2); LTS_RET; };
- IF(":AI") { void* a1=PopTaggedAddr(); int a2=PopTaggedInt();
- STS; ((void(*)(void*,int))(fun))(a1,a2); LTS_RET; };
-
- IF("I:I") { int a1=PopTaggedInt(); int r;
- STS; r=((int(*)(int))(fun))(a1); LTS;
- PushTaggedInt(r); RET; };
- IF("A:I") { int a1=PopTaggedInt(); void* r;
- STS; r=((void*(*)(int))(fun))(a1); LTS;
- PushTaggedAddr(r); RET; };
- IF("A:A") { void* a1=PopTaggedAddr(); void* r;
- STS; r=((void*(*)(void*))(fun))(a1); LTS;
- PushTaggedAddr(r); RET; };
-
- IF("I:II") { int a1=PopTaggedInt(); int a2=PopTaggedInt(); int r;
- STS; r=((int(*)(int,int))(fun))(a1,a2); LTS;
- PushTaggedInt(r); RET; };
- IF("I:AI") { void* a1=PopTaggedAddr(); int a2=PopTaggedInt(); int r;
- STS; r=((int(*)(void*,int))(fun))(a1,a2); LTS;
- PushTaggedInt(r); RET; };
- IF("A:AI") { void* a1=PopTaggedAddr(); int a2=PopTaggedInt(); void* r;
- STS; r=((void*(*)(void*,int))(fun))(a1,a2); LTS;
- PushTaggedAddr(r); RET; };
-
- IF("I:III") { int a1=PopTaggedInt(); int a2=PopTaggedInt();
- int a3=PopTaggedInt(); int r;
- STS; r=((int(*)(int,int,int))(fun))(a1,a2,a3); LTS;
- PushTaggedInt(r); RET; };
-
- IF(":AIDCF") { void* a1 = PopTaggedAddr();
- int a2 = PopTaggedInt();
- double a3 = PopTaggedDouble();
- char a4 = PopTaggedChar();
- float a5 = PopTaggedFloat();
- STS;
- ((void(*)(void*,int,double,char,float))(fun))(a1,a2,a3,a4,a5);
- LTS_RET; };
-
-
-fprintf(stderr,"panic: ccall cdesc `%s' not implemented\n", cdesc );
- exit(1);
-
-
-fprintf(stderr,
- "ccall: arg_tys %s arg_size %d result_tys %s result_size %d\n",
- d->arg_tys, d->arg_size, d->result_tys, d->result_size );
-}
-
-#undef IF
-#undef STS
-#undef LTS
-#undef LTS_RET
-#undef RET
-
-#endif
-
-
+ if (d->num_results == 0) {
+ argd_vec[0] = 'i';
+ } else {
+ switch (d->result_tys[0]) {
+ case CHAR_REP: case INT_REP:
+ argd_vec[0] = 'i'; break;
+ case ADDR_REP:
+ argd_vec[0] = (sizeof(void*)==4) ? 'i' : 'I'; break;
+ case FLOAT_REP:
+ argd_vec[0] = 'f'; break;
+ case DOUBLE_REP:
+ argd_vec[0] = 'F'; break;
+ default:
+ return 1;
+ }
+ }
+
+ 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 (
+ d->num_args, (void*)arg_vec, argd_vec, fun );
+ LoadThreadState();
+ *bco=(StgBCO*)PopPtr();
+
+ 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 ADDR_REP:
+ if (sizeof(void*) == 4)
+ PushTaggedAddr ( ((StgAddr*)p) [0] );
+ else
+ PushTaggedAddr ( ((StgAddr*)p) [0] );
+ break;
+ case FLOAT_REP:
+ PushTaggedFloat ( ((StgFloat*)p) [0] );
+ break;
+ case DOUBLE_REP:
+ PushTaggedDouble ( ((StgDouble*)p) [0] );
+ break;
+ default:
+ return 1;
+ }
+ }
+ return 0;
+}
CFunDescriptor* mkDescriptor( char* as, char* rs )
{
/* ToDo: don't use malloc */
- CFunDescriptor *d = malloc(sizeof(CFunDescriptor));
- assert(d);
- d->arg_tys = as;
- d->arg_size = argSize(as);
- d->result_tys = rs;
- d->result_size = argSize(rs);
+ 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;
}
+++ /dev/null
-/* --------------------------------------------------------------------------
- * Assembly code to call C and Haskell functions
- *
- * Copyright (c) 1994-1998.
- *
- * $RCSfile: callfun.S,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/15 13:08:03 $
- * ------------------------------------------------------------------------*/
-
-#include "config.h"
-#include "options.h"
-
-#ifdef INTERPRETER
- .file "callfun.S"
-
-/* No longer needed - I finally figured out how to use __builtin_apply */
-#if 0 && i386_TARGET_ARCH
-
-#if 0
- void ccall( CFunDescriptor* d, void* fun )
- {
- void *rs=alloca(d->result_size);
- void *as=alloca(d->arg_size);
- unmarshall(d->arg_tys,as);
- rs = fun(as) ;
- marshall(d->result_tys,rs);
- }
-
- On entry, we have:
- ret = 0(%esp)
- d = 4(%esp)
- fun = 8(%esp)
-
- We assume that %ebp is a callee saves register
- and that %ecx is not used to return the result.
- If %ecx is a callee saves register (I think it is), the code
- can be optimised slightly - but I doubt its worth it.
-#endif
-.globl ccall
-ccall:
- pushl %ebp /* Save stack frame pointer */
- pushl %ecx /* Save callee-saves register */
-
- leal 8(%esp), %ebp /* ebp = frame pointer */
- movl 4(%ebp), %ecx /* ecx = d; */
- subl 12(%ecx), %esp /* rs = alloca(d->result_size); */
- subl 4(%ecx), %esp /* as = alloca(d->arg_size); */
-
- /* Marshall arguments off STG stack */
- pushl %esp
- pushl 0(%ecx)
- call unmarshall
- addl $8,%esp /* unmarshall(d->arg_tys,as); */
-
- /* Call function */
- movl 8(%ebp), %ecx
- call *%ecx /* rs = fun(as); */
-
- movl 4(%ebp), %ecx /* ecx = d; */
- addl 4(%ecx), %esp /* free(as) */
-
-
- /* Save result in rs - assume one or zero results for now */
- movl 8(%ecx), %ecx /* ecx = d->result_tys */
-
- cmpl $0,(%ecx) /* '\0' = no result */
- je .args_saved
-
- cmpl $70,(%ecx) /* 'F' = float result */
- jne .not_float
- flds (%esp) /* *rs = (float)f1 */
- jmp .args_saved
-
-.not_float:
- cmpl $68,(%ecx) /* 'D' = double result */
- jne .not_double
- fldl (%esp) /* *rs = (double)f1 */
- jmp .args_saved
-
-.not_double:
- movl %eax,(%esp) /* *rs = eax */
- /* fall through to .args_saved */
-
- /* Marshall results back onto STG stack */
-.args_saved:
- pushl %esp
- movl 4(%ebp), %ecx /* ecx = d; */
- pushl 8(%ecx)
- call marshall
- addl $8,%esp /* marshall(d->result_tys,rs); */
-
-
- movl 4(%ebp), %ecx /* ecx = d; */
- addl 12(%ecx), %esp /* free(rs) */
-
- popl %ecx /* Restore callee-saves register */
- popl %ebp /* restore stack frame pointer */
- ret
-
-#if 0
-/* When we call a Fun, we push the arguments on the stack, push a return
- * address and execute the instruction "call callFun_entry" which brings us
- * here with a return address on top of the stack, a pointer to
- * the FunDescriptor under that and the arguments under that.
- * We swap the top arguments so that when we jmp to callFunDesc, the stack
- * will look as though we executed "callFunDesc(fDescriptor,arg1,arg2,...)"
- */
-
- /* function call/return - standard entry point
- * we'll have one of these for each calling convention
- * all of which jump to callFunDesc when done
- */
- .globl callFun_entry
- .type callFun_entry,@function
-callFun_entry:
- popl %eax /* FunDescriptor */
- popl %edx /* Return address */
- pushl %eax
- pushl %edx
- jmp callFunDesc
-
- /* generic function call/return */
-callFunDesc:
- subl $8,%esp /* int/double res1; */
- pushl %esp /* &res1 */
- leal 20(%esp),%ecx /* &arg1 */
- pushl %ecx
- pushl 20(%esp) /* fun */
- call call_H /* returns result type in %eax */
- addl $20,%esp
-
- testl %eax,%eax /* '\0' = no result */
- jne .L1
- ret
-.L1:
- cmpl $70,%eax /* 'F' = float result */
- jne .L2
- flds -8(%esp)
- ret
-.L2:
- cmpl $68,%eax /* 'D' = double result */
- jne .L3
- fldl -8(%esp)
- ret
-.L3:
- movl -8(%esp),%eax /* return r */
- ret
-
-
-/* Some useful instructions - for later use:
- * fstpl (%ebx) store a double
- * fstps (%ebx) store a float
- *
- * fldl (%esi) load a double (ready for return)
- * flds (%esi) load a float (ready for return)
- */
-#endif /* 0 */
-
-#endif /* i386_TARGET_ARCH */
-
-#endif /* INTERPRETER */
\ No newline at end of file
projects / ghc-hetmet.git / commitdiff