2 /* -----------------------------------------------------------------------------
3 * $Id: ForeignCall.c,v 1.5 1999/10/15 11:03:06 sewardj Exp $
5 * (c) The GHC Team 1994-1999.
7 * Foreign Function calls
9 * ---------------------------------------------------------------------------*/
15 #include "Assembler.h" /* for CFun stuff */
16 #include "Evaluator.h"
17 #include "ForeignCall.h"
19 /* the assymetry here seem to come from the caller-allocates
20 * calling convention. But does the caller really allocate
24 void hcall( HFunDescriptor* d, StablePtr fun, void* as, void* rs)
27 /* out of date - ADR */
28 marshall(d->arg_tys,as);
30 unmarshall(d->result_tys,rs);
37 /* By experiment on an x86 box, we found that gcc's
38 * __builtin_apply(fun,as,size) expects *as to look like this:
39 * as[0] = &first arg = &as[1]
44 * on an x86, it returns a pointer to a struct containing an
45 * int/int64/ptr in its first 4-8 bytes and a float/double in the next
49 * as[0] = &first arg = &as[2]
50 * as[1] = where structures should be returned
55 * This is something of a hack - but seems to be more portable than
56 * hacking it up in assembly language which is how I did it before - ADR
58 void ccall( CFunDescriptor* d, void (*fun)(void) )
61 char* tys = d->arg_tys;
62 /* ToDo: the use of ARG_SIZE is based on the assumption that Hugs
63 * obeys the same alignment restrictions as C.
64 * But this is almost certainly wrong!
65 * We could use gcc's __va_rounded_size macro (see varargs.h) to do a
69 void *as=alloca(4 + d->arg_size);
70 StgWord* args = (StgWord*) as;
71 *(void**)(args++) = 4 + (char*)as; /* incoming args ptr */
73 args += unmarshall(*tys,args);
75 rs = __builtin_apply(fun,as,(char*)args-(char*)as-4);
76 #elif sparc_TARGET_ARCH
77 void *as=alloca(8 + d->arg_size);
78 StgWord* args = (StgWord*) as;
80 *(void**)(args++) = (char*)as; /* incoming args ptr */
81 *(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*/
83 args += unmarshall(*tys,args);
85 argcount = ((void*)args - as);
86 ASSERT(8 + d->arg_size == argcount);
92 rs = __builtin_apply(fun,as,argcount);
94 #error Cant do ccall for this architecture
97 /* ToDo: can't handle multiple return values at the moment
98 * - it's hard enough to get single return values working
100 if (*(d->result_tys)) {
101 char ty = *(d->result_tys);
102 ASSERT(d->result_tys[1] == '\0');
106 /* ToDo: is this right? */
107 marshall(ty,(char*)rs+8);
121 /* HACK alert (red alert) */
122 extern StgInt PopTaggedInt ( void ) ;
123 extern StgDouble PopTaggedDouble ( void ) ;
124 extern StgFloat PopTaggedFloat ( void ) ;
125 extern StgChar PopTaggedChar ( void ) ;
126 extern StgAddr PopTaggedAddr ( void ) ;
128 extern void PushTaggedInt ( StgInt );
129 extern void PushTaggedAddr ( StgAddr );
130 extern void PushPtr ( StgPtr );
131 extern StgPtr PopPtr ( void );
135 #define IF(sss) if (strcmp(sss,cdesc)==0)
136 #define STS PushPtr((StgPtr)(*bco));SaveThreadState()
137 #define LTS LoadThreadState();*bco=(StgBCO*)PopPtr();
138 #define LTS_RET LoadThreadState();*bco=(StgBCO*)PopPtr(); return
140 void ccall( CFunDescriptor* d, void (*fun)(void), StgBCO** bco )
144 strcpy(cdesc, d->result_tys);
146 strcat(cdesc, d->arg_tys);
147 for (i = 0; cdesc[i] != 0; i++) {
149 case 'x': cdesc[i] = 'A'; break;
154 //fprintf(stderr, "ccall: %d cdesc = `%s'\n", seqNr++, cdesc);
156 IF(":") { STS; ((void(*)(void))(fun))(); LTS_RET; };
158 IF(":I") { int a1=PopTaggedInt();
159 STS; ((void(*)(int))(fun))(a1); LTS_RET; };
160 IF(":A") { void* a1=PopTaggedAddr();
161 STS; ((void(*)(void*))(fun))(a1); LTS_RET; };
164 STS; r= ((int(*)(void))(fun))(); LTS;
165 PushTaggedInt(r); RET ;};
167 IF(":II") { int a1=PopTaggedInt(); int a2=PopTaggedInt();
168 STS; ((void(*)(int,int))(fun))(a1,a2); LTS_RET; };
169 IF(":AI") { void* a1=PopTaggedAddr(); int a2=PopTaggedInt();
170 STS; ((void(*)(void*,int))(fun))(a1,a2); LTS_RET; };
172 IF("I:I") { int a1=PopTaggedInt(); int r;
173 STS; r=((int(*)(int))(fun))(a1); LTS;
174 PushTaggedInt(r); RET; };
175 IF("A:I") { int a1=PopTaggedInt(); void* r;
176 STS; r=((void*(*)(int))(fun))(a1); LTS;
177 PushTaggedAddr(r); RET; };
178 IF("A:A") { void* a1=PopTaggedAddr(); void* r;
179 STS; r=((void*(*)(void*))(fun))(a1); LTS;
180 PushTaggedAddr(r); RET; };
182 IF("I:II") { int a1=PopTaggedInt(); int a2=PopTaggedInt(); int r;
183 STS; r=((int(*)(int,int))(fun))(a1,a2); LTS;
184 PushTaggedInt(r); RET; };
185 IF("I:AI") { void* a1=PopTaggedAddr(); int a2=PopTaggedInt(); int r;
186 STS; r=((int(*)(void*,int))(fun))(a1,a2); LTS;
187 PushTaggedInt(r); RET; };
188 IF("A:AI") { void* a1=PopTaggedAddr(); int a2=PopTaggedInt(); void* r;
189 STS; r=((void*(*)(void*,int))(fun))(a1,a2); LTS;
190 PushTaggedAddr(r); RET; };
192 IF("I:III") { int a1=PopTaggedInt(); int a2=PopTaggedInt();
193 int a3=PopTaggedInt(); int r;
194 STS; r=((int(*)(int,int,int))(fun))(a1,a2,a3); LTS;
195 PushTaggedInt(r); RET; };
197 IF(":AIDCF") { void* a1 = PopTaggedAddr();
198 int a2 = PopTaggedInt();
199 double a3 = PopTaggedDouble();
200 char a4 = PopTaggedChar();
201 float a5 = PopTaggedFloat();
203 ((void(*)(void*,int,double,char,float))(fun))(a1,a2,a3,a4,a5);
207 fprintf(stderr,"panic: ccall cdesc `%s' not implemented\n", cdesc );
212 "ccall: arg_tys %s arg_size %d result_tys %s result_size %d\n",
213 d->arg_tys, d->arg_size, d->result_tys, d->result_size );
229 CFunDescriptor* mkDescriptor( char* as, char* rs )
231 /* ToDo: don't use malloc */
232 CFunDescriptor *d = malloc(sizeof(CFunDescriptor));
235 d->arg_size = argSize(as);
237 d->result_size = argSize(rs);
241 #endif /* INTERPRETER */