Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/runtime/c-libs/smlnj-ccalls/c-calls.c
ViewVC logotype

Annotation of /sml/trunk/src/runtime/c-libs/smlnj-ccalls/c-calls.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2 - (view) (download) (as text)

1 : monnier 2 /* c-calls.c
2 :     *
3 :     * COPYRIGHT (c) 1995 by AT&T Bell Laboratories.
4 :     *
5 :     * C-side support for calling user C functions from SML/NJ.
6 :     *
7 :     */
8 :    
9 :     #include <string.h>
10 :     #include "ml-base.h"
11 :     #include "ml-values.h"
12 :     #include "ml-objects.h"
13 :     #if defined(INDIRECT_CFUNC)
14 :     # include "c-library.h"
15 :     #endif
16 :     #include "ml-c.h"
17 :     #include "c-calls.h"
18 :    
19 :    
20 :     /* assumptions:
21 :     *
22 :     * Word_t fits in a machine word
23 :     *
24 :     * restrictions:
25 :     * C function args must fit in Word_t
26 :     * C's double is the largest return value from a function
27 :     */
28 :    
29 :     ml_val_t dummyRoot = ML_unit; /* empty root for GC */
30 :    
31 :     /* visible_msp used to expose msp to C code */
32 :     ml_state_t *visible_msp = NULL;
33 :    
34 :     #define CONS_SZB (3*WORD_SZB) /* desc + car + cdr */
35 :     #define CADDR_SZB (2*WORD_SZB) /* string desc + ptr */
36 :    
37 :     #define MK_SOME(msp,v) recAlloc1(msp,v)
38 :    
39 :     #define NULLARY_DATACON INT_CtoML(0)
40 :    
41 :     /* this map must correspond to the layout of the type cdata and ctype
42 :     datatypes defined in ML_FILES
43 :     */
44 :    
45 :     #define MLADDR_CODE '@'
46 :     #define MLARRAY_CODE 'A'
47 :     #define MLCHAR_CODE 'C'
48 :     #define MLDOUBLE_CODE 'D'
49 :     #define MLFLOAT_CODE 'R'
50 :     #define MLFUNCTION_CODE 'F'
51 :     #define MLINT_CODE 'I'
52 :     #define MLLONG_CODE 'L'
53 :     #define MLPTR_CODE 'P'
54 :     #define MLSHORT_CODE 'i'
55 :     #define MLSTRING_CODE 'S'
56 :     #define MLOPENSTRUCT_CODE '('
57 :     #define MLCLOSESTRUCT_CODE ')'
58 :     #define MLOPENUNION_CODE '<'
59 :     #define MLCLOSEUNION_CODE '>'
60 :     #define MLVECTOR_CODE 'B'
61 :     #define MLVOID_CODE 'V'
62 :     #define MLPAD_CODE '#'
63 :    
64 :     #define MLSTRUCT_CODE MLOPENSTRUCT_CODE
65 :     #define MLUNION_CODE MLOPENUNION_CODE
66 :    
67 :    
68 :     /* this enumeration must match the sml/nj tags on the cdata datatype */
69 :     /* see c-calls.sml */
70 :    
71 :     #define MLADDR_TAG 0
72 :     #define MLARRAY_TAG 1
73 :     #define MLCHAR_TAG 2
74 :     #define MLDOUBLE_TAG 3
75 :     #define MLFLOAT_TAG 4
76 :     #define MLFUNCTION_TAG 5
77 :     #define MLINT_TAG 6
78 :     #define MLLONG_TAG 7
79 :     #define MLPTR_TAG 8
80 :     #define MLSHORT_TAG 9
81 :     #define MLSTRING_TAG 10
82 :     #define MLSTRUCT_TAG 11
83 :     #define MLUNION_TAG 12
84 :     #define MLVECTOR_TAG 13
85 :     /* #define MLVOID_TAG not used */
86 :    
87 :     /* map from datatype tags to single char descriptor (aka code) */
88 :     char typeMap[] = {MLADDR_CODE,
89 :     MLARRAY_CODE,
90 :     MLCHAR_CODE,
91 :     MLDOUBLE_CODE,
92 :     MLFLOAT_CODE,
93 :     MLFUNCTION_CODE,
94 :     MLINT_CODE,
95 :     MLLONG_CODE,
96 :     MLPTR_CODE,
97 :     MLSHORT_CODE,
98 :     MLSTRING_CODE,
99 :     MLSTRUCT_CODE,
100 :     MLUNION_CODE,
101 :     MLVECTOR_CODE,
102 :     MLVOID_CODE};
103 :    
104 :     /* utility functions */
105 :    
106 :     #define CHAR_RANGE 255 /* must agree with CharRange in c-calls.sml */
107 :    
108 :     PVT int extractUnsigned(unsigned char **s,int bytes)
109 :     {
110 :     int r = 0;
111 :    
112 :     while (bytes--)
113 :     r = r * CHAR_RANGE + (int) *((*s)++) - 1;
114 :     return r;
115 :     }
116 :    
117 :    
118 :    
119 :     /* could (should) use stdlib's strdup instead of this */
120 :     PVT char *mk_strcpy(char *s)
121 :     {
122 :     char *p;
123 :    
124 :     if ((p = (char *) malloc(strlen(s)+1)) == NULL)
125 :     Die("couldn't make string copy during C call\n");
126 :     return strcpy(p,s);
127 :     }
128 :    
129 :     Word_t *checked_memalign(int n,int align)
130 :     {
131 :     Word_t *p;
132 :    
133 :     if (align < sizeof(Word_t))
134 :     align = sizeof(Word_t);
135 :     if ((p = (Word_t *)malloc(n)) == NULL)
136 :     Die("couldn't alloc memory for C call\n");
137 :    
138 :     ASSERT(((Word_t)p & (Word_t)(align-1)) != 0);
139 :    
140 :     return p;
141 :     }
142 :    
143 :     PVT ml_val_t recAlloc1(ml_state_t *msp,ml_val_t v)
144 :     {
145 :     ml_val_t ret;
146 :    
147 :     REC_ALLOC1(msp,ret,v);
148 :     return ret;
149 :     }
150 :    
151 :     PVT ml_val_t mkWord32(ml_state_t *msp, Word_t p)
152 :     {
153 :     ML_AllocWrite(msp, 0, MAKE_DESC(sizeof(Word_t), DTAG_string));
154 :     ML_AllocWrite(msp, 1, (ml_val_t)p);
155 :     return ML_Alloc(msp, sizeof(Word_t));
156 :     }
157 :    
158 :     PVT Word_t getWord32(ml_val_t v)
159 :     {
160 :     return (Word_t) REC_SEL(v,0);
161 :     }
162 :    
163 :     #define MK_CADDR(msp,p) mkWord32(msp,(Word_t) (p))
164 :     #define GET_CADDR(v) (Word_t *)getWord32(v)
165 :    
166 :     PVT ml_val_t double_CtoML(ml_state_t *msp,double g)
167 :     {
168 :     ml_val_t res;
169 :    
170 :     #ifdef DEBUG_C_CALLS
171 :     SayDebug("double_CtoML: building an ML double %l.15f\n", g);
172 :     #endif
173 :     /* Force REALD_SZB alignment */
174 :     msp->ml_allocPtr = (ml_val_t *)((Addr_t)(msp->ml_allocPtr) | WORD_SZB);
175 :     ML_AllocWrite(msp,0,DESC_reald);
176 :     res = ML_Alloc(msp,(sizeof(double)>>2));
177 :     memcpy (res, &g, sizeof(double));
178 :     return res;
179 :     }
180 :    
181 :     /* ptrs to storage alloc'd by the interface. */
182 :     typedef struct ptr_desc {
183 :     Word_t *ptr;
184 :     struct ptr_desc *next;
185 :     } ptrlist_t;
186 :    
187 :     PVT ptrlist_t *ptrlist = NULL;
188 :    
189 :     #ifdef DEBUG_C_CALLS
190 :     PVT int ptrlist_len()
191 :     {
192 :     int i = 0;
193 :     ptrlist_t *p = ptrlist;
194 :    
195 :     while (p != NULL) {
196 :     i++;
197 :     p = p->next;
198 :     }
199 :     return i;
200 :     }
201 :     #endif
202 :    
203 :    
204 :     PVT void keep_ptr(Word_t *p)
205 :     {
206 :     ptrlist_t *q = (ptrlist_t *) checked_alloc(sizeof(ptrlist_t));
207 :    
208 :     #ifdef DEBUG_C_CALLS
209 :     SayDebug("keeping ptr %x, |ptrlist|=%d\n", p, ptrlist_len());
210 :     #endif
211 :    
212 :     q->ptr = p;
213 :     q->next = ptrlist;
214 :     ptrlist = q;
215 :     }
216 :    
217 :     PVT void free_ptrlist()
218 :     {
219 :     ptrlist_t *p;
220 :    
221 :     #ifdef DEBUG_C_CALLS
222 :     SayDebug("freeing ptr list, |ptrlist|=%d\n",ptrlist_len());
223 :     #endif
224 :     p = ptrlist;
225 :     while (p != NULL) {
226 :     ptrlist = ptrlist->next;
227 :     free(p->ptr); /* the block */
228 :     free(p); /* the block's descriptor */
229 :     p = ptrlist;
230 :     }
231 :     }
232 :    
233 :     PVT ml_val_t ptrlist_to_MLlist(ml_state_t *msp)
234 :     {
235 :     ml_val_t lp = LIST_nil;
236 :     ml_val_t v;
237 :     ptrlist_t *p;
238 :    
239 :     #ifdef DEBUG_C_CALLS
240 :     int i = 0;
241 :     SayDebug("converting ptrlist (|ptrlist|=%d) to ML list ",ptrlist_len());
242 :     #endif
243 :     p = ptrlist;
244 :     while (p != NULL) {
245 :     #ifdef DEBUG_C_CALLS
246 :     i++;
247 :     #endif
248 :     ptrlist = p->next;
249 :     v = MK_CADDR(msp,p->ptr);
250 :     LIST_cons(msp, lp, v, lp);
251 :     free(p);
252 :     p = ptrlist;
253 :     }
254 :     #ifdef DEBUG_C_CALLS
255 :     SayDebug("of length %d\n", i);
256 :     #endif
257 :     return lp;
258 :     }
259 :    
260 :     /* return the number of bytes the ptrlist will occupy in the ML heap */
261 :     PVT int ptrlist_space()
262 :     {
263 :     int n = 0;
264 :     ptrlist_t *p;
265 :    
266 :     p = ptrlist;
267 :     while (p != NULL) {
268 :     p = p->next;
269 :     n += CONS_SZB + CADDR_SZB;
270 :     }
271 :     #ifdef DEBUG_C_CALLS
272 :     SayDebug("space for ptrlist is %d, |ptrlist|=%d\n",n,ptrlist_len());
273 :     #endif
274 :     return n;
275 :     }
276 :    
277 :     PVT void save_ptrlist(ptrlist_t **save)
278 :     {
279 :     #ifdef DEBUG_C_CALLS
280 :     SayDebug("saving ptrlist, |ptrlist|=%d\n", ptrlist_len());
281 :     #endif
282 :     *save = ptrlist;
283 :     ptrlist = NULL;
284 :     }
285 :    
286 :     PVT void restore_ptrlist(ptrlist_t *save)
287 :     {
288 :     ptrlist = save;
289 :     #ifdef DEBUG_C_CALLS
290 :     SayDebug("restoring ptrlist, |ptrlist|=%d\n", ptrlist_len());
291 :     #endif
292 :     }
293 :    
294 :     ml_val_t revMLList(ml_val_t l,ml_val_t r)
295 :     {
296 :     if (l == LIST_nil)
297 :     return r;
298 :     else {
299 :     ml_val_t tmp = LIST_tl(l);
300 :    
301 :     LIST_tl(l) = r;
302 :     return revMLList(tmp,l);
303 :     }
304 :     }
305 :    
306 :    
307 :     #define SMALL_SPACE 0 /* size to 'NeedGC' for a small obj, say <10 words */
308 :    
309 :     PVT void spaceCheck(ml_state_t *msp, int bytes, ml_val_t *one_root)
310 :     {
311 :     /* assume the ONE_K buffer will absorb descriptors, '\0' terminators */
312 :     if (NeedGC(msp,bytes + ONE_K)) {
313 :     #ifdef DEBUG_C_CALLS
314 :     SayDebug("spaceCheck: invoking GC\n");
315 :     #endif
316 :     InvokeGCWithRoots(msp,0,one_root,NIL(ml_val_t *));
317 :     if (NeedGC(msp,bytes + ONE_K))
318 :     Error("spaceCheck: cannot alloc ML space for ML-C conversion\n");
319 :     }
320 :     }
321 :    
322 :    
323 :     /* interface functions */
324 :    
325 :     PVT char *too_many_args = "c-calls with more than 15 args not supported\n";
326 :    
327 :     /* call_word_fn
328 :     * used when the return type fits into a machine word (Word_t)
329 :     */
330 :     PVT Word_t call_word_fn(Word_t (*f)(),int n,Word_t *args)
331 :     {
332 :     Word_t ret = 0;
333 :    
334 :     switch(n) {
335 :     case 0:
336 :     ret = (*f)();
337 :     break;
338 :     case 1:
339 :     ret = (*f)(args[0]);
340 :     break;
341 :     case 2:
342 :     ret = (*f)(args[0],args[1]);
343 :     break;
344 :     case 3:
345 :     ret = (*f)(args[0],args[1],args[2]);
346 :     break;
347 :     case 4:
348 :     ret = (*f)(args[0],args[1],args[2],args[3]);
349 :     break;
350 :     case 5:
351 :     ret = (*f)(args[0],args[1],args[2],args[3],args[4]);
352 :     break;
353 :     case 6:
354 :     ret = (*f)(args[0],args[1],args[2],args[3],args[4],
355 :     args[5]);
356 :     break;
357 :     case 7:
358 :     ret = (*f)(args[0],args[1],args[2],args[3],args[4],
359 :     args[5],args[6]);
360 :     break;
361 :     case 8:
362 :     ret = (*f)(args[0],args[1],args[2],args[3],args[4],
363 :     args[5],args[6],args[7]);
364 :     break;
365 :     case 9:
366 :     ret = (*f)(args[0],args[1],args[2],args[3],args[4],
367 :     args[5],args[6],args[7],args[8]);
368 :     break;
369 :     case 10:
370 :     ret = (*f)(args[0],args[1],args[2],args[3],args[4],
371 :     args[5],args[6],args[7],args[8],args[9]);
372 :     break;
373 :     case 11:
374 :     ret = (*f)(args[0],args[1],args[2],args[3],args[4],
375 :     args[5],args[6],args[7],args[8],args[9],
376 :     args[10]);
377 :     break;
378 :     case 12:
379 :     ret = (*f)(args[0],args[1],args[2],args[3],args[4],
380 :     args[5],args[6],args[7],args[8],args[9],
381 :     args[10],args[11]);
382 :     break;
383 :     case 13:
384 :     ret = (*f)(args[0],args[1],args[2],args[3],args[4],
385 :     args[5],args[6],args[7],args[8],args[9],
386 :     args[10],args[11],args[12]);
387 :     break;
388 :     case 14:
389 :     ret = (*f)(args[0],args[1],args[2],args[3],args[4],
390 :     args[5],args[6],args[7],args[8],args[9],
391 :     args[10],args[11],args[12],args[13]);
392 :     break;
393 :     case 15:
394 :     ret = (*f)(args[0],args[1],args[2],args[3],args[4],
395 :     args[5],args[6],args[7],args[8],args[9],
396 :     args[10],args[11],args[12],args[13],args[14]);
397 :     break;
398 :     default:
399 :     /* shouldn't happen; ML side assures this */
400 :     Error(too_many_args);
401 :     }
402 :    
403 :     #ifdef DEBUG_C_CALLS
404 :     SayDebug("call_word_fn: return=0x%x\n",ret);
405 :     #endif
406 :     return ret;
407 :     }
408 :    
409 :     /* call_double_fn
410 :     */
411 :     PVT double call_double_fn(double (*f)(),int n,Word_t *args)
412 :     {
413 :     double ret;
414 :    
415 :     switch(n) {
416 :     case 0:
417 :     ret = (*f)();
418 :     break;
419 :     case 1:
420 :     ret = (*f)(args[0]);
421 :     break;
422 :     case 2:
423 :     ret = (*f)(args[0],args[1]);
424 :     break;
425 :     case 3:
426 :     ret = (*f)(args[0],args[1],args[2]);
427 :     break;
428 :     case 4:
429 :     ret = (*f)(args[0],args[1],args[2],args[3]);
430 :     break;
431 :     case 5:
432 :     ret = (*f)(args[0],args[1],args[2],args[3],args[4]);
433 :     break;
434 :     case 6:
435 :     ret = (*f)(args[0],args[1],args[2],args[3],args[4],
436 :     args[5]);
437 :     break;
438 :     case 7:
439 :     ret = (*f)(args[0],args[1],args[2],args[3],args[4],
440 :     args[5],args[6]);
441 :     break;
442 :     case 8:
443 :     ret = (*f)(args[0],args[1],args[2],args[3],args[4],
444 :     args[5],args[6],args[7]);
445 :     break;
446 :     case 9:
447 :     ret = (*f)(args[0],args[1],args[2],args[3],args[4],
448 :     args[5],args[6],args[7],args[8]);
449 :     break;
450 :     case 10:
451 :     ret = (*f)(args[0],args[1],args[2],args[3],args[4],
452 :     args[5],args[6],args[7],args[8],args[9]);
453 :     break;
454 :     default:
455 :     /* shouldn't happen; ML side assures this */
456 :     Error(too_many_args);
457 :     }
458 :     return ret;
459 :     }
460 :    
461 :     /* call_float_fn
462 :     */
463 :     PVT float call_float_fn(float (*f)(),int n,Word_t *args)
464 :     {
465 :     float ret;
466 :    
467 :     switch(n) {
468 :     case 0:
469 :     ret = (*f)();
470 :     break;
471 :     case 1:
472 :     ret = (*f)(args[0]);
473 :     break;
474 :     case 2:
475 :     ret = (*f)(args[0],args[1]);
476 :     break;
477 :     case 3:
478 :     ret = (*f)(args[0],args[1],args[2]);
479 :     break;
480 :     case 4:
481 :     ret = (*f)(args[0],args[1],args[2],args[3]);
482 :     break;
483 :     case 5:
484 :     ret = (*f)(args[0],args[1],args[2],args[3],args[4]);
485 :     break;
486 :     case 6:
487 :     ret = (*f)(args[0],args[1],args[2],args[3],args[4],
488 :     args[5]);
489 :     break;
490 :     case 7:
491 :     ret = (*f)(args[0],args[1],args[2],args[3],args[4],
492 :     args[5],args[6]);
493 :     break;
494 :     case 8:
495 :     ret = (*f)(args[0],args[1],args[2],args[3],args[4],
496 :     args[5],args[6],args[7]);
497 :     break;
498 :     case 9:
499 :     ret = (*f)(args[0],args[1],args[2],args[3],args[4],
500 :     args[5],args[6],args[7],args[8]);
501 :     break;
502 :     case 10:
503 :     ret = (*f)(args[0],args[1],args[2],args[3],args[4],
504 :     args[5],args[6],args[7],args[8],args[9]);
505 :     break;
506 :     default:
507 :     /* shouldn't happen; ML side assures this */
508 :     Error(too_many_args);
509 :     }
510 :     return ret;
511 :     }
512 :    
513 :     /* error handling */
514 :    
515 :     #define NO_ERR 0
516 :     #define ERR_TYPEMISMATCH 1
517 :     #define ERR_EMPTY_AGGREGATE 2
518 :     #define ERR_SZ_MISMATCH 3
519 :     #define ERR_WRONG_ARG_COUNT 4
520 :     #define ERR_TOO_MANY_ARGS 5
521 :    
522 :     PVT char *errtbl[] = {
523 :     "no error",
524 :     "type mismatch",
525 :     "empty aggregate",
526 :     "array/vector size does not match registered size",
527 :     "wrong number of args in C call",
528 :     "current max of 10 args to C fn",
529 :     };
530 :    
531 :     PVT char errbuf[100];
532 :    
533 :     PVT ml_val_t RaiseError(ml_state_t *msp,int err)
534 :     {
535 :     sprintf(errbuf,"SML/NJ-C-Interface: %s",errtbl[err]);
536 :     return RaiseSysError(msp,errbuf);
537 :     }
538 :    
539 :    
540 :     /* char *nextdatum(char *t)
541 :     *
542 :     * must match typeToCtl in c-calls.sml
543 :     */
544 :     PVT char *nextdatum(char *t)
545 :     {
546 :     int level = 0;
547 :    
548 :     do {
549 :     switch(*t) {
550 :     case MLFUNCTION_CODE: {
551 :     int nargs, i;
552 :    
553 :     t++; /* skip code */
554 :     nargs = extractUnsigned((unsigned char **)&t,1);
555 :     /* skip arg types AND return type */
556 :     for (i = 0; i < nargs+1; i++) {
557 :     t = nextdatum(t);
558 :     }
559 :     }
560 :     break;
561 :     case MLPTR_CODE:
562 :     /* can fall through as long as Cptr has 4 bytes of sz info */
563 :     case MLARRAY_CODE:
564 :     case MLVECTOR_CODE:
565 :     t = nextdatum(t+5); /* skip 4 bytes of sz info & code */
566 :     break;
567 :     case MLOPENUNION_CODE:
568 :     t++; /* skip 1 byte of sz info ; fall through */
569 :     case MLOPENSTRUCT_CODE:
570 :     t++; /* skip code */
571 :     level++;
572 :     break;
573 :     case MLCLOSEUNION_CODE:
574 :     case MLCLOSESTRUCT_CODE:
575 :     t++; /* skip code */
576 :     level--;
577 :     break;
578 :     case MLINT_CODE:
579 :     case MLSHORT_CODE:
580 :     case MLLONG_CODE:
581 :     /* skip 1 byte of size; fall through */
582 :     t++;
583 :     default:
584 :     t++; /* skip simple type */
585 :     break;
586 :     }
587 :     } while (level);
588 :     return t;
589 :     }
590 :    
591 :     PVT void mkCint(Word_t src,Word_t **dst,int bytes)
592 :     {
593 :     #ifdef DEBUG_C_CALLS
594 :     SayDebug("mkCint: placing integer into %d bytes at %x\n", bytes, *dst);
595 :     #endif
596 :    
597 :     src <<= (sizeof(Word_t) - bytes)*8;
598 :     memcpy (*dst, &src, bytes);
599 :     (*(Byte_t **)dst) += bytes;
600 :     }
601 :    
602 :     PVT void mkMLint(Word_t **src,Word_t *dst,int bytes)
603 :     {
604 :     #ifdef DEBUG_C_CALLS
605 :     SayDebug("mkMLint: reading integer from %x into %d bytes\n", *src, bytes);
606 :     #endif
607 :    
608 :     memcpy (dst, *src, bytes);
609 :     *dst >>= (sizeof(Word_t) - bytes)*8;
610 :     *(Byte_t **)src += bytes;
611 :     }
612 :    
613 :    
614 :     #define DO_PAD(p,t) (*(Byte_t **)(p) += extractUnsigned((unsigned char **)(t),1))
615 :     #define IF_PAD_DO_PAD(p,t) {if (**t == MLPAD_CODE) {++(*t); DO_PAD(p,t);}}
616 :    
617 :     int datumMLtoC(ml_state_t *msp,char **t,Word_t **p,ml_val_t datum)
618 :     {
619 :     int tag = REC_SELINT(datum,0);
620 :     ml_val_t val = REC_SEL(datum,1);
621 :     int err = NO_ERR;
622 :     int sz = 0;
623 :    
624 :     while (**t == MLPAD_CODE) {
625 :     ++(*t); /* advance past code */
626 :     #ifdef DEBUG_C_CALLS
627 :     SayDebug("datumMLtoC: adding pad from %x ", *p);
628 :     #endif
629 :     DO_PAD(p,t);
630 :     #ifdef DEBUG_C_CALLS
631 :     SayDebug(" to %x\n", *p);
632 :     #endif
633 :     }
634 :     if (typeMap[tag] != **t) {
635 :     #ifdef DEBUG_C_CALLS
636 :     SayDebug("datumMLtoC: type mismatch %c != %d\n",**t,tag);
637 :     #endif
638 :     return ERR_TYPEMISMATCH;
639 :     }
640 :     switch(*(*t)++) {
641 :     case MLFUNCTION_CODE: {
642 :     char *argtypes[N_ARGS], *rettype;
643 :     char *this_arg, *next_arg;
644 :     int nargs, len, i;
645 :    
646 :     nargs = extractUnsigned((unsigned char **)t,1);
647 :     #ifdef DEBUG_C_CALLS
648 :     SayDebug("datumMLtoC: function with %d args\n", nargs);
649 :     #endif
650 :     this_arg = *t;
651 :     for (i = 0; i < nargs; i++) {
652 :     next_arg = nextdatum(this_arg);
653 :     len = next_arg - this_arg;
654 :     argtypes[i] = (char *)checked_alloc(len+1); /* len plus null */
655 :     strncpy(argtypes[i],this_arg,len);
656 :     argtypes[i][len] = '\0';
657 :     this_arg = next_arg;
658 :     #ifdef DEBUG_C_CALLS
659 :     SayDebug("datumMLtoC: function arg[%d] is \"%s\"\n",
660 :     i,argtypes[i]);
661 :     #endif
662 :     }
663 :     /* get the return type */
664 :     next_arg = nextdatum(this_arg);
665 :     len = next_arg - this_arg;
666 :     rettype = (char *)checked_alloc(len+1); /* len plus null */
667 :     strncpy(rettype,this_arg,len);
668 :     rettype[len] = '\0';
669 :     #ifdef DEBUG_C_CALLS
670 :     SayDebug("datumMLtoC: function returns \"%s\"\n",
671 :     rettype);
672 :     #endif
673 :     *t = next_arg;
674 :     *(*p)++ = mk_C_function(msp,val,nargs,argtypes,rettype);
675 :     #ifdef DEBUG_C_CALLS
676 :     SayDebug("datumMLtoC: made C function\n");
677 :     #endif
678 :     }
679 :     break;
680 :     case MLPTR_CODE: {
681 :     int szb, align;
682 :     Word_t *q;
683 :    
684 :     szb = extractUnsigned((unsigned char **)t,4);
685 :     align = extractUnsigned((unsigned char **)t,1);
686 :     #ifdef DEBUG_C_CALLS
687 :     SayDebug("datumMLtoC: ptr szb=%d, align=%d\n", szb, align);
688 :     #endif
689 :     q = checked_memalign(szb,align);
690 :     keep_ptr(q);
691 :     *(*p)++ = (Word_t) q;
692 :     #ifdef DEBUG_C_CALLS
693 :     SayDebug("datumMLtoC: ptr substructure at %x\n", q);
694 :     #endif
695 :     if (err = datumMLtoC(msp,t,&q,val))
696 :     return err;
697 :     }
698 :     break;
699 :     case MLCHAR_CODE:
700 :     *(*(Byte_t **)p)++ = (Byte_t) INT_MLtoC(val);
701 :     break;
702 :     case MLFLOAT_CODE:
703 :     sz = sizeof(float);
704 :     /* fall through */
705 :     case MLDOUBLE_CODE: {
706 :     double g;
707 :    
708 :     if (!sz) {
709 :     /* came in through MLDOUBLE_CODE */
710 :     sz = sizeof(double);
711 :     }
712 :     memcpy (&g, (Word_t *)val, sizeof(double));
713 :     #ifdef DEBUG_C_CALLS
714 :     SayDebug("datumMLtoC: ML real %l.15f:%l.15f %.15f\n", *(double *)val, g, (float) g);
715 :     #endif
716 :     if (sz == sizeof(float))
717 :     *(*(float **)p)++ = (float) g;
718 :     else
719 :     *(*(double **)p)++ = g;
720 :     }
721 :     break;
722 :     case MLINT_CODE:
723 :     case MLSHORT_CODE:
724 :     case MLLONG_CODE:
725 :     #ifdef DEBUG_C_CALLS
726 :     SayDebug("datumMLtoC: integer %d\n", getWord32(val));
727 :     #endif
728 :     mkCint(getWord32(val),p,extractUnsigned((unsigned char **)t,1));
729 :     break;
730 :     case MLADDR_CODE:
731 :     #ifdef DEBUG_C_CALLS
732 :     SayDebug("datumMLtoC: addr %x\n", GET_CADDR(val));
733 :     #endif
734 :     *(*p)++ = (Word_t) GET_CADDR(val);
735 :     break;
736 :     case MLSTRING_CODE: {
737 :     char *r, *s;
738 :    
739 :     s = PTR_MLtoC(char,val);
740 :     #ifdef DEBUG_C_CALLS
741 :     SayDebug("datumMLtoC: string \"%s\"\n",s);
742 :     #endif
743 :     r = (char *) checked_alloc(strlen(s)+1);
744 :     strcpy(r,s);
745 :     keep_ptr((Word_t *) r);
746 :     *(*p)++ = (Word_t) r;
747 :     #ifdef DEBUG_C_CALLS
748 :     SayDebug("datumMLtoC: copied string \"%s\"=%x\n",r,r);
749 :     #endif
750 :     }
751 :     break;
752 :     case MLOPENSTRUCT_CODE: {
753 :     ml_val_t lp = val;
754 :     ml_val_t hd;
755 :    
756 :     #ifdef DEBUG_C_CALLS
757 :     SayDebug("datumMLtoC: struct\n");
758 :     #endif
759 :     while (**t != MLCLOSESTRUCT_CODE) {
760 :     hd = LIST_hd(lp);
761 :     if (err = datumMLtoC(msp,t,p,hd))
762 :     return err;
763 :     lp = LIST_tl(lp);
764 :     IF_PAD_DO_PAD(p,t);
765 :     }
766 :     (*t)++; /* advance past MLCLOSESTRUCT_CODE */
767 :     }
768 :     break;
769 :     case MLOPENUNION_CODE: {
770 :     Byte_t *init_p = (Byte_t *) *p;
771 :     char *next_try;
772 :    
773 :     sz = extractUnsigned((unsigned char **)t,1);
774 :     #ifdef DEBUG_C_CALLS
775 :     SayDebug("datumMLtoC: union of size %d\n", sz);
776 :     #endif
777 :     if ((**t) == MLCLOSEUNION_CODE)
778 :     return ERR_EMPTY_AGGREGATE;
779 :     next_try = nextdatum(*t);
780 :     /* try union types until one matches or all fail */
781 :     while ((err = datumMLtoC(msp,t,p,val)) == ERR_TYPEMISMATCH) {
782 :     *t = next_try;
783 :     if ((**t) == MLCLOSEUNION_CODE) {
784 :     err = ERR_TYPEMISMATCH;
785 :     break;
786 :     }
787 :     next_try = nextdatum(*t);
788 :     *p = (Word_t *) init_p;
789 :     }
790 :     if (err)
791 :     return err;
792 :     while (**t != MLCLOSEUNION_CODE)
793 :     *t = nextdatum(*t);
794 :     (*t)++; /* advance past MLCLOSEUNION_CODE */
795 :     *p = (Word_t *) (init_p + sz);
796 :     }
797 :     break;
798 :     case MLARRAY_CODE:
799 :     case MLVECTOR_CODE: {
800 :     int nelems,elem_sz, i;
801 :     char *saved_t;
802 :    
803 :     nelems = extractUnsigned((unsigned char **)t,2);
804 :     elem_sz = extractUnsigned((unsigned char **)t,2);
805 :     #ifdef DEBUG_C_CALLS
806 :     SayDebug("datumMLtoC: array/vector of %d elems of size %d\n",
807 :     nelems, elem_sz);
808 :     #endif
809 :     i = sz = OBJ_LEN(val);
810 :     #ifdef DEBUG_C_CALLS
811 :     SayDebug("datumMLtoC: array/vector size is %d\n", sz);
812 :     #endif
813 :    
814 :     if (sz != nelems)
815 :     return ERR_SZ_MISMATCH;
816 :     saved_t = *t;
817 :     while (!err && i--) {
818 :     *t = saved_t;
819 :     err = datumMLtoC(msp,t,p,*(ml_val_t *)val++);
820 :     }
821 :     if (err)
822 :     return err;
823 :     }
824 :     break;
825 :     case MLCLOSESTRUCT_CODE:
826 :     case MLCLOSEUNION_CODE:
827 :     return ERR_EMPTY_AGGREGATE;
828 :     break;
829 :     default:
830 :     Die("datumMLtoC: cannot yet handle type\n");
831 :     }
832 :     return err;
833 :     }
834 :    
835 :     /* ML entry point for 'datumMLtoC' */
836 :     ml_val_t ml_datumMLtoC(ml_state_t *msp, ml_val_t arg)
837 :     {
838 :     /* no GCs can occur since no allocation on ML heap */
839 :     /* guaranteed that datum is a pointer (Cptr or Cstring) */
840 :     char *type = REC_SELPTR(char,arg,0);
841 :     ml_val_t datum = REC_SEL(arg,1);
842 :     int err = 0;
843 :     Word_t p, *q = &p;
844 :     ml_val_t lp, ret;
845 :     ptrlist_t *saved_pl;
846 :    
847 :     save_ptrlist(&saved_pl);
848 :     err = datumMLtoC(msp,&type,&q,datum);
849 :     if (err) {
850 :     free_ptrlist();
851 :     restore_ptrlist(saved_pl);
852 :     return RaiseError(msp,err);
853 :     }
854 :     /* return (result,list of pointers to alloc'd C objects) */
855 :     spaceCheck(msp,ptrlist_space(),&dummyRoot);
856 :     lp = ptrlist_to_MLlist(msp); /* this frees the ptr descriptors */
857 :     restore_ptrlist(saved_pl);
858 :     ret = MK_CADDR(msp,(Word_t *)p);
859 :     REC_ALLOC2(msp, ret, ret, lp);
860 :     return ret;
861 :     }
862 :    
863 :     PVT ml_val_t word_CtoML(ml_state_t *msp,char **t,Word_t **p, ml_val_t *root)
864 :     {
865 :     ml_val_t ret = ML_unit;
866 :     ml_val_t mlval = ML_unit;
867 :     int tag;
868 :     char code;
869 :    
870 :     switch(code = *(*t)++) {
871 :     case MLPAD_CODE:
872 :     #ifdef DEBUG_C_CALLS
873 :     SayDebug("word_CtoML: skipping pad %x ", *p);
874 :     #endif
875 :     DO_PAD(p,t);
876 :     #ifdef DEBUG_C_CALLS
877 :     SayDebug(" to %x\n", *p);
878 :     #endif
879 :     return word_CtoML(msp,t,p,root);
880 :     case MLVOID_CODE:
881 :     return NULLARY_DATACON;
882 :     case MLCHAR_CODE:
883 :     tag = MLCHAR_TAG;
884 :     mlval = INT_CtoML(**(Byte_t **)p);
885 :     (*(Byte_t **)p)++;
886 :     break;
887 :     case MLPTR_CODE: {
888 :     Word_t q;
889 :     #ifdef DEBUG_C_CALLS
890 :     SayDebug("word_CtoML: ptr %x\n", **(Word_t ****)p);
891 :     #endif
892 :     tag = MLPTR_TAG;
893 :     #ifdef DEBUG_C_CALLS
894 :     SayDebug("word_CtoML: size is %d\n",
895 :     extractUnsigned((unsigned char **)t,4));
896 :     SayDebug("word_CtoML: align is %d\n",
897 :     extractUnsigned((unsigned char **)t,1));
898 :     #else
899 :     *t += 5; /* 5 bytes of size */
900 :     #endif
901 :     q = **p;
902 :     mlval = word_CtoML(msp,t,(Word_t **) &q,root);
903 :     (*p)++;
904 :     }
905 :     break;
906 :     case MLINT_CODE:
907 :     tag = MLINT_TAG;
908 :     goto handle_int;
909 :     case MLSHORT_CODE:
910 :     tag = MLSHORT_TAG;
911 :     goto handle_int;
912 :     case MLLONG_CODE:
913 :     tag = MLLONG_TAG;
914 :     handle_int:
915 :     {
916 :     Word_t w;
917 :    
918 :     mkMLint(p,&w,extractUnsigned((unsigned char **)t,1));
919 :     mlval = mkWord32(msp,w);
920 :     }
921 :     break;
922 :     case MLADDR_CODE: {
923 :     Word_t *cp = ** (Word_t ***) p;
924 :    
925 :     #ifdef DEBUG_C_CALLS
926 :     SayDebug("word_CtoML: C addr %x\n", cp);
927 :     #endif
928 :     tag = MLADDR_TAG;
929 :     mlval = MK_CADDR(msp,cp);
930 :     (*p)++;
931 :     }
932 :     break;
933 :     case MLFLOAT_CODE: {
934 :     /* C floats become ML reals, which are doubles... */
935 :     tag = MLFLOAT_TAG;
936 :     mlval = double_CtoML(msp,(double) *(*(float **)p)++);
937 :     #ifdef DEBUG_C_CALLS
938 :     SayDebug("word_CtoML: made float %l.15f\n", *(double*)mlval);
939 :     #endif
940 :     }
941 :     break;
942 :     case MLDOUBLE_CODE: {
943 :     tag = MLDOUBLE_TAG;
944 :     mlval = double_CtoML(msp,*(*(double **)p)++);
945 :     #ifdef DEBUG_C_CALLS
946 :     SayDebug("word_CtoML: made double %l.15f\n", *(double*)mlval);
947 :     #endif
948 :     }
949 :     break;
950 :     case MLSTRING_CODE:
951 :     #ifdef DEBUG_C_CALLS
952 :     SayDebug("word_CtoML: string \"%s\"\n", (char *)**p);
953 :     #endif
954 :     tag = MLSTRING_TAG;
955 :     spaceCheck(msp,strlen((char *)**p),root);
956 :     mlval = ML_CString(msp,(char *) **p);
957 :     (*p)++;
958 :     break;
959 :     case MLOPENSTRUCT_CODE: {
960 :     ml_val_t local_root;
961 :    
962 :     tag = MLSTRUCT_TAG;
963 :     mlval = LIST_nil;
964 :    
965 :     #ifdef DEBUG_C_CALLS
966 :     SayDebug("word_CtoML: open struct\n");
967 :     #endif
968 :     while (**t != MLCLOSESTRUCT_CODE) {
969 :     LIST_cons(msp,local_root,mlval,*root);
970 :     ret = word_CtoML(msp,t,p,&local_root);
971 :     mlval = LIST_hd(local_root);
972 :     *root = LIST_tl(local_root);
973 :     LIST_cons(msp,mlval,ret,mlval);
974 :     IF_PAD_DO_PAD(p,t);
975 :     }
976 :     (*t)++; /* advance past MLCLOSESTRUCT_CODE */
977 :     mlval = revMLList(mlval,LIST_nil);
978 :     }
979 :     break;
980 :     case MLCLOSESTRUCT_CODE:
981 :     Die("word_CtoML: found lone MLCLOSESTRUCT_CODE");
982 :     case MLARRAY_CODE:
983 :     case MLVECTOR_CODE: {
984 :     int szb;
985 :     char *saved_t;
986 :     ml_val_t res,local_root;
987 :     int n,i;
988 :     Word_t dtag;
989 :    
990 :     tag = (code == MLARRAY_CODE) ? MLARRAY_TAG : MLVECTOR_TAG;
991 :     dtag = (code == MLARRAY_CODE) ? DTAG_array : DTAG_vector;
992 :     n = extractUnsigned((unsigned char **)t,2); /* number of elements */
993 :     szb = extractUnsigned((unsigned char **)t,2);/* element sz (bytes)*/
994 :     #ifdef DEBUG_C_CALLS
995 :     SayDebug("word_CtoML: array/vector with %d elems of size %d\n", n, szb);
996 :     #endif
997 :     saved_t = *t;
998 :     spaceCheck(msp,szb*n,root);
999 :     /* ML_AllocArray isn't used here since it might call GC */
1000 :     ML_AllocWrite (msp, 0, MAKE_DESC(n,dtag));
1001 :     mlval = ML_Alloc (msp, n);
1002 :     /* clear the array/vector so that it can be GC'd if necessary */
1003 :     for (i = 0; i < n; i++) {
1004 :     PTR_MLtoC(ml_val_t,mlval)[i] = ML_unit;
1005 :     }
1006 :     for (i = 0; i < n; i++) {
1007 :     *t = saved_t;
1008 :     LIST_cons(msp,local_root,mlval,*root);
1009 :     res = word_CtoML(msp,t,p,&local_root);
1010 :     mlval = LIST_hd(local_root);
1011 :     *root = LIST_tl(local_root);
1012 :     PTR_MLtoC(ml_val_t,mlval)[i] = res;
1013 :     }
1014 :     }
1015 :     break;
1016 :     default:
1017 :     #ifdef DEBUG_C_CALLS
1018 :     SayDebug("word_CtoML: bad type is '%c'\n", *(*t-1));
1019 :     #endif
1020 :     Die("word_CtoML: cannot yet handle type\n");
1021 :     }
1022 :     REC_ALLOC2(msp,ret,INT_CtoML(tag),mlval);
1023 :     return ret;
1024 :     }
1025 :    
1026 :     /* static c-calls-fns.c needs to see this */
1027 :     ml_val_t datumCtoML(ml_state_t *msp, char *type, Word_t p, ml_val_t *root)
1028 :     {
1029 :     ml_val_t ret;
1030 :    
1031 :     #ifdef DEBUG_C_CALLS
1032 :     SayDebug("datumCtoML: C address is %x\n", p);
1033 :     #endif
1034 :    
1035 :     #ifdef DEBUG_C_CALLS
1036 :     SayDebug("datumCtoML: type is %s\n", type);
1037 :     #endif
1038 :    
1039 :     switch (*type) {
1040 :     case MLDOUBLE_CODE:
1041 :     ret = double_CtoML(msp, *(double *)p);
1042 :     REC_ALLOC2(msp,ret,INT_CtoML(MLDOUBLE_TAG),ret);
1043 :     break;
1044 :     case MLFLOAT_CODE:
1045 :     ret = double_CtoML(msp, (double) (*(float *)p));
1046 :     REC_ALLOC2(msp,ret,INT_CtoML(MLFLOAT_TAG),ret);
1047 :     break;
1048 :     default: {
1049 :     Word_t *q = &p;
1050 :     ret = word_CtoML(msp,&type,&q,root);
1051 :     }
1052 :     break;
1053 :     }
1054 :     #ifdef DEBUG_C_CALLS
1055 :     SayDebug("datumCtoML: returning\n");
1056 :     #endif
1057 :     return ret;
1058 :     }
1059 :    
1060 :    
1061 :     /* ML entry point for 'datumCtoML' */
1062 :     ml_val_t ml_datumCtoML(ml_state_t *msp, ml_val_t arg)
1063 :     {
1064 :     /* make copies of things that GC may move */
1065 :     char *type = mk_strcpy(REC_SELPTR(char,arg,0));
1066 :     Word_t *caddr = GET_CADDR(REC_SEL(arg,1));
1067 :     ml_val_t ret;
1068 :    
1069 :     ret = datumCtoML(msp,type,(Word_t) caddr,&arg);
1070 :     free(type);
1071 :     return ret;
1072 :     }
1073 :    
1074 :    
1075 :     /* ML entry point for 'c_call' */
1076 :     ml_val_t ml_c_call(ml_state_t *msp, ml_val_t arg)
1077 :     {
1078 :     #if !defined(INDIRECT_CFUNC)
1079 :     Word_t (*f)() = (Word_t (*)())
1080 :     REC_SELPTR(Word_t,arg,0);
1081 :     #else
1082 :     Word_t (*f)() = (Word_t (*)())
1083 :     ((cfunc_binding_t *)REC_SELPTR(Word_t,arg,0))->cfunc;
1084 :     #endif
1085 :     int n_cargs = REC_SELINT(arg,1);
1086 :     ml_val_t carg_types = REC_SEL(arg,2); /* string list */
1087 :     char *cret_type = REC_SELPTR(char,arg,3);
1088 :     ml_val_t cargs = REC_SEL(arg,4); /* cdata list */
1089 :     bool_t auto_free = REC_SELINT(arg,5);
1090 :     ptrlist_t *saved_pl;
1091 :    
1092 :     ml_val_t p,q;
1093 :     ml_val_t ret;
1094 :     int i;
1095 :     Word_t vals[N_ARGS];
1096 :     Word_t w;
1097 :     int err = NO_ERR;
1098 :    
1099 :     if (n_cargs > N_ARGS) /* shouldn't see this; ML side insures this */
1100 :     return RaiseError(msp,ERR_TOO_MANY_ARGS);
1101 :    
1102 :     /* save the ptrlist since C can call ML can call C ... */
1103 :     save_ptrlist(&saved_pl);
1104 :    
1105 :     p = carg_types;
1106 :     q = cargs;
1107 :     i = 0;
1108 :     while (p != LIST_nil && q != LIST_nil) {
1109 :     char *carg_type = PTR_MLtoC(char,LIST_hd(p));
1110 :     Word_t *vp;
1111 :    
1112 :     #ifdef DEBUG_C_CALLS
1113 :     SayDebug("ml_c_call: arg %d:\"%s\"\n",i,carg_type);
1114 :     #endif
1115 :    
1116 :     vp = &vals[i];
1117 :     if (err = datumMLtoC(msp,&carg_type,&vp,LIST_hd(q)))
1118 :     break;
1119 :     i++;
1120 :     p = LIST_tl(p);
1121 :     q = LIST_tl(q);
1122 :     }
1123 :     #ifdef DEBUG_C_CALLS
1124 :     SayDebug("ml_c_call: rettype is \"%s\"\n", cret_type);
1125 :     #endif
1126 :    
1127 :     /* within ml_c_call, no ML allocation occurs above this point */
1128 :    
1129 :     if (!err && (i != n_cargs))
1130 :     err = ERR_WRONG_ARG_COUNT;
1131 :     if (err) {
1132 :     free_ptrlist();
1133 :     restore_ptrlist(saved_pl);
1134 :     return RaiseError(msp,err);
1135 :     }
1136 :     #ifdef DEBUG_C_CALLS
1137 :     SayDebug("ml_c_call: calling C function at %x\n", f);
1138 :     #endif
1139 :    
1140 :     /* expose msp so C has access to it */
1141 :     visible_msp = msp;
1142 :     switch (*cret_type) {
1143 :     case MLDOUBLE_CODE:
1144 :     ret = double_CtoML(msp,call_double_fn((double (*)())f,n_cargs,vals));
1145 :     REC_ALLOC2(msp,ret,INT_CtoML(MLDOUBLE_TAG),ret);
1146 :     break;
1147 :     case MLFLOAT_CODE:
1148 :     ret = double_CtoML(msp,
1149 :     (double) call_float_fn((float(*)())f,n_cargs,vals));
1150 :     REC_ALLOC2(msp,ret,INT_CtoML(MLFLOAT_TAG),ret);
1151 :     break;
1152 :     case MLCHAR_CODE: {
1153 :     Byte_t b = (Byte_t) call_word_fn(f,n_cargs,vals);
1154 :     Byte_t *bp = &b;
1155 :    
1156 :     ret = word_CtoML(msp,&cret_type,(Word_t **)&bp,&dummyRoot);
1157 :     }
1158 :     break;
1159 :     default: {
1160 :     Word_t w = call_word_fn(f,n_cargs,vals);
1161 :     Word_t *wp = &w;
1162 :    
1163 :     ret = word_CtoML(msp,&cret_type,&wp,&dummyRoot);
1164 :     }
1165 :     }
1166 :     #ifdef DEBUG_C_CALLS
1167 :     SayDebug("ml_c_call: returned from C function\n");
1168 :     #endif
1169 :    
1170 :     #ifdef DEBUG_C_CALLS
1171 :     SayDebug("ml_c_call: auto_free is %d\n",auto_free);
1172 :     #endif
1173 :    
1174 :     /* setup the return value, always a pair */
1175 :     {
1176 :     ml_val_t lp = LIST_nil;
1177 :    
1178 :     if (auto_free) {
1179 :     #ifdef DEBUG_C_CALLS
1180 :     SayDebug("ml_c_call: performing auto-free\n");
1181 :     #endif
1182 :    
1183 :     free_ptrlist();
1184 :     } else {
1185 :     /* return (result,list of pointers to alloc'd C objects) */
1186 :     #ifdef DEBUG_C_CALLS
1187 :     SayDebug("ml_c_call: returning list of caddrs\n");
1188 :     #endif
1189 :     spaceCheck(msp,ptrlist_space(),&ret);
1190 :     lp = ptrlist_to_MLlist(msp); /* this frees the ptr descriptors */
1191 :     }
1192 :     REC_ALLOC2(msp, ret, ret, lp);
1193 :     }
1194 :     restore_ptrlist(saved_pl); /* restore the previous ptrlist */
1195 :     return ret;
1196 :     }
1197 :    
1198 :    
1199 :     /* end of c-calls.c */

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0