2 /* -----------------------------------------------------------------------------
3 * $Id: ForeignCall.c,v 1.18 2000/08/07 23:37:23 qrczak 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 == (int)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);
217 /* ----------------------------------------------------------------*
218 * Move args/results between STG stack and the above API's arg block
219 * Returns 0 on success
220 * 1 if too many args/results or non-handled type
221 * 2 if config error on this platform
222 * Tries to automatically handle 32-vs-64 bit differences.
223 * Assumes an LP64 programming model for 64 bit:
224 * sizeof(long)==sizeof(void*)==64 on a 64 bit platform
225 * sizeof(int)==32 on a 64 bit platform
226 * This code attempts to be architecture neutral (viz, generic).
227 * ----------------------------------------------------------------*/
229 int ccall ( CFunDescriptor* d,
243 if (sizeof(int) != 4 || sizeof(double) != 8 || sizeof(float) != 4
244 || (sizeof(void*) != 4 && sizeof(void*) != 8)
245 || (sizeof(unsigned long) != sizeof(void*)))
248 if (d->num_args > 30 || d->num_results > 1)
249 return 1; /* unlikely, but ... */
251 p = (unsigned int*) &arg_vec[1];
252 for (i = 0; i < (int)(d->num_args); i++) {
253 switch (d->arg_tys[i]) {
256 ul = (unsigned long)PopTaggedInt();
257 goto common_int32_or_64;
259 ul = (unsigned long)PopTaggedWord();
260 goto common_int32_or_64;
262 ul = (unsigned long)(PopTaggedAddr());
263 goto common_int32_or_64;
265 ul = (unsigned long)PopTaggedStablePtr();
267 if (sizeof(void*) == 4) {
268 *(unsigned long *)p = ul; p++; *p++ = 0;
271 *(unsigned long *)p = ul;
278 int j = (int)PopTaggedChar();
284 float f = PopTaggedFloat();
285 *(float*)p = f; p++; *p++ = 0;
290 double d = PopTaggedDouble();
291 *(double*)p = d; p+=2;
300 if (d->num_results == 0) {
303 switch (d->result_tys[0]) {
304 case INT_REP: case WORD_REP: case ADDR_REP: case STABLE_REP:
305 argd_vec[0] = (sizeof(void*)==4) ? 'i' : 'I'; break;
307 argd_vec[0] = 'i'; break;
309 argd_vec[0] = 'f'; break;
311 argd_vec[0] = 'F'; break;
317 PushPtr((StgPtr)(*bco));
318 cap->rCurrentTSO->sp = MainRegTable.rSp;
319 cap->rCurrentTSO->su = MainRegTable.rSu;
320 cap->rCurrentTSO->splim = MainRegTable.rSpLim;
321 token = suspendThread(cap);
325 universal_call_c_x86_ccall (
326 d->num_args, (void*)arg_vec, argd_vec, fun );
328 universal_call_c_x86_stdcall (
329 d->num_args, (void*)arg_vec, argd_vec, fun );
330 else barf ( "ccall(i386): unknown calling convention" );
332 universal_call_c_generic (
333 d->num_args, (void*)arg_vec, argd_vec, fun );
336 cap = resumeThread(token);
337 MainRegTable.rSp = cap->rCurrentTSO->sp;
338 MainRegTable.rSu = cap->rCurrentTSO->su;
339 MainRegTable.rSpLim = cap->rCurrentTSO->splim;
340 *bco=(StgBCO*)PopPtr();
342 /* INT, WORD, ADDR, STABLE don't need to do a word-size check
343 since the result is in the bytes starting at p regardless. */
345 if (d->num_results > 0) {
346 p = (unsigned int*) &arg_vec[0];
347 switch (d->result_tys[0]) {
350 PushTaggedInt ( ((StgInt*)p) [0] );
353 PushTaggedWord ( ((StgWord*)p) [0] );
356 PushTaggedAddr ( ((StgAddr*)p) [0] );
359 PushTaggedStablePtr ( ((StgStablePtr*)p) [0] );
363 PushTaggedChar ( (StgChar) p[0]);
366 PushTaggedFloat ( ((StgFloat*)p) [0] );
369 PushTaggedDouble ( ((StgDouble*)p) [0] );
382 /* ----------------------------------------------------------------------
383 * Part the second: CALLING IN -- foreign export {dynamic}
384 * --------------------------------------------------------------------*/
386 /* Make it possible for the evaluator to get hold of bytecode
387 for a given function by name. Useful but a hack. Sigh.
389 extern void* /* StgClosure* */ getHugs_BCO_cptr_for ( char* s );
390 extern int /*Bool*/ combined;
392 /* ----------------------------------------------------------------*
393 * The implementation for x86_ccall and x86_stdcall.
394 * ----------------------------------------------------------------*/
398 unpackArgsAndCallHaskell_x86_nocallconv_wrk ( StgStablePtr stableptr,
399 char* tydesc, char* args)
401 /* Copy args out of the C stack frame in an architecture
402 dependent fashion, under the direction of the type description
403 string tydesc. Dereference the stable pointer, giving the
404 Haskell function to call. Build an application of this to
405 the arguments, and finally wrap primRunST round the whole
406 thing, since we know it returns an IO type. Then evaluate
407 the whole, which leaves nodeOut as the evaluated 'a', where
408 the type of the function called is .... -> IO a.
410 We can't immediately unpack the results and return, since
411 int results need to return in a different register (%eax and
412 possibly %edx) from float things (%st(0)). So return nodeOut
413 to the relevant wrapper function, which knows enough about
414 the return type to do the Right Thing.
416 There's no getting round it: this is most heinous hack.
421 SchedulerStatus sstat;
426 node = (HaskellObj)deRefStablePtr(stableptr);
428 if (*argp != ':') argp++;
429 ASSERT( *argp == ':' );
434 node = rts_apply ( node, rts_mkChar ( *(unsigned int*)args ) );
438 node = rts_apply ( node, rts_mkInt ( *(int*)args ) );
442 node = rts_apply ( node, rts_mkWord ( *(unsigned int*)args ) );
446 node = rts_apply ( node, rts_mkAddr ( *(void**)args ) );
450 node = rts_apply ( node, rts_mkStablePtr ( *(int*)args ) );
454 node = rts_apply ( node, rts_mkFloat ( *(float*)args ) );
458 node = rts_apply ( node, rts_mkDouble ( *(double*)args ) );
463 "unpackArgsAndCallHaskell_x86_nocallconv: "
464 "unexpected arg type rep");
470 sstat = rts_evalIO ( node, &nodeOut );
473 getHugs_BCO_cptr_for("runST"),
475 sstat = rts_eval ( node, &nodeOut );
478 if (sstat != Success)
479 barf ("unpackArgsAndCallHaskell_x86_nocallconv: eval failed");
487 unpackArgsAndCallHaskell_x86_nocallconv_DOUBLE (
488 StgStablePtr stableptr, char* tydesc, char* args
492 = unpackArgsAndCallHaskell_x86_nocallconv_wrk (
493 stableptr, tydesc, args
495 /* Return a double. This return will go into %st(0), which
496 is unmodified by the adjustor thunk.
498 ASSERT(tydesc[0] == DOUBLE_REP);
499 return rts_getDouble(nodeOut);
505 unpackArgsAndCallHaskell_x86_nocallconv_FLOAT (
506 StgStablePtr stableptr, char* tydesc, char* args
510 = unpackArgsAndCallHaskell_x86_nocallconv_wrk (
511 stableptr, tydesc, args
513 /* Probably could be merged with the double case, since %st(0) is
514 still the return register.
516 ASSERT(tydesc[0] == FLOAT_REP);
517 return rts_getFloat(nodeOut);
523 unpackArgsAndCallHaskell_x86_nocallconv_INTISH (
524 StgStablePtr stableptr, char* tydesc, char* args
528 nodeOut = unpackArgsAndCallHaskell_x86_nocallconv_wrk (
529 stableptr, tydesc, args
531 /* A complete hack. We know that all these returns will be
532 put into %eax (and %edx, if it is a 64-bit return), and
533 the adjustor thunk will then itself return to the original
534 (C-world) caller without modifying %eax or %edx, so the
535 original caller will be a Happy Bunny.
539 case CHAR_REP: return (unsigned long)rts_getChar(nodeOut);
540 case INT_REP: return (unsigned long)rts_getInt(nodeOut);
541 case WORD_REP: return (unsigned long)rts_getWord(nodeOut);
542 case ADDR_REP: return (unsigned long)rts_getAddr(nodeOut);
543 case STABLE_REP: return (unsigned long)rts_getStablePtr(nodeOut);
546 "unpackArgsAndCallHaskell_x86_nocallconv: "
547 "unexpected res type rep");
552 /* This is a bit subtle, since it can deal with both stdcall
553 and ccall. There are two call transitions to consider:
555 1. The call to "here". If it's a ccall, we can return
556 using 'ret 0' and let the caller remove the args.
557 If stdcall, we have to return with 'ret N', where
558 N is the size of the args passed. N has to be
559 determined by inspecting the type descriptor string
562 2. The call to unpackArgsAndCallHaskell_x86_anycallconv_*.
563 Whether these are done with stdcall or ccall depends on
564 the conventions applied by the compiler that translated
565 those procedures. Fortunately, we can sidestep what it
566 did by saving esp (in ebx), pushing the three args,
567 calling unpack..., and restoring esp from ebx. This
568 trick assumes that ebx is a callee-saves register, so
569 its value will be preserved across the unpack... call.
572 StgAddr createAdjThunk_x86 ( StgStablePtr stableptr,
576 unsigned char* codeblock;
581 unsigned char* argp = (unsigned char*)typestr;
582 unsigned int ts = (unsigned int)typestr;
583 unsigned int sp = (unsigned int)stableptr;
585 if (((char*)typestr)[0] == DOUBLE_REP)
587 &unpackArgsAndCallHaskell_x86_nocallconv_DOUBLE;
588 else if (((char*)typestr)[0] == FLOAT_REP)
590 &unpackArgsAndCallHaskell_x86_nocallconv_FLOAT;
593 &unpackArgsAndCallHaskell_x86_nocallconv_INTISH;
595 codeblock = malloc ( 0x26 );
597 barf ( "createAdjThunk_x86: can't malloc memory\n");
599 if (callconv == 's') {
601 if (*argp != ':') argp++;
602 ASSERT( *argp == ':' );
606 case CHAR_REP: case INT_REP: case WORD_REP:
607 case ADDR_REP: case STABLE_REP: case FLOAT_REP:
612 barf("createAdjThunk_x86: unexpected type descriptor");
617 if (callconv == 'c') {
620 barf ( "createAdjThunk_x86: unknown calling convention\n");
625 0000 53 pushl %ebx # save caller's registers
630 0005 89E0 movl %esp,%eax # sp -> eax
631 0007 83C018 addl $24,%eax # move eax back over 5 saved regs + retaddr
632 000a 89E3 movl %esp,%ebx # remember sp before pushing args
633 000c 50 pushl %eax # push arg-block addr
634 000d 6844332211 pushl $0x11223344 # push addr of type descr string
635 0012 6877665544 pushl $0x44556677 # push stableptr to closure
636 0017 E8BBAA9988 call 0x8899aabb # SEE COMMENT BELOW
637 # return value is in %eax, or %eax:%edx,
638 # or %st(0), so don't trash these regs
639 # between here and 'ret'
640 001c 89DC movl %ebx,%esp # restore sp from remembered value
641 001e 5D popl %ebp # restore caller's registers
646 0023 C27766 ret $0x6677 # return, clearing args if stdcall
653 *cp++ = 0x89; *cp++ = 0xE0;
654 *cp++ = 0x83; *cp++ = 0xC0; *cp++ = 0x18;
655 *cp++ = 0x89; *cp++ = 0xE3;
657 *cp++ = 0x68; *cp++=ts;ts>>=8; *cp++=ts;ts>>=8; *cp++=ts;ts>>=8; *cp++=ts;
658 *cp++ = 0x68; *cp++=sp;sp>>=8; *cp++=sp;sp>>=8; *cp++=sp;sp>>=8; *cp++=sp;
660 /* call address needs to be: displacement relative to next insn */
661 ch = ch - ( ((unsigned int)cp) + 5);
662 *cp++ = 0xE8; *cp++=ch;ch>>=8; *cp++=ch;ch>>=8; *cp++=ch;ch>>=8; *cp++=ch;
664 *cp++ = 0x89; *cp++ = 0xDC;
670 *cp++ = 0xC2; *cp++=nwords;nwords>>=8; *cp++=nwords;
676 /* ----------------------------------------------------------------*
677 * The only function involved in foreign-export that needs to be
678 * visible outside this file.
679 * ----------------------------------------------------------------*/
681 StgAddr createAdjThunk ( StgStablePtr stableptr,
687 createAdjThunk_x86 ( stableptr, typestr, callconv );
690 #warning foreign export not implemented on this architecture
695 #endif /* INTERPRETER */