2 /* -----------------------------------------------------------------------------
3 * $Id: ForeignCall.c,v 1.10 1999/10/26 17:27:30 sewardj Exp $
5 * (c) The GHC Team 1994-1999.
7 * Implementation of foreign import and foreign export.
8 * ---------------------------------------------------------------------------*/
14 #include "RtsUtils.h" /* barf :-) */
15 #include "Assembler.h" /* for CFun stuff */
16 #include "Evaluator.h"
17 #include "ForeignCall.h"
19 /* Exports of this file:
23 Everything else is local, I think.
26 /* ----------------------------------------------------------------------
27 * Some misc-ery to begin with.
28 * --------------------------------------------------------------------*/
30 CFunDescriptor* mkDescriptor( char* as, char* rs )
32 /* ToDo: don't use malloc */
33 CFunDescriptor *d = malloc(sizeof(CFunDescriptor));
34 if (d == NULL) return d;
37 d->num_args = strlen(as);
38 d->num_results = strlen(rs);
43 /* ----------------------------------------------------------------------
44 * Part the first: CALLING OUT -- foreign import
45 * --------------------------------------------------------------------*/
47 /* SOME NOTES ABOUT PARAMETERISATION.
49 These pertain equally to foreign import and foreign export.
51 Implementations for calling in and out are very architecture
52 dependent. After some consideration, it appears that the two
53 important factors are the instruction set, and the calling
54 convention used. Factors like the OS and compiler are not
57 So: routines which are architecture dependent are have
58 _instructionsetname_callingconventionname attached to the
59 the base name. For example, code specific to the ccall
60 convention on x86 would be suffixed _x86_ccall.
62 A third possible dimension of parameterisation relates to the
63 split between callee and caller saves registers. For example,
64 x86_ccall code needs to assume a split, and different splits
65 using ccall on x86 need different code. However, that does not
66 yet seem an issue, so it is ignored here.
70 /* ------------------------------------------------------------------
71 * Calling out to C: a simple, universal calling API
72 * ----------------------------------------------------------------*/
74 /* The universal call-C API supplies a single function:
76 void universal_call_c ( int n_args,
83 args points to the start of a block of memory containing the
84 arguments. This block is an array of 8-byte entities,
85 containing (n_args+1) slots. The zeroth slot is where the
86 return result goes. Slots [1 .. n_args] contain the arguments,
87 presented left-to-right.
89 Arguments are stored in the host's byte ordering inside
90 the slots. Only 4 or 8 byte entities are allowed.
91 4-byte entities are stored in the half-slot with lower
94 For example, a 32-bit value 0xAABBCCDD would be stored, on
99 whereas on a big-endian would expect
103 Clients do not need to fill in the zero bytes; they are there
104 only for illustration.
106 argstr is a simplified argument descriptor string. argstr
107 has one character for each (notional) argument slot of
108 args. That means the first byte of argstr describes the
109 return type. args should be allocated by the caller to hold
110 as many slots as implied by argstr.
112 argstr always specifies a return type. If the function to
113 be called returns no result, you must specify a bogus
114 return type in argstr[0]; a 32-bit int seems like a good bet.
116 Characters in argstr specify the result and argument types:
123 Pointers should travel as integral entities. At the moment
124 there are no descriptors for entities smaller than 32 bits
125 since AFAIK all calling conventions expand smaller entities
126 to 32 bits anyway. Users of this routine need to handle
127 packing/unpacking of 16 and 8 bit quantities themselves.
129 If the preconditions are not met, behaviour of
130 universal_call_c is entirely undefined.
135 The function specified by fun is called with arguments
136 in args as specified by argstr. The result of the call
137 is placed in the first 8 bytes of args, again as specified
138 by the first byte of argstr. Calling and returning is to
139 be done using the correct calling convention for the
142 It's clear that implementations of universal_call_c will
143 have to be handwritten assembly. The above design is intended
144 to make that assembly as simple as possible, at the expense
145 of a small amount of complication for the API's user.
147 These architecture-dependent assembly routines are in
148 rts/universal_call_c.S.
152 /* ----------------------------------------------------------------*
153 * External refs for the assembly routines.
154 * ----------------------------------------------------------------*/
157 extern void universal_call_c_x86_stdcall ( int, void*, char*, void* );
158 extern void universal_call_c_x86_ccall ( int, void*, char*, void* );
160 static void universal_call_c_generic ( int, void*, char*, void* );
163 /* ----------------------------------------------------------------*
164 * This is a generic version of universal call that
165 * only works for specific argument patterns.
167 * It allows ports to work on the Hugs Prelude immediately,
168 * even if universal_call_c_arch_callingconvention is not available.
169 * ----------------------------------------------------------------*/
171 static void universal_call_c_generic
177 unsigned int *p = (unsigned int*) args;
179 #define ARG(n) (p[n*2])
180 #define CMP(str) ((n_args + 1 == strlen(str)) && \
181 (!strncmp(str,argstr,n_args + 1)))
183 #define CALL(retType,callTypes,callVals) \
184 ((retType(*)callTypes)(fun))callVals
187 int res = CALL(int,(void),());
189 } else if (CMP("ii")) {
190 int arg1 = (int) ARG(1);
191 int res = CALL(int,(int),(arg1));
193 } else if (CMP("iii")) {
194 int arg1 = (int) ARG(1);
195 int arg2 = (int) ARG(2);
196 int res = CALL(int,(int,int),(arg1,arg2));
199 /* Do not have the generic call for this argument list. */
201 printf("Can not call external function at address %d\n",(int)fun);
202 printf("Argument string = '");
203 for(i=0;i<n_args;i++) {
204 printf("%c",(char)argstr[i]);
206 printf("' [%d arg(s)]\n",n_args);
215 /* ----------------------------------------------------------------*
216 * Move args/results between STG stack and the above API's arg block
217 * Returns 0 on success
218 * 1 if too many args/results or non-handled type
219 * 2 if config error on this platform
220 * Tries to automatically handle 32-vs-64 bit differences.
221 * Assumes an LP64 programming model for 64 bit:
222 * sizeof(long)==sizeof(void*)==64 on a 64 bit platform
223 * sizeof(int)==32 on a 64 bit platform
224 * This code attempts to be architecture neutral (viz, generic).
225 * ----------------------------------------------------------------*/
227 int ccall ( CFunDescriptor* d,
239 if (sizeof(int) != 4 || sizeof(double) != 8 || sizeof(float) != 4
240 || (sizeof(void*) != 4 && sizeof(void*) != 8)
241 || (sizeof(unsigned long) != sizeof(void*)))
244 if (d->num_args > 30 || d->num_results > 1)
245 return 1; /* unlikely, but ... */
247 p = (unsigned int*) &arg_vec[1];
248 for (i = 0; i < d->num_args; i++) {
249 switch (d->arg_tys[i]) {
252 ul = (unsigned long)PopTaggedInt();
253 goto common_int32_or_64;
255 ul = (unsigned long)PopTaggedWord();
256 goto common_int32_or_64;
258 ul = (unsigned long)(PopTaggedAddr());
259 goto common_int32_or_64;
261 ul = (unsigned long)PopTaggedStablePtr();
263 if (sizeof(void*) == 4) {
264 *(unsigned long *)p = ul; p++; *p++ = 0;
267 *(unsigned long *)p = ul;
274 int j = (int)PopTaggedChar();
280 float f = PopTaggedFloat();
281 *(float*)p = f; p++; *p++ = 0;
286 double d = PopTaggedDouble();
287 *(double*)p = d; p+=2;
296 if (d->num_results == 0) {
299 switch (d->result_tys[0]) {
300 case INT_REP: case WORD_REP: case ADDR_REP: case STABLE_REP:
301 argd_vec[0] = (sizeof(void*)==4) ? 'i' : 'I'; break;
303 argd_vec[0] = 'i'; break;
305 argd_vec[0] = 'f'; break;
307 argd_vec[0] = 'F'; break;
313 PushPtr((StgPtr)(*bco));
318 universal_call_c_x86_ccall (
319 d->num_args, (void*)arg_vec, argd_vec, fun );
321 universal_call_c_x86_stdcall (
322 d->num_args, (void*)arg_vec, argd_vec, fun );
323 else barf ( "ccall(i386): unknown calling convention" );
325 universal_call_c_generic (
326 d->num_args, (void*)arg_vec, argd_vec, fun );
329 *bco=(StgBCO*)PopPtr();
331 /* INT, WORD, ADDR, STABLE don't need to do a word-size check
332 since the result is in the bytes starting at p regardless. */
334 if (d->num_results > 0) {
335 p = (unsigned int*) &arg_vec[0];
336 switch (d->result_tys[0]) {
339 PushTaggedInt ( ((StgInt*)p) [0] );
342 PushTaggedWord ( ((StgWord*)p) [0] );
345 PushTaggedAddr ( ((StgAddr*)p) [0] );
348 PushTaggedStablePtr ( ((StgStablePtr*)p) [0] );
352 PushTaggedChar ( (StgChar) p[0]);
355 PushTaggedFloat ( ((StgFloat*)p) [0] );
358 PushTaggedDouble ( ((StgDouble*)p) [0] );
371 /* ----------------------------------------------------------------------
372 * Part the second: CALLING IN -- foreign export {dynamic}
373 * --------------------------------------------------------------------*/
375 /* Make it possible for the evaluator to get hold of bytecode
376 for a given function by name. Useful but a hack. Sigh.
378 extern void* getHugs_AsmObject_for ( char* s );
381 /* ----------------------------------------------------------------*
382 * The implementation for x86_ccall and x86_stdcall.
383 * ----------------------------------------------------------------*/
387 unpackArgsAndCallHaskell_x86_nocallconv_wrk ( StgStablePtr stableptr,
388 char* tydesc, char* args)
390 /* Copy args out of the C stack frame in an architecture
391 dependent fashion, under the direction of the type description
392 string tydesc. Dereference the stable pointer, giving the
393 Haskell function to call. Build an application of this to
394 the arguments, and finally wrap primRunST round the whole
395 thing, since we know it returns an IO type. Then evaluate
396 the whole, which leaves nodeOut as the evaluated 'a', where
397 the type of the function called is .... -> IO a.
399 We can't immediately unpack the results and return, since
400 int results need to return in a different register (%eax and
401 possibly %edx) from float things (%st(0)). So return nodeOut
402 to the relevant wrapper function, which knows enough about
403 the return type to do the Right Thing.
405 There's no getting round it: this is most heinous hack.
410 SchedulerStatus sstat;
415 node = (HaskellObj)deRefStablePtr(stableptr);
417 if (*argp != ':') argp++;
418 ASSERT( *argp == ':' );
423 node = rts_apply ( node, rts_mkChar ( *(char*)args ) );
427 node = rts_apply ( node, rts_mkInt ( *(int*)args ) );
431 node = rts_apply ( node, rts_mkWord ( *(unsigned int*)args ) );
435 node = rts_apply ( node, rts_mkAddr ( *(void**)args ) );
439 node = rts_apply ( node, rts_mkStablePtr ( *(int*)args ) );
443 node = rts_apply ( node, rts_mkFloat ( *(float*)args ) );
447 node = rts_apply ( node, rts_mkDouble ( *(double*)args ) );
452 "unpackArgsAndCallHaskell_x86_nocallconv: "
453 "unexpected arg type rep");
459 asmClosureOfObject(getHugs_AsmObject_for("primRunST")),
462 sstat = rts_eval ( node, &nodeOut );
463 if (sstat != Success)
464 barf ("unpackArgsAndCallHaskell_x86_nocallconv: eval failed");
472 unpackArgsAndCallHaskell_x86_nocallconv_DOUBLE (
473 StgStablePtr stableptr, char* tydesc, char* args
477 = unpackArgsAndCallHaskell_x86_nocallconv_wrk (
478 stableptr, tydesc, args
480 /* Return a double. This return will go into %st(0), which
481 is unmodified by the adjustor thunk.
483 ASSERT(tydesc[0] == DOUBLE_REP);
484 return rts_getDouble(nodeOut);
490 unpackArgsAndCallHaskell_x86_nocallconv_FLOAT (
491 StgStablePtr stableptr, char* tydesc, char* args
495 = unpackArgsAndCallHaskell_x86_nocallconv_wrk (
496 stableptr, tydesc, args
498 /* Probably could be merged with the double case, since %st(0) is
499 still the return register.
501 ASSERT(tydesc[0] == FLOAT_REP);
502 return rts_getFloat(nodeOut);
508 unpackArgsAndCallHaskell_x86_nocallconv_INTISH (
509 StgStablePtr stableptr, char* tydesc, char* args
513 = unpackArgsAndCallHaskell_x86_nocallconv_wrk (
514 stableptr, tydesc, args
516 /* A complete hack. We know that all these returns will be
517 put into %eax (and %edx, if it is a 64-bit return), and
518 the adjustor thunk will then itself return to the original
519 (C-world) caller without modifying %eax or %edx, so the
520 original caller will be a Happy Bunny.
524 case CHAR_REP: return (unsigned long)rts_getChar(nodeOut);
525 case INT_REP: return (unsigned long)rts_getInt(nodeOut);
526 case WORD_REP: return (unsigned long)rts_getWord(nodeOut);
527 case ADDR_REP: return (unsigned long)rts_getAddr(nodeOut);
528 case STABLE_REP: return (unsigned long)rts_getStablePtr(nodeOut);
531 "unpackArgsAndCallHaskell_x86_nocallconv: "
532 "unexpected res type rep");
537 /* This is a bit subtle, since it can deal with both stdcall
538 and ccall. There are two call transitions to consider:
540 1. The call to "here". If it's a ccall, we can return
541 using 'ret 0' and let the caller remove the args.
542 If stdcall, we have to return with 'ret N', where
543 N is the size of the args passed. N has to be
544 determined by inspecting the type descriptor string
547 2. The call to unpackArgsAndCallHaskell_x86_anycallconv_*.
548 Whether these are done with stdcall or ccall depends on
549 the conventions applied by the compiler that translated
550 those procedures. Fortunately, we can sidestep what it
551 did by saving esp (in ebx), pushing the three args,
552 calling unpack..., and restoring esp from ebx. This
553 trick assumes that ebx is a callee-saves register, so
554 its value will be preserved across the unpack... call.
557 StgAddr createAdjThunk_x86 ( StgStablePtr stableptr,
561 unsigned char* codeblock;
566 unsigned char* argp = (unsigned char*)typestr;
567 unsigned int ts = (unsigned int)typestr;
568 unsigned int sp = (unsigned int)stableptr;
570 if (((char*)typestr)[0] == DOUBLE_REP)
572 &unpackArgsAndCallHaskell_x86_nocallconv_DOUBLE;
573 else if (((char*)typestr)[0] == FLOAT_REP)
575 &unpackArgsAndCallHaskell_x86_nocallconv_FLOAT;
578 &unpackArgsAndCallHaskell_x86_nocallconv_INTISH;
580 codeblock = malloc ( 0x26 );
582 barf ( "createAdjThunk_x86: can't malloc memory\n");
584 if (callconv == 's') {
586 if (*argp != ':') argp++;
587 ASSERT( *argp == ':' );
591 case CHAR_REP: case INT_REP: case WORD_REP:
592 case ADDR_REP: case STABLE_REP: case FLOAT_REP:
597 barf("createAdjThunk_x86: unexpected type descriptor");
602 if (callconv == 'c') {
605 barf ( "createAdjThunk_x86: unknown calling convention\n");
610 0000 53 pushl %ebx # save caller's registers
615 0005 89E0 movl %esp,%eax # sp -> eax
616 0007 83C018 addl $24,%eax # move eax back over 5 saved regs + retaddr
617 000a 89E3 movl %esp,%ebx # remember sp before pushing args
618 000c 50 pushl %eax # push arg-block addr
619 000d 6844332211 pushl $0x11223344 # push addr of type descr string
620 0012 6877665544 pushl $0x44556677 # push stableptr to closure
621 0017 E8BBAA9988 call 0x8899aabb # SEE COMMENT BELOW
622 # return value is in %eax, or %eax:%edx,
623 # or %st(0), so don't trash these regs
624 # between here and 'ret'
625 001c 89DC movl %ebx,%esp # restore sp from remembered value
626 001e 5D popl %ebp # restore caller's registers
631 0023 C27766 ret $0x6677 # return, clearing args if stdcall
638 *cp++ = 0x89; *cp++ = 0xE0;
639 *cp++ = 0x83; *cp++ = 0xC0; *cp++ = 0x18;
640 *cp++ = 0x89; *cp++ = 0xE3;
642 *cp++ = 0x68; *cp++=ts;ts>>=8; *cp++=ts;ts>>=8; *cp++=ts;ts>>=8; *cp++=ts;
643 *cp++ = 0x68; *cp++=sp;sp>>=8; *cp++=sp;sp>>=8; *cp++=sp;sp>>=8; *cp++=sp;
645 /* call address needs to be: displacement relative to next insn */
646 ch = ch - ( ((unsigned int)cp) + 5);
647 *cp++ = 0xE8; *cp++=ch;ch>>=8; *cp++=ch;ch>>=8; *cp++=ch;ch>>=8; *cp++=ch;
649 *cp++ = 0x89; *cp++ = 0xDC;
655 *cp++ = 0xC2; *cp++=nwords;nwords>>=8; *cp++=nwords;
661 /* ----------------------------------------------------------------*
662 * The only function involved in foreign-export that needs to be
663 * visible outside this file.
664 * ----------------------------------------------------------------*/
666 StgAddr createAdjThunk ( StgStablePtr stableptr,
672 createAdjThunk_x86 ( stableptr, typestr, callconv );
675 #warn foreign export not implemented on this architecture
680 #endif /* INTERPRETER */