1 /* Copyright (C) 2010 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful, but
9 * WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
29 #include "libguile/_scm.h"
30 #include "libguile/bytevectors.h"
31 #include "libguile/instructions.h"
32 #include "libguile/foreign.h"
36 SCM_SYMBOL (sym_void
, "void");
37 SCM_SYMBOL (sym_float
, "float");
38 SCM_SYMBOL (sym_double
, "double");
39 SCM_SYMBOL (sym_uint8
, "uint8");
40 SCM_SYMBOL (sym_int8
, "int8");
41 SCM_SYMBOL (sym_uint16
, "uint16");
42 SCM_SYMBOL (sym_int16
, "int16");
43 SCM_SYMBOL (sym_uint32
, "uint32");
44 SCM_SYMBOL (sym_int32
, "int32");
45 SCM_SYMBOL (sym_uint64
, "uint64");
46 SCM_SYMBOL (sym_int64
, "int64");
47 SCM_SYMBOL (sym_int
, "int");
48 SCM_SYMBOL (sym_long
, "long");
49 SCM_SYMBOL (sym_unsigned_int
, "unsigned-int");
50 SCM_SYMBOL (sym_unsigned_long
, "unsigned-long");
51 SCM_SYMBOL (sym_size_t
, "size_t");
53 /* that's for pointers, you know. */
54 SCM_SYMBOL (sym_asterisk
, "*");
56 SCM_SYMBOL (sym_null
, "%null-pointer");
57 SCM_SYMBOL (sym_null_pointer_error
, "null-pointer-error");
59 /* The cell representing the null pointer. */
60 static SCM null_pointer
;
62 #if SIZEOF_VOID_P == 4
63 # define scm_to_uintptr scm_to_uint32
64 # define scm_from_uintptr scm_from_uint32
65 #elif SIZEOF_VOID_P == 8
66 # define scm_to_uintptr scm_to_uint64
67 # define scm_from_uintptr scm_from_uint64
69 # error unsupported pointer size
73 /* Raise a null pointer dereference error. */
75 null_pointer_error (const char *func_name
)
77 scm_error (sym_null_pointer_error
, func_name
,
78 "null pointer dereference", SCM_EOL
, SCM_EOL
);
82 static SCM
cif_to_procedure (SCM cif
, SCM func_ptr
);
85 static SCM pointer_weak_refs
= SCM_BOOL_F
;
88 register_weak_reference (SCM from
, SCM to
)
90 scm_hashq_set_x (pointer_weak_refs
, from
, to
);
94 pointer_finalizer_trampoline (GC_PTR ptr
, GC_PTR data
)
96 scm_t_pointer_finalizer finalizer
= data
;
97 finalizer (SCM_POINTER_VALUE (PTR2SCM (ptr
)));
100 SCM_DEFINE (scm_make_pointer
, "make-pointer", 1, 1, 0,
101 (SCM address
, SCM finalizer
),
102 "Return a foreign pointer object pointing to @var{address}. "
103 "If @var{finalizer} is passed, it should be a pointer to a "
104 "one-argument C function that will be called when the pointer "
105 "object becomes unreachable.")
106 #define FUNC_NAME s_scm_make_pointer
109 scm_t_uintptr c_address
;
112 c_address
= scm_to_uintptr (address
);
113 if (SCM_UNBNDP (finalizer
))
117 SCM_VALIDATE_POINTER (2, finalizer
);
118 c_finalizer
= SCM_POINTER_VALUE (finalizer
);
121 if (c_address
== 0 && c_finalizer
== NULL
)
122 result
= null_pointer
;
124 result
= scm_from_pointer ((void *) c_address
, c_finalizer
);
131 scm_from_pointer (void *ptr
, scm_t_pointer_finalizer finalizer
)
136 word0
= scm_tc7_pointer
| (finalizer
? (1 << 16UL) : 0UL);
138 ret
= scm_cell (word0
, (scm_t_bits
) ptr
);
141 /* Register a finalizer for the newly created instance. */
142 GC_finalization_proc prev_finalizer
;
143 GC_PTR prev_finalizer_data
;
144 GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (ret
),
145 pointer_finalizer_trampoline
,
148 &prev_finalizer_data
);
154 SCM_DEFINE (scm_pointer_address
, "pointer-address", 1, 0, 0,
156 "Return the numerical value of @var{pointer}.")
157 #define FUNC_NAME s_scm_pointer_address
159 SCM_VALIDATE_POINTER (1, pointer
);
161 return scm_from_uintptr ((scm_t_uintptr
) SCM_POINTER_VALUE (pointer
));
165 SCM_DEFINE (scm_dereference_pointer
, "dereference-pointer", 1, 0, 0,
167 "Return the a pointer object representing the pointer "
168 "pointed to by @var{pointer}.")
169 #define FUNC_NAME s_scm_dereference_pointer
171 SCM_VALIDATE_POINTER (1, pointer
);
173 return scm_from_pointer (* (void **) SCM_POINTER_VALUE (pointer
), NULL
);
177 SCM_DEFINE (scm_pointer_to_bytevector
, "pointer->bytevector", 2, 2, 0,
178 (SCM pointer
, SCM len
, SCM offset
, SCM uvec_type
),
179 "Return a bytevector aliasing the memory pointed to by\n"
181 "@var{pointer} must be a void pointer, a pointer whose type is\n"
182 "@var{void}. By default, the resulting bytevector will alias\n"
183 "all of the memory pointed to by @var{pointer}, from beginning\n"
184 "to end, treated as a @code{vu8} array.\n\n"
185 "The user may specify an alternate default interpretation for\n"
186 "the memory by passing the @var{uvec_type} argument, to indicate\n"
187 "that the memory is an array of elements of that type.\n"
188 "@var{uvec_type} should be something that\n"
189 "@code{uniform-vector-element-type} would return, like @code{f32}\n"
191 "Users may also specify that the bytevector should only alias a\n"
192 "subset of the memory, by specifying @var{offset} and @var{len}\n"
194 #define FUNC_NAME s_scm_pointer_to_bytevector
198 size_t boffset
, blen
;
199 scm_t_array_element_type btype
;
201 SCM_VALIDATE_POINTER (1, pointer
);
202 ptr
= SCM_POINTER_VALUE (pointer
);
204 if (SCM_UNLIKELY (ptr
== NULL
))
205 null_pointer_error (FUNC_NAME
);
207 if (SCM_UNBNDP (uvec_type
))
208 btype
= SCM_ARRAY_ELEMENT_TYPE_VU8
;
212 for (i
= 0; i
<= SCM_ARRAY_ELEMENT_TYPE_LAST
; i
++)
213 if (scm_is_eq (uvec_type
, scm_i_array_element_types
[i
]))
217 case SCM_ARRAY_ELEMENT_TYPE_VU8
:
218 case SCM_ARRAY_ELEMENT_TYPE_U8
:
219 case SCM_ARRAY_ELEMENT_TYPE_S8
:
220 case SCM_ARRAY_ELEMENT_TYPE_U16
:
221 case SCM_ARRAY_ELEMENT_TYPE_S16
:
222 case SCM_ARRAY_ELEMENT_TYPE_U32
:
223 case SCM_ARRAY_ELEMENT_TYPE_S32
:
224 case SCM_ARRAY_ELEMENT_TYPE_U64
:
225 case SCM_ARRAY_ELEMENT_TYPE_S64
:
226 case SCM_ARRAY_ELEMENT_TYPE_F32
:
227 case SCM_ARRAY_ELEMENT_TYPE_F64
:
228 case SCM_ARRAY_ELEMENT_TYPE_C32
:
229 case SCM_ARRAY_ELEMENT_TYPE_C64
:
233 scm_wrong_type_arg_msg (FUNC_NAME
, SCM_ARG1
, uvec_type
,
234 "uniform vector type");
238 if (SCM_UNBNDP (offset
))
241 boffset
= scm_to_size_t (offset
);
243 blen
= scm_to_size_t (len
);
245 ret
= scm_c_take_typed_bytevector (ptr
+ boffset
, blen
, btype
);
246 register_weak_reference (ret
, pointer
);
251 SCM_DEFINE (scm_bytevector_to_pointer
, "bytevector->pointer", 1, 2, 0,
252 (SCM bv
, SCM offset
, SCM len
),
253 "Return a pointer pointer aliasing the memory pointed to by\n"
255 "The resulting pointer will be a void pointer, a pointer whose\n"
256 "type is @code{void}. By default it will alias all of the\n"
257 "memory pointed to by @var{bv}, from beginning to end.\n\n"
258 "Users may explicily specify that the pointer should only alias a\n"
259 "subset of the memory, by specifying @var{offset} and @var{len}\n"
261 #define FUNC_NAME s_scm_bytevector_to_pointer
265 size_t boffset
, blen
;
267 SCM_VALIDATE_BYTEVECTOR (1, bv
);
268 ptr
= SCM_BYTEVECTOR_CONTENTS (bv
);
270 if (SCM_UNBNDP (offset
))
273 boffset
= scm_to_unsigned_integer (offset
, 0,
274 SCM_BYTEVECTOR_LENGTH (bv
) - 1);
276 if (SCM_UNBNDP (len
))
277 blen
= SCM_BYTEVECTOR_LENGTH (bv
) - boffset
;
279 blen
= scm_to_unsigned_integer (len
, 0,
280 SCM_BYTEVECTOR_LENGTH (bv
) - boffset
);
282 ret
= scm_from_pointer (ptr
+ boffset
, NULL
);
283 register_weak_reference (ret
, bv
);
288 SCM_DEFINE (scm_set_pointer_finalizer_x
, "set-pointer-finalizer!", 2, 0, 0,
289 (SCM pointer
, SCM finalizer
),
290 "Arrange for the C procedure wrapped by @var{finalizer} to be\n"
291 "called on the pointer wrapped by @var{pointer} when @var{pointer}\n"
292 "becomes unreachable. Note: the C procedure should not call into\n"
293 "Scheme. If you need a Scheme finalizer, use guardians.")
294 #define FUNC_NAME s_scm_set_pointer_finalizer_x
297 GC_finalization_proc prev_finalizer
;
298 GC_PTR prev_finalizer_data
;
300 SCM_VALIDATE_POINTER (1, pointer
);
301 SCM_VALIDATE_POINTER (2, finalizer
);
303 c_finalizer
= SCM_POINTER_VALUE (finalizer
);
305 SCM_SET_CELL_WORD_0 (pointer
, SCM_CELL_WORD_0 (pointer
) | (1 << 16UL));
307 GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (pointer
),
308 pointer_finalizer_trampoline
,
311 &prev_finalizer_data
);
313 return SCM_UNSPECIFIED
;
320 scm_i_pointer_print (SCM pointer
, SCM port
, scm_print_state
*pstate
)
322 scm_puts ("#<pointer ", port
);
323 scm_display (scm_pointer_address (pointer
), port
);
324 scm_putc ('>', port
);
329 SCM_DEFINE (scm_alignof
, "alignof", 1, 0, 0, (SCM type
),
330 "Return the alignment of @var{type}, in bytes.\n\n"
331 "@var{type} should be a valid C type, like @code{int}.\n"
332 "Alternately @var{type} may be the symbol @code{*}, in which\n"
333 "case the alignment of a pointer is returned. @var{type} may\n"
334 "also be a list of types, in which case the alignment of a\n"
335 "@code{struct} with ABI-conventional packing is returned.")
336 #define FUNC_NAME s_scm_alignof
338 if (SCM_I_INUMP (type
))
340 switch (SCM_I_INUM (type
))
342 case SCM_FOREIGN_TYPE_FLOAT
:
343 return scm_from_size_t (alignof (float));
344 case SCM_FOREIGN_TYPE_DOUBLE
:
345 return scm_from_size_t (alignof (double));
346 case SCM_FOREIGN_TYPE_UINT8
:
347 return scm_from_size_t (alignof (scm_t_uint8
));
348 case SCM_FOREIGN_TYPE_INT8
:
349 return scm_from_size_t (alignof (scm_t_int8
));
350 case SCM_FOREIGN_TYPE_UINT16
:
351 return scm_from_size_t (alignof (scm_t_uint16
));
352 case SCM_FOREIGN_TYPE_INT16
:
353 return scm_from_size_t (alignof (scm_t_int16
));
354 case SCM_FOREIGN_TYPE_UINT32
:
355 return scm_from_size_t (alignof (scm_t_uint32
));
356 case SCM_FOREIGN_TYPE_INT32
:
357 return scm_from_size_t (alignof (scm_t_int32
));
358 case SCM_FOREIGN_TYPE_UINT64
:
359 return scm_from_size_t (alignof (scm_t_uint64
));
360 case SCM_FOREIGN_TYPE_INT64
:
361 return scm_from_size_t (alignof (scm_t_int64
));
363 scm_wrong_type_arg (FUNC_NAME
, 1, type
);
366 else if (scm_is_eq (type
, sym_asterisk
))
368 return scm_from_size_t (alignof (void*));
369 else if (scm_is_pair (type
))
371 return scm_alignof (scm_car (type
));
373 scm_wrong_type_arg (FUNC_NAME
, 1, type
);
377 SCM_DEFINE (scm_sizeof
, "sizeof", 1, 0, 0, (SCM type
),
378 "Return the size of @var{type}, in bytes.\n\n"
379 "@var{type} should be a valid C type, like @code{int}.\n"
380 "Alternately @var{type} may be the symbol @code{*}, in which\n"
381 "case the size of a pointer is returned. @var{type} may also\n"
382 "be a list of types, in which case the size of a @code{struct}\n"
383 "with ABI-conventional packing is returned.")
384 #define FUNC_NAME s_scm_sizeof
386 if (SCM_I_INUMP (type
))
388 switch (SCM_I_INUM (type
))
390 case SCM_FOREIGN_TYPE_FLOAT
:
391 return scm_from_size_t (sizeof (float));
392 case SCM_FOREIGN_TYPE_DOUBLE
:
393 return scm_from_size_t (sizeof (double));
394 case SCM_FOREIGN_TYPE_UINT8
:
395 return scm_from_size_t (sizeof (scm_t_uint8
));
396 case SCM_FOREIGN_TYPE_INT8
:
397 return scm_from_size_t (sizeof (scm_t_int8
));
398 case SCM_FOREIGN_TYPE_UINT16
:
399 return scm_from_size_t (sizeof (scm_t_uint16
));
400 case SCM_FOREIGN_TYPE_INT16
:
401 return scm_from_size_t (sizeof (scm_t_int16
));
402 case SCM_FOREIGN_TYPE_UINT32
:
403 return scm_from_size_t (sizeof (scm_t_uint32
));
404 case SCM_FOREIGN_TYPE_INT32
:
405 return scm_from_size_t (sizeof (scm_t_int32
));
406 case SCM_FOREIGN_TYPE_UINT64
:
407 return scm_from_size_t (sizeof (scm_t_uint64
));
408 case SCM_FOREIGN_TYPE_INT64
:
409 return scm_from_size_t (sizeof (scm_t_int64
));
411 scm_wrong_type_arg (FUNC_NAME
, 1, type
);
414 else if (scm_is_eq (type
, sym_asterisk
))
416 return scm_from_size_t (sizeof (void*));
417 else if (scm_is_pair (type
))
421 while (scm_is_pair (type
))
423 off
= ROUND_UP (off
, scm_to_size_t (scm_alignof (scm_car (type
))));
424 off
+= scm_to_size_t (scm_sizeof (scm_car (type
)));
425 type
= scm_cdr (type
);
427 return scm_from_size_t (off
);
430 scm_wrong_type_arg (FUNC_NAME
, 1, type
);
435 /* return 1 on success, 0 on failure */
437 parse_ffi_type (SCM type
, int return_p
, long *n_structs
, long *n_struct_elts
)
439 if (SCM_I_INUMP (type
))
441 if ((SCM_I_INUM (type
) < 0 )
442 || (SCM_I_INUM (type
) > SCM_FOREIGN_TYPE_LAST
))
444 else if (SCM_I_INUM (type
) == SCM_FOREIGN_TYPE_VOID
&& !return_p
)
449 else if (scm_is_eq (type
, sym_asterisk
))
456 len
= scm_ilength (type
);
461 if (!parse_ffi_type (scm_car (type
), 0, n_structs
, n_struct_elts
))
464 type
= scm_cdr (type
);
472 fill_ffi_type (SCM type
, ffi_type
*ftype
, ffi_type
***type_ptrs
,
475 if (SCM_I_INUMP (type
))
477 switch (SCM_I_INUM (type
))
479 case SCM_FOREIGN_TYPE_FLOAT
:
480 *ftype
= ffi_type_float
;
482 case SCM_FOREIGN_TYPE_DOUBLE
:
483 *ftype
= ffi_type_double
;
485 case SCM_FOREIGN_TYPE_UINT8
:
486 *ftype
= ffi_type_uint8
;
488 case SCM_FOREIGN_TYPE_INT8
:
489 *ftype
= ffi_type_sint8
;
491 case SCM_FOREIGN_TYPE_UINT16
:
492 *ftype
= ffi_type_uint16
;
494 case SCM_FOREIGN_TYPE_INT16
:
495 *ftype
= ffi_type_sint16
;
497 case SCM_FOREIGN_TYPE_UINT32
:
498 *ftype
= ffi_type_uint32
;
500 case SCM_FOREIGN_TYPE_INT32
:
501 *ftype
= ffi_type_sint32
;
503 case SCM_FOREIGN_TYPE_UINT64
:
504 *ftype
= ffi_type_uint64
;
506 case SCM_FOREIGN_TYPE_INT64
:
507 *ftype
= ffi_type_sint64
;
509 case SCM_FOREIGN_TYPE_VOID
:
510 *ftype
= ffi_type_void
;
513 scm_wrong_type_arg_msg ("make-foreign-function", 0, type
,
517 else if (scm_is_eq (type
, sym_asterisk
))
520 *ftype
= ffi_type_pointer
;
527 len
= scm_ilength (type
);
530 ftype
->alignment
= 0;
531 ftype
->type
= FFI_TYPE_STRUCT
;
532 ftype
->elements
= *type_ptrs
;
533 *type_ptrs
+= len
+ 1;
535 for (i
= 0; i
< len
; i
++)
537 ftype
->elements
[i
] = *types
;
539 fill_ffi_type (scm_car (type
), ftype
->elements
[i
],
541 type
= scm_cdr (type
);
543 ftype
->elements
[i
] = NULL
;
547 SCM_DEFINE (scm_make_foreign_function
, "make-foreign-function", 3, 0, 0,
548 (SCM return_type
, SCM func_ptr
, SCM arg_types
),
549 "Make a foreign function.\n\n"
550 "Given the foreign void pointer @var{func_ptr}, its argument and\n"
551 "return types @var{arg_types} and @var{return_type}, return a\n"
552 "procedure that will pass arguments to the foreign function\n"
553 "and return appropriate values.\n\n"
554 "@var{arg_types} should be a list of foreign types.\n"
555 "@code{return_type} should be a foreign type.")
556 #define FUNC_NAME s_scm_make_foreign_function
559 long i
, nargs
, n_structs
, n_struct_elts
;
563 ffi_type
**type_ptrs
;
566 SCM_VALIDATE_POINTER (2, func_ptr
);
568 nargs
= scm_ilength (arg_types
);
569 SCM_ASSERT (nargs
>= 0, arg_types
, 3, FUNC_NAME
);
570 /* fixme: assert nargs < 1<<32 */
571 n_structs
= n_struct_elts
= 0;
573 /* For want of talloc, we're going to have to do this in two passes: first we
574 figure out how much memory is needed for all types, then we allocate the
575 cif and the types all in one block. */
576 if (!parse_ffi_type (return_type
, 1, &n_structs
, &n_struct_elts
))
577 scm_wrong_type_arg (FUNC_NAME
, 1, return_type
);
578 for (walk
= arg_types
; scm_is_pair (walk
); walk
= scm_cdr (walk
))
579 if (!parse_ffi_type (scm_car (walk
), 0, &n_structs
, &n_struct_elts
))
580 scm_wrong_type_arg (FUNC_NAME
, 3, scm_car (walk
));
582 /* the memory: with space for the cif itself */
583 cif_len
= sizeof (ffi_cif
);
585 /* then ffi_type pointers: one for each arg, one for each struct
586 element, and one for each struct (for null-termination) */
587 cif_len
= (ROUND_UP (cif_len
, alignof(void*))
588 + (nargs
+ n_structs
+ n_struct_elts
)*sizeof(void*));
590 /* then the ffi_type structs themselves, one per arg and struct element, and
591 one for the return val */
592 cif_len
= (ROUND_UP (cif_len
, alignof(ffi_type
))
593 + (nargs
+ n_struct_elts
+ 1)*sizeof(ffi_type
));
595 mem
= scm_gc_malloc_pointerless (cif_len
, "foreign");
596 scm_cif
= scm_from_pointer (mem
, NULL
);
597 cif
= (ffi_cif
*) mem
;
599 /* reuse cif_len to walk through the mem */
600 cif_len
= ROUND_UP (sizeof (ffi_cif
), alignof(void*));
601 type_ptrs
= (ffi_type
**)(mem
+ cif_len
);
602 cif_len
= ROUND_UP (cif_len
603 + (nargs
+ n_structs
+ n_struct_elts
)*sizeof(void*),
605 types
= (ffi_type
*)(mem
+ cif_len
);
607 /* whew. now knit the pointers together. */
608 cif
->rtype
= types
++;
609 fill_ffi_type (return_type
, cif
->rtype
, &type_ptrs
, &types
);
610 cif
->arg_types
= type_ptrs
;
612 for (walk
= arg_types
, i
= 0; scm_is_pair (walk
); walk
= scm_cdr (walk
), i
++)
614 cif
->arg_types
[i
] = types
++;
615 fill_ffi_type (scm_car (walk
), cif
->arg_types
[i
], &type_ptrs
, &types
);
618 /* round out the cif, and we're done. */
619 cif
->abi
= FFI_DEFAULT_ABI
;
624 if (FFI_OK
!= ffi_prep_cif (cif
, FFI_DEFAULT_ABI
, cif
->nargs
, cif
->rtype
,
626 scm_misc_error (FUNC_NAME
, "ffi_prep_cif failed", SCM_EOL
);
628 return cif_to_procedure (scm_cif
, func_ptr
);
634 /* Pre-generate trampolines for less than 10 arguments. */
636 #ifdef WORDS_BIGENDIAN
637 #define OBJCODE_HEADER 0, 0, 0, 8, 0, 0, 0, 40
638 #define META_HEADER 0, 0, 0, 32, 0, 0, 0, 0
640 #define OBJCODE_HEADER 8, 0, 0, 0, 40, 0, 0, 0
641 #define META_HEADER 32, 0, 0, 0, 0, 0, 0, 0
646 /* 0 */ scm_op_assert_nargs_ee, 0, nreq, /* assert number of args */ \
647 /* 3 */ scm_op_object_ref, 0, /* push the pair with the cif and the function pointer */ \
648 /* 5 */ scm_op_foreign_call, nreq, /* and call (will return value as well) */ \
649 /* 7 */ scm_op_nop, \
650 /* 8 */ META (3, 7, nreq)
652 #define META(start, end, nreq) \
654 /* 0 */ scm_op_make_eol, /* bindings */ \
655 /* 1 */ scm_op_make_eol, /* sources */ \
656 /* 2 */ scm_op_make_int8, start, scm_op_make_int8, end, /* arity: from ip N to ip N */ \
657 /* 6 */ scm_op_make_int8, nreq, /* the arity is N required args */ \
658 /* 8 */ scm_op_list, 0, 3, /* make a list of those 3 vals */ \
659 /* 11 */ scm_op_list, 0, 1, /* and the arities will be a list of that one list */ \
660 /* 14 */ scm_op_load_symbol, 0, 0, 4, 'n', 'a', 'm', 'e', /* `name' */ \
661 /* 22 */ scm_op_object_ref, 1, /* the name from the object table */ \
662 /* 24 */ scm_op_cons, /* make a pair for the properties */ \
663 /* 25 */ scm_op_list, 0, 4, /* pack bindings, sources, and arities into list */ \
664 /* 28 */ scm_op_return, /* and return */ \
665 /* 29 */ scm_op_nop, scm_op_nop, scm_op_nop \
670 scm_t_uint64 dummy
; /* ensure 8-byte alignment; perhaps there's a better way */
671 const scm_t_uint8 bytes
[10 * (sizeof (struct scm_objcode
) + 8
672 + sizeof (struct scm_objcode
) + 32)];
676 CODE (0), CODE (1), CODE (2), CODE (3), CODE (4),
677 CODE (5), CODE (6), CODE (7), CODE (8), CODE (9)
683 #undef OBJCODE_HEADER
687 (defun generate-objcode-cells (n)
688 "Generate objcode cells for up to N arguments"
693 (format " { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + %d) },\n"
694 (* (+ 4 4 8 4 4 32) i)))
695 (insert " { SCM_BOOL_F, SCM_PACK (0) },\n")
698 #define STATIC_OBJCODE_TAG \
699 SCM_PACK (scm_tc7_objcode | (SCM_F_OBJCODE_IS_STATIC << 8))
703 scm_t_uint64 dummy
; /* alignment */
704 scm_t_cell cells
[10 * 2]; /* 10 double cells */
707 /* C-u 1 0 M-x generate-objcode-cells RET */
709 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 0) },
710 { SCM_BOOL_F
, SCM_PACK (0) },
711 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 56) },
712 { SCM_BOOL_F
, SCM_PACK (0) },
713 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 112) },
714 { SCM_BOOL_F
, SCM_PACK (0) },
715 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 168) },
716 { SCM_BOOL_F
, SCM_PACK (0) },
717 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 224) },
718 { SCM_BOOL_F
, SCM_PACK (0) },
719 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 280) },
720 { SCM_BOOL_F
, SCM_PACK (0) },
721 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 336) },
722 { SCM_BOOL_F
, SCM_PACK (0) },
723 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 392) },
724 { SCM_BOOL_F
, SCM_PACK (0) },
725 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 448) },
726 { SCM_BOOL_F
, SCM_PACK (0) },
727 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 504) },
728 { SCM_BOOL_F
, SCM_PACK (0) }
732 static const SCM objcode_trampolines
[10] = {
733 SCM_PACK (objcode_cells
.cells
+0),
734 SCM_PACK (objcode_cells
.cells
+2),
735 SCM_PACK (objcode_cells
.cells
+4),
736 SCM_PACK (objcode_cells
.cells
+6),
737 SCM_PACK (objcode_cells
.cells
+8),
738 SCM_PACK (objcode_cells
.cells
+10),
739 SCM_PACK (objcode_cells
.cells
+12),
740 SCM_PACK (objcode_cells
.cells
+14),
741 SCM_PACK (objcode_cells
.cells
+16),
742 SCM_PACK (objcode_cells
.cells
+18),
746 cif_to_procedure (SCM cif
, SCM func_ptr
)
750 SCM objcode
, table
, ret
;
752 c_cif
= (ffi_cif
*) SCM_POINTER_VALUE (cif
);
753 nargs
= c_cif
->nargs
;
756 objcode
= objcode_trampolines
[nargs
];
758 scm_misc_error ("make-foreign-function", "args >= 10 currently unimplemented",
761 table
= scm_c_make_vector (2, SCM_UNDEFINED
);
762 SCM_SIMPLE_VECTOR_SET (table
, 0, scm_cons (cif
, func_ptr
));
763 SCM_SIMPLE_VECTOR_SET (table
, 1, SCM_BOOL_F
); /* name */
764 ret
= scm_make_program (objcode
, table
, SCM_BOOL_F
);
769 /* Set *LOC to the foreign representation of X with TYPE. */
771 unpack (const ffi_type
*type
, void *loc
, SCM x
)
776 *(float *) loc
= scm_to_double (x
);
778 case FFI_TYPE_DOUBLE
:
779 *(double *) loc
= scm_to_double (x
);
782 *(scm_t_uint8
*) loc
= scm_to_uint8 (x
);
785 *(scm_t_int8
*) loc
= scm_to_int8 (x
);
787 case FFI_TYPE_UINT16
:
788 *(scm_t_uint16
*) loc
= scm_to_uint16 (x
);
790 case FFI_TYPE_SINT16
:
791 *(scm_t_int16
*) loc
= scm_to_int16 (x
);
793 case FFI_TYPE_UINT32
:
794 *(scm_t_uint32
*) loc
= scm_to_uint32 (x
);
796 case FFI_TYPE_SINT32
:
797 *(scm_t_int32
*) loc
= scm_to_int32 (x
);
799 case FFI_TYPE_UINT64
:
800 *(scm_t_uint64
*) loc
= scm_to_uint64 (x
);
802 case FFI_TYPE_SINT64
:
803 *(scm_t_int64
*) loc
= scm_to_int64 (x
);
805 case FFI_TYPE_STRUCT
:
806 memcpy (loc
, SCM_POINTER_VALUE (x
), type
->size
);
808 case FFI_TYPE_POINTER
:
809 *(void **) loc
= SCM_POINTER_VALUE (x
);
816 /* Return a Scheme representation of the foreign value at LOC of type TYPE. */
818 pack (const ffi_type
* type
, const void *loc
)
823 return SCM_UNSPECIFIED
;
825 return scm_from_double (*(float *) loc
);
826 case FFI_TYPE_DOUBLE
:
827 return scm_from_double (*(double *) loc
);
829 return scm_from_uint8 (*(scm_t_uint8
*) loc
);
831 return scm_from_int8 (*(scm_t_int8
*) loc
);
832 case FFI_TYPE_UINT16
:
833 return scm_from_uint16 (*(scm_t_uint16
*) loc
);
834 case FFI_TYPE_SINT16
:
835 return scm_from_int16 (*(scm_t_int16
*) loc
);
836 case FFI_TYPE_UINT32
:
837 return scm_from_uint32 (*(scm_t_uint32
*) loc
);
838 case FFI_TYPE_SINT32
:
839 return scm_from_int32 (*(scm_t_int32
*) loc
);
840 case FFI_TYPE_UINT64
:
841 return scm_from_uint64 (*(scm_t_uint64
*) loc
);
842 case FFI_TYPE_SINT64
:
843 return scm_from_int64 (*(scm_t_int64
*) loc
);
844 case FFI_TYPE_STRUCT
:
846 void *mem
= scm_gc_malloc_pointerless (type
->size
, "foreign");
847 memcpy (mem
, loc
, type
->size
);
848 return scm_from_pointer (mem
, NULL
);
850 case FFI_TYPE_POINTER
:
851 return scm_from_pointer (*(void **) loc
, NULL
);
859 scm_i_foreign_call (SCM foreign
, const SCM
*argv
)
861 /* FOREIGN is the pair that cif_to_procedure set as the 0th element of the
872 cif
= SCM_POINTER_VALUE (SCM_CAR (foreign
));
873 func
= SCM_POINTER_VALUE (SCM_CDR (foreign
));
875 /* Argument pointers. */
876 args
= alloca (sizeof (void *) * cif
->nargs
);
878 /* Compute the worst-case amount of memory needed to store all the argument
879 values. Note: as of libffi 3.0.9 `cif->bytes' is undocumented and is zero,
880 so it can't be used for that purpose. */
881 for (i
= 0, arg_size
= 0; i
< cif
->nargs
; i
++)
882 arg_size
+= cif
->arg_types
[i
]->size
+ cif
->arg_types
[i
]->alignment
- 1;
884 /* Space for argument values, followed by return value. */
885 data
= alloca (arg_size
+ cif
->rtype
->size
886 + max (sizeof (void *), cif
->rtype
->alignment
));
888 /* Unpack ARGV to native values, setting ARGV pointers. */
891 off
= (scm_t_uint8
*) args
[i
] - data
+ cif
->arg_types
[i
]->size
,
894 /* Suitably align the storage area for argument I. */
895 args
[i
] = (void *) ROUND_UP ((scm_t_uintptr
) data
+ off
,
896 cif
->arg_types
[i
]->alignment
);
897 assert ((scm_t_uintptr
) args
[i
] % cif
->arg_types
[i
]->alignment
== 0);
898 unpack (cif
->arg_types
[i
], args
[i
], argv
[i
]);
901 /* Prepare space for the return value. On some platforms, such as
902 `armv5tel-*-linux-gnueabi', the return value has to be at least
903 word-aligned, even if its type doesn't have any alignment requirement as is
904 the case with `char'. */
905 rvalue
= (void *) ROUND_UP ((scm_t_uintptr
) data
+ off
,
906 max (sizeof (void *), cif
->rtype
->alignment
));
909 ffi_call (cif
, func
, rvalue
, args
);
911 return pack (cif
->rtype
, rvalue
);
917 scm_init_foreign (void)
919 #ifndef SCM_MAGIC_SNARFER
920 #include "libguile/foreign.x"
922 scm_define (sym_void
, scm_from_uint8 (SCM_FOREIGN_TYPE_VOID
));
923 scm_define (sym_float
, scm_from_uint8 (SCM_FOREIGN_TYPE_FLOAT
));
924 scm_define (sym_double
, scm_from_uint8 (SCM_FOREIGN_TYPE_DOUBLE
));
925 scm_define (sym_uint8
, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT8
));
926 scm_define (sym_int8
, scm_from_uint8 (SCM_FOREIGN_TYPE_INT8
));
927 scm_define (sym_uint16
, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT16
));
928 scm_define (sym_int16
, scm_from_uint8 (SCM_FOREIGN_TYPE_INT16
));
929 scm_define (sym_uint32
, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32
));
930 scm_define (sym_int32
, scm_from_uint8 (SCM_FOREIGN_TYPE_INT32
));
931 scm_define (sym_uint64
, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64
));
932 scm_define (sym_int64
, scm_from_uint8 (SCM_FOREIGN_TYPE_INT64
));
936 scm_from_uint8 (SCM_FOREIGN_TYPE_INT64
)
937 #elif SIZEOF_INT == 4
938 scm_from_uint8 (SCM_FOREIGN_TYPE_INT32
)
940 # error unsupported sizeof (int)
944 scm_define (sym_unsigned_int
,
945 #if SIZEOF_UNSIGNED_INT == 8
946 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64
)
947 #elif SIZEOF_UNSIGNED_INT == 4
948 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32
)
950 # error unsupported sizeof (unsigned int)
954 scm_define (sym_long
,
956 scm_from_uint8 (SCM_FOREIGN_TYPE_INT64
)
957 #elif SIZEOF_LONG == 4
958 scm_from_uint8 (SCM_FOREIGN_TYPE_INT32
)
960 # error unsupported sizeof (long)
964 scm_define (sym_unsigned_long
,
965 #if SIZEOF_UNSIGNED_LONG == 8
966 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64
)
967 #elif SIZEOF_UNSIGNED_LONG == 4
968 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32
)
970 # error unsupported sizeof (unsigned long)
974 scm_define (sym_size_t
,
975 #if SIZEOF_SIZE_T == 8
976 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64
)
977 #elif SIZEOF_SIZE_T == 4
978 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32
)
980 # error unsupported sizeof (size_t)
984 null_pointer
= scm_cell (scm_tc7_pointer
, 0);
985 scm_define (sym_null
, null_pointer
);
989 scm_register_foreign (void)
991 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
993 (scm_t_extension_init_func
)scm_init_foreign
,
995 pointer_weak_refs
= scm_make_weak_key_hash_table (SCM_UNDEFINED
);