2 /* -----------------------------------------------------------------------------
3 * $Id: ForeignCall.c,v 1.13 2000/03/02 10:32:17 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 */
17 #include "Evaluator.h"
18 #include "ForeignCall.h"
20 /* Exports of this file:
24 Everything else is local, I think.
27 /* ----------------------------------------------------------------------
28 * Some misc-ery to begin with.
29 * --------------------------------------------------------------------*/
31 CFunDescriptor* mkDescriptor( char* as, char* rs )
33 /* ToDo: don't use malloc */
34 CFunDescriptor *d = malloc(sizeof(CFunDescriptor));
35 if (d == NULL) return d;
38 d->num_args = strlen(as);
39 d->num_results = strlen(rs);
44 /* ----------------------------------------------------------------------
45 * Part the first: CALLING OUT -- foreign import
46 * --------------------------------------------------------------------*/
48 /* SOME NOTES ABOUT PARAMETERISATION.
50 These pertain equally to foreign import and foreign export.
52 Implementations for calling in and out are very architecture
53 dependent. After some consideration, it appears that the two
54 important factors are the instruction set, and the calling
55 convention used. Factors like the OS and compiler are not
58 So: routines which are architecture dependent are have
59 _instructionsetname_callingconventionname attached to the
60 the base name. For example, code specific to the ccall
61 convention on x86 would be suffixed _x86_ccall.
63 A third possible dimension of parameterisation relates to the
64 split between callee and caller saves registers. For example,
65 x86_ccall code needs to assume a split, and different splits
66 using ccall on x86 need different code. However, that does not
67 yet seem an issue, so it is ignored here.
71 /* ------------------------------------------------------------------
72 * Calling out to C: a simple, universal calling API
73 * ----------------------------------------------------------------*/
75 /* The universal call-C API supplies a single function:
77 void universal_call_c ( int n_args,
84 args points to the start of a block of memory containing the
85 arguments. This block is an array of 8-byte entities,
86 containing (n_args+1) slots. The zeroth slot is where the
87 return result goes. Slots [1 .. n_args] contain the arguments,
88 presented left-to-right.
90 Arguments are stored in the host's byte ordering inside
91 the slots. Only 4 or 8 byte entities are allowed.
92 4-byte entities are stored in the half-slot with lower
95 For example, a 32-bit value 0xAABBCCDD would be stored, on
100 whereas on a big-endian would expect
104 Clients do not need to fill in the zero bytes; they are there
105 only for illustration.
107 argstr is a simplified argument descriptor string. argstr
108 has one character for each (notional) argument slot of
109 args. That means the first byte of argstr describes the
110 return type. args should be allocated by the caller to hold
111 as many slots as implied by argstr.
113 argstr always specifies a return type. If the function to
114 be called returns no result, you must specify a bogus
115 return type in argstr[0]; a 32-bit int seems like a good bet.
117 Characters in argstr specify the result and argument types:
124 Pointers should travel as integral entities. At the moment
125 there are no descriptors for entities smaller than 32 bits
126 since AFAIK all calling conventions expand smaller entities
127 to 32 bits anyway. Users of this routine need to handle
128 packing/unpacking of 16 and 8 bit quantities themselves.
130 If the preconditions are not met, behaviour of
131 universal_call_c is entirely undefined.
136 The function specified by fun is called with arguments
137 in args as specified by argstr. The result of the call
138 is placed in the first 8 bytes of args, again as specified
139 by the first byte of argstr. Calling and returning is to
140 be done using the correct calling convention for the
143 It's clear that implementations of universal_call_c will
144 have to be handwritten assembly. The above design is intended
145 to make that assembly as simple as possible, at the expense
146 of a small amount of complication for the API's user.
148 These architecture-dependent assembly routines are in
149 rts/universal_call_c.S.
153 /* ----------------------------------------------------------------*
154 * External refs for the assembly routines.
155 * ----------------------------------------------------------------*/
158 extern void universal_call_c_x86_stdcall ( int, void*, char*, void* );
159 extern void universal_call_c_x86_ccall ( int, void*, char*, void* );
161 static void universal_call_c_generic ( int, void*, char*, void* );
164 /* ----------------------------------------------------------------*
165 * This is a generic version of universal call that
166 * only works for specific argument patterns.
168 * It allows ports to work on the Hugs Prelude immediately,
169 * even if universal_call_c_arch_callingconvention is not available.
170 * ----------------------------------------------------------------*/
172 static void universal_call_c_generic
178 unsigned int *p = (unsigned int*) args;
180 #define ARG(n) (p[n*2])
181 #define CMP(str) ((n_args + 1 == strlen(str)) && \
182 (!strncmp(str,argstr,n_args + 1)))
184 #define CALL(retType,callTypes,callVals) \
185 ((retType(*)callTypes)(fun))callVals
188 int res = CALL(int,(void),());
190 } else if (CMP("ii")) {
191 int arg1 = (int) ARG(1);
192 int res = CALL(int,(int),(arg1));
194 } else if (CMP("iii")) {
195 int arg1 = (int) ARG(1);
196 int arg2 = (int) ARG(2);
197 int res = CALL(int,(int,int),(arg1,arg2));
200 /* Do not have the generic call for this argument list. */
202 printf("Can not call external function at address %d\n",(int)fun);
203 printf("Argument string = '");
204 for(i=0;i<n_args;i++) {
205 printf("%c",(char)argstr[i]);
207 printf("' [%d arg(s)]\n",n_args);
216 /* ----------------------------------------------------------------*
217 * Move args/results between STG stack and the above API's arg block
218 * Returns 0 on success
219 * 1 if too many args/results or non-handled type
220 * 2 if config error on this platform
221 * Tries to automatically handle 32-vs-64 bit differences.
222 * Assumes an LP64 programming model for 64 bit:
223 * sizeof(long)==sizeof(void*)==64 on a 64 bit platform
224 * sizeof(int)==32 on a 64 bit platform
225 * This code attempts to be architecture neutral (viz, generic).
226 * ----------------------------------------------------------------*/
228 int ccall ( CFunDescriptor* d,
242 if (sizeof(int) != 4 || sizeof(double) != 8 || sizeof(float) != 4
243 || (sizeof(void*) != 4 && sizeof(void*) != 8)
244 || (sizeof(unsigned long) != sizeof(void*)))
247 if (d->num_args > 30 || d->num_results > 1)
248 return 1; /* unlikely, but ... */
250 p = (unsigned int*) &arg_vec[1];
251 for (i = 0; i < d->num_args; i++) {
252 switch (d->arg_tys[i]) {
255 ul = (unsigned long)PopTaggedInt();
256 goto common_int32_or_64;
258 ul = (unsigned long)PopTaggedWord();
259 goto common_int32_or_64;
261 ul = (unsigned long)(PopTaggedAddr());
262 goto common_int32_or_64;
264 ul = (unsigned long)PopTaggedStablePtr();
266 if (sizeof(void*) == 4) {
267 *(unsigned long *)p = ul; p++; *p++ = 0;
270 *(unsigned long *)p = ul;
277 int j = (int)PopTaggedChar();
283 float f = PopTaggedFloat();
284 *(float*)p = f; p++; *p++ = 0;
289 double d = PopTaggedDouble();
290 *(double*)p = d; p+=2;
299 if (d->num_results == 0) {
302 switch (d->result_tys[0]) {
303 case INT_REP: case WORD_REP: case ADDR_REP: case STABLE_REP:
304 argd_vec[0] = (sizeof(void*)==4) ? 'i' : 'I'; break;
306 argd_vec[0] = 'i'; break;
308 argd_vec[0] = 'f'; break;
310 argd_vec[0] = 'F'; break;
316 PushPtr((StgPtr)(*bco));
317 cap->rCurrentTSO->sp = MainRegTable.rSp;
318 cap->rCurrentTSO->su = MainRegTable.rSu;
319 cap->rCurrentTSO->splim = MainRegTable.rSpLim;
320 token = suspendThread(cap);
324 universal_call_c_x86_ccall (
325 d->num_args, (void*)arg_vec, argd_vec, fun );
327 universal_call_c_x86_stdcall (
328 d->num_args, (void*)arg_vec, argd_vec, fun );
329 else barf ( "ccall(i386): unknown calling convention" );
331 universal_call_c_generic (
332 d->num_args, (void*)arg_vec, argd_vec, fun );
335 cap = resumeThread(token);
336 MainRegTable.rSp = cap->rCurrentTSO->sp;
337 MainRegTable.rSu = cap->rCurrentTSO->su;
338 MainRegTable.rSpLim = cap->rCurrentTSO->splim;
339 *bco=(StgBCO*)PopPtr();
341 /* INT, WORD, ADDR, STABLE don't need to do a word-size check
342 since the result is in the bytes starting at p regardless. */
344 if (d->num_results > 0) {
345 p = (unsigned int*) &arg_vec[0];
346 switch (d->result_tys[0]) {
349 PushTaggedInt ( ((StgInt*)p) [0] );
352 PushTaggedWord ( ((StgWord*)p) [0] );
355 PushTaggedAddr ( ((StgAddr*)p) [0] );
358 PushTaggedStablePtr ( ((StgStablePtr*)p) [0] );
362 PushTaggedChar ( (StgChar) p[0]);
365 PushTaggedFloat ( ((StgFloat*)p) [0] );
368 PushTaggedDouble ( ((StgDouble*)p) [0] );
381 /* ----------------------------------------------------------------------
382 * Part the second: CALLING IN -- foreign export {dynamic}
383 * --------------------------------------------------------------------*/
385 /* Make it possible for the evaluator to get hold of bytecode
386 for a given function by name. Useful but a hack. Sigh.
388 extern void* getHugs_AsmObject_for ( char* s );
389 extern int /*Bool*/ combined;
391 /* ----------------------------------------------------------------*
392 * The implementation for x86_ccall and x86_stdcall.
393 * ----------------------------------------------------------------*/
397 unpackArgsAndCallHaskell_x86_nocallconv_wrk ( StgStablePtr stableptr,
398 char* tydesc, char* args)
400 /* Copy args out of the C stack frame in an architecture
401 dependent fashion, under the direction of the type description
402 string tydesc. Dereference the stable pointer, giving the
403 Haskell function to call. Build an application of this to
404 the arguments, and finally wrap primRunST round the whole
405 thing, since we know it returns an IO type. Then evaluate
406 the whole, which leaves nodeOut as the evaluated 'a', where
407 the type of the function called is .... -> IO a.
409 We can't immediately unpack the results and return, since
410 int results need to return in a different register (%eax and
411 possibly %edx) from float things (%st(0)). So return nodeOut
412 to the relevant wrapper function, which knows enough about
413 the return type to do the Right Thing.
415 There's no getting round it: this is most heinous hack.
420 SchedulerStatus sstat;
425 node = (HaskellObj)deRefStablePtr(stableptr);
427 if (*argp != ':') argp++;
428 ASSERT( *argp == ':' );
433 node = rts_apply ( node, rts_mkChar ( *(char*)args ) );
437 node = rts_apply ( node, rts_mkInt ( *(int*)args ) );
441 node = rts_apply ( node, rts_mkWord ( *(unsigned int*)args ) );
445 node = rts_apply ( node, rts_mkAddr ( *(void**)args ) );
449 node = rts_apply ( node, rts_mkStablePtr ( *(int*)args ) );
453 node = rts_apply ( node, rts_mkFloat ( *(float*)args ) );
457 node = rts_apply ( node, rts_mkDouble ( *(double*)args ) );
462 "unpackArgsAndCallHaskell_x86_nocallconv: "
463 "unexpected arg type rep");
469 sstat = rts_evalIO ( node, &nodeOut );
472 asmClosureOfObject(getHugs_AsmObject_for("primRunST")),
474 sstat = rts_eval ( node, &nodeOut );
477 if (sstat != Success)
478 barf ("unpackArgsAndCallHaskell_x86_nocallconv: eval failed");
486 unpackArgsAndCallHaskell_x86_nocallconv_DOUBLE (
487 StgStablePtr stableptr, char* tydesc, char* args
491 = unpackArgsAndCallHaskell_x86_nocallconv_wrk (
492 stableptr, tydesc, args
494 /* Return a double. This return will go into %st(0), which
495 is unmodified by the adjustor thunk.
497 ASSERT(tydesc[0] == DOUBLE_REP);
498 return rts_getDouble(nodeOut);
504 unpackArgsAndCallHaskell_x86_nocallconv_FLOAT (
505 StgStablePtr stableptr, char* tydesc, char* args
509 = unpackArgsAndCallHaskell_x86_nocallconv_wrk (
510 stableptr, tydesc, args
512 /* Probably could be merged with the double case, since %st(0) is
513 still the return register.
515 ASSERT(tydesc[0] == FLOAT_REP);
516 return rts_getFloat(nodeOut);
522 unpackArgsAndCallHaskell_x86_nocallconv_INTISH (
523 StgStablePtr stableptr, char* tydesc, char* args
527 nodeOut = unpackArgsAndCallHaskell_x86_nocallconv_wrk (
528 stableptr, tydesc, args
530 /* A complete hack. We know that all these returns will be
531 put into %eax (and %edx, if it is a 64-bit return), and
532 the adjustor thunk will then itself return to the original
533 (C-world) caller without modifying %eax or %edx, so the
534 original caller will be a Happy Bunny.
538 case CHAR_REP: return (unsigned long)rts_getChar(nodeOut);
539 case INT_REP: return (unsigned long)rts_getInt(nodeOut);
540 case WORD_REP: return (unsigned long)rts_getWord(nodeOut);
541 case ADDR_REP: return (unsigned long)rts_getAddr(nodeOut);
542 case STABLE_REP: return (unsigned long)rts_getStablePtr(nodeOut);
545 "unpackArgsAndCallHaskell_x86_nocallconv: "
546 "unexpected res type rep");
551 /* This is a bit subtle, since it can deal with both stdcall
552 and ccall. There are two call transitions to consider:
554 1. The call to "here". If it's a ccall, we can return
555 using 'ret 0' and let the caller remove the args.
556 If stdcall, we have to return with 'ret N', where
557 N is the size of the args passed. N has to be
558 determined by inspecting the type descriptor string
561 2. The call to unpackArgsAndCallHaskell_x86_anycallconv_*.
562 Whether these are done with stdcall or ccall depends on
563 the conventions applied by the compiler that translated
564 those procedures. Fortunately, we can sidestep what it
565 did by saving esp (in ebx), pushing the three args,
566 calling unpack..., and restoring esp from ebx. This
567 trick assumes that ebx is a callee-saves register, so
568 its value will be preserved across the unpack... call.
571 StgAddr createAdjThunk_x86 ( StgStablePtr stableptr,
575 unsigned char* codeblock;
580 unsigned char* argp = (unsigned char*)typestr;
581 unsigned int ts = (unsigned int)typestr;
582 unsigned int sp = (unsigned int)stableptr;
584 if (((char*)typestr)[0] == DOUBLE_REP)
586 &unpackArgsAndCallHaskell_x86_nocallconv_DOUBLE;
587 else if (((char*)typestr)[0] == FLOAT_REP)
589 &unpackArgsAndCallHaskell_x86_nocallconv_FLOAT;
592 &unpackArgsAndCallHaskell_x86_nocallconv_INTISH;
594 codeblock = malloc ( 0x26 );
596 barf ( "createAdjThunk_x86: can't malloc memory\n");
598 if (callconv == 's') {
600 if (*argp != ':') argp++;
601 ASSERT( *argp == ':' );
605 case CHAR_REP: case INT_REP: case WORD_REP:
606 case ADDR_REP: case STABLE_REP: case FLOAT_REP:
611 barf("createAdjThunk_x86: unexpected type descriptor");
616 if (callconv == 'c') {
619 barf ( "createAdjThunk_x86: unknown calling convention\n");
624 0000 53 pushl %ebx # save caller's registers
629 0005 89E0 movl %esp,%eax # sp -> eax
630 0007 83C018 addl $24,%eax # move eax back over 5 saved regs + retaddr
631 000a 89E3 movl %esp,%ebx # remember sp before pushing args
632 000c 50 pushl %eax # push arg-block addr
633 000d 6844332211 pushl $0x11223344 # push addr of type descr string
634 0012 6877665544 pushl $0x44556677 # push stableptr to closure
635 0017 E8BBAA9988 call 0x8899aabb # SEE COMMENT BELOW
636 # return value is in %eax, or %eax:%edx,
637 # or %st(0), so don't trash these regs
638 # between here and 'ret'
639 001c 89DC movl %ebx,%esp # restore sp from remembered value
640 001e 5D popl %ebp # restore caller's registers
645 0023 C27766 ret $0x6677 # return, clearing args if stdcall
652 *cp++ = 0x89; *cp++ = 0xE0;
653 *cp++ = 0x83; *cp++ = 0xC0; *cp++ = 0x18;
654 *cp++ = 0x89; *cp++ = 0xE3;
656 *cp++ = 0x68; *cp++=ts;ts>>=8; *cp++=ts;ts>>=8; *cp++=ts;ts>>=8; *cp++=ts;
657 *cp++ = 0x68; *cp++=sp;sp>>=8; *cp++=sp;sp>>=8; *cp++=sp;sp>>=8; *cp++=sp;
659 /* call address needs to be: displacement relative to next insn */
660 ch = ch - ( ((unsigned int)cp) + 5);
661 *cp++ = 0xE8; *cp++=ch;ch>>=8; *cp++=ch;ch>>=8; *cp++=ch;ch>>=8; *cp++=ch;
663 *cp++ = 0x89; *cp++ = 0xDC;
669 *cp++ = 0xC2; *cp++=nwords;nwords>>=8; *cp++=nwords;
675 /* ----------------------------------------------------------------*
676 * The only function involved in foreign-export that needs to be
677 * visible outside this file.
678 * ----------------------------------------------------------------*/
680 StgAddr createAdjThunk ( StgStablePtr stableptr,
686 createAdjThunk_x86 ( stableptr, typestr, callconv );
689 #warn foreign export not implemented on this architecture
694 #endif /* INTERPRETER */