1 /* Copyright (C) 2010, 2011, 2012, 2013 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
30 #include "libguile/_scm.h"
31 #include "libguile/bytevectors.h"
32 #include "libguile/instructions.h"
33 #include "libguile/threads.h"
34 #include "libguile/foreign.h"
38 SCM_SYMBOL (sym_void
, "void");
39 SCM_SYMBOL (sym_float
, "float");
40 SCM_SYMBOL (sym_double
, "double");
41 SCM_SYMBOL (sym_uint8
, "uint8");
42 SCM_SYMBOL (sym_int8
, "int8");
43 SCM_SYMBOL (sym_uint16
, "uint16");
44 SCM_SYMBOL (sym_int16
, "int16");
45 SCM_SYMBOL (sym_uint32
, "uint32");
46 SCM_SYMBOL (sym_int32
, "int32");
47 SCM_SYMBOL (sym_uint64
, "uint64");
48 SCM_SYMBOL (sym_int64
, "int64");
49 SCM_SYMBOL (sym_short
, "short");
50 SCM_SYMBOL (sym_int
, "int");
51 SCM_SYMBOL (sym_long
, "long");
52 SCM_SYMBOL (sym_unsigned_short
, "unsigned-short");
53 SCM_SYMBOL (sym_unsigned_int
, "unsigned-int");
54 SCM_SYMBOL (sym_unsigned_long
, "unsigned-long");
55 SCM_SYMBOL (sym_size_t
, "size_t");
56 SCM_SYMBOL (sym_ssize_t
, "ssize_t");
57 SCM_SYMBOL (sym_ptrdiff_t
, "ptrdiff_t");
59 /* that's for pointers, you know. */
60 SCM_SYMBOL (sym_asterisk
, "*");
62 SCM_SYMBOL (sym_null
, "%null-pointer");
63 SCM_SYMBOL (sym_null_pointer_error
, "null-pointer-error");
65 /* The cell representing the null pointer. */
66 static SCM null_pointer
;
69 /* Raise a null pointer dereference error. */
71 null_pointer_error (const char *func_name
)
73 scm_error (sym_null_pointer_error
, func_name
,
74 "null pointer dereference", SCM_EOL
, SCM_EOL
);
78 static SCM
cif_to_procedure (SCM cif
, SCM func_ptr
);
81 static SCM pointer_weak_refs
= SCM_BOOL_F
;
85 register_weak_reference (SCM from
, SCM to
)
87 scm_weak_table_putq_x (pointer_weak_refs
, from
, to
);
91 pointer_finalizer_trampoline (void *ptr
, void *data
)
93 scm_t_pointer_finalizer finalizer
= data
;
94 finalizer (SCM_POINTER_VALUE (SCM_PACK_POINTER (ptr
)));
97 SCM_DEFINE (scm_pointer_p
, "pointer?", 1, 0, 0,
99 "Return @code{#t} if @var{obj} is a pointer object, "
100 "@code{#f} otherwise.\n")
101 #define FUNC_NAME s_scm_pointer_p
103 return scm_from_bool (SCM_POINTER_P (obj
));
107 SCM_DEFINE (scm_make_pointer
, "make-pointer", 1, 1, 0,
108 (SCM address
, SCM finalizer
),
109 "Return a foreign pointer object pointing to @var{address}. "
110 "If @var{finalizer} is passed, it should be a pointer to a "
111 "one-argument C function that will be called when the pointer "
112 "object becomes unreachable.")
113 #define FUNC_NAME s_scm_make_pointer
116 scm_t_uintptr c_address
;
118 c_address
= scm_to_uintptr_t (address
);
119 if (SCM_UNBNDP (finalizer
))
123 SCM_VALIDATE_POINTER (2, finalizer
);
124 c_finalizer
= SCM_POINTER_VALUE (finalizer
);
127 return scm_from_pointer ((void *) c_address
, c_finalizer
);
132 scm_to_pointer (SCM pointer
)
133 #define FUNC_NAME "scm_to_pointer"
135 SCM_VALIDATE_POINTER (1, pointer
);
136 return SCM_POINTER_VALUE (pointer
);
141 scm_from_pointer (void *ptr
, scm_t_pointer_finalizer finalizer
)
145 if (ptr
== NULL
&& finalizer
== NULL
)
149 ret
= scm_cell (scm_tc7_pointer
, (scm_t_bits
) ptr
);
152 scm_i_set_finalizer (SCM2PTR (ret
), pointer_finalizer_trampoline
,
159 SCM_DEFINE (scm_pointer_address
, "pointer-address", 1, 0, 0,
161 "Return the numerical value of @var{pointer}.")
162 #define FUNC_NAME s_scm_pointer_address
164 SCM_VALIDATE_POINTER (1, pointer
);
166 return scm_from_uintptr_t ((scm_t_uintptr
) SCM_POINTER_VALUE (pointer
));
170 SCM_DEFINE (scm_pointer_to_scm
, "pointer->scm", 1, 0, 0,
172 "Unsafely cast @var{pointer} to a Scheme object.\n"
173 "Cross your fingers!")
174 #define FUNC_NAME s_scm_pointer_to_scm
176 SCM_VALIDATE_POINTER (1, pointer
);
178 return SCM_PACK ((scm_t_bits
) SCM_POINTER_VALUE (pointer
));
182 SCM_DEFINE (scm_scm_to_pointer
, "scm->pointer", 1, 0, 0,
184 "Return a foreign pointer object with the @code{object-address}\n"
186 #define FUNC_NAME s_scm_scm_to_pointer
190 ret
= scm_from_pointer ((void*) SCM_UNPACK (scm
), NULL
);
191 if (SCM_HEAP_OBJECT_P (ret
))
192 register_weak_reference (ret
, scm
);
198 SCM_DEFINE (scm_pointer_to_bytevector
, "pointer->bytevector", 2, 2, 0,
199 (SCM pointer
, SCM len
, SCM offset
, SCM uvec_type
),
200 "Return a bytevector aliasing the @var{len} bytes pointed\n"
201 "to by @var{pointer}.\n\n"
202 "The user may specify an alternate default interpretation for\n"
203 "the memory by passing the @var{uvec_type} argument, to indicate\n"
204 "that the memory is an array of elements of that type.\n"
205 "@var{uvec_type} should be something that\n"
206 "@code{uniform-vector-element-type} would return, like @code{f32}\n"
208 "When @var{offset} is passed, it specifies the offset in bytes\n"
209 "relative to @var{pointer} of the memory region aliased by the\n"
210 "returned bytevector.")
211 #define FUNC_NAME s_scm_pointer_to_bytevector
215 size_t boffset
, blen
;
216 scm_t_array_element_type btype
;
218 SCM_VALIDATE_POINTER (1, pointer
);
219 ptr
= SCM_POINTER_VALUE (pointer
);
221 if (SCM_UNLIKELY (ptr
== NULL
))
222 null_pointer_error (FUNC_NAME
);
224 if (SCM_UNBNDP (uvec_type
))
225 btype
= SCM_ARRAY_ELEMENT_TYPE_VU8
;
229 for (i
= 0; i
<= SCM_ARRAY_ELEMENT_TYPE_LAST
; i
++)
230 if (scm_is_eq (uvec_type
, scm_i_array_element_types
[i
]))
234 case SCM_ARRAY_ELEMENT_TYPE_VU8
:
235 case SCM_ARRAY_ELEMENT_TYPE_U8
:
236 case SCM_ARRAY_ELEMENT_TYPE_S8
:
237 case SCM_ARRAY_ELEMENT_TYPE_U16
:
238 case SCM_ARRAY_ELEMENT_TYPE_S16
:
239 case SCM_ARRAY_ELEMENT_TYPE_U32
:
240 case SCM_ARRAY_ELEMENT_TYPE_S32
:
241 case SCM_ARRAY_ELEMENT_TYPE_U64
:
242 case SCM_ARRAY_ELEMENT_TYPE_S64
:
243 case SCM_ARRAY_ELEMENT_TYPE_F32
:
244 case SCM_ARRAY_ELEMENT_TYPE_F64
:
245 case SCM_ARRAY_ELEMENT_TYPE_C32
:
246 case SCM_ARRAY_ELEMENT_TYPE_C64
:
250 scm_wrong_type_arg_msg (FUNC_NAME
, SCM_ARG1
, uvec_type
,
251 "uniform vector type");
255 if (SCM_UNBNDP (offset
))
258 boffset
= scm_to_size_t (offset
);
260 blen
= scm_to_size_t (len
);
262 ret
= scm_c_take_typed_bytevector ((signed char *) ptr
+ boffset
,
263 blen
, btype
, pointer
);
269 SCM_DEFINE (scm_bytevector_to_pointer
, "bytevector->pointer", 1, 1, 0,
270 (SCM bv
, SCM offset
),
271 "Return a pointer pointer aliasing the memory pointed to by\n"
272 "@var{bv} or @var{offset} bytes after @var{bv} when @var{offset}\n"
274 #define FUNC_NAME s_scm_bytevector_to_pointer
280 SCM_VALIDATE_BYTEVECTOR (1, bv
);
281 ptr
= SCM_BYTEVECTOR_CONTENTS (bv
);
283 if (SCM_UNBNDP (offset
))
286 boffset
= scm_to_unsigned_integer (offset
, 0,
287 SCM_BYTEVECTOR_LENGTH (bv
) - 1);
289 ret
= scm_from_pointer (ptr
+ boffset
, NULL
);
290 register_weak_reference (ret
, bv
);
295 SCM_DEFINE (scm_set_pointer_finalizer_x
, "set-pointer-finalizer!", 2, 0, 0,
296 (SCM pointer
, SCM finalizer
),
297 "Arrange for the C procedure wrapped by @var{finalizer} to be\n"
298 "called on the pointer wrapped by @var{pointer} when @var{pointer}\n"
299 "becomes unreachable. Note: the C procedure should not call into\n"
300 "Scheme. If you need a Scheme finalizer, use guardians.")
301 #define FUNC_NAME s_scm_set_pointer_finalizer_x
303 SCM_VALIDATE_POINTER (1, pointer
);
304 SCM_VALIDATE_POINTER (2, finalizer
);
306 scm_i_add_finalizer (SCM2PTR (pointer
), pointer_finalizer_trampoline
,
307 SCM_POINTER_VALUE (finalizer
));
309 return SCM_UNSPECIFIED
;
314 scm_i_pointer_print (SCM pointer
, SCM port
, scm_print_state
*pstate
)
316 scm_puts_unlocked ("#<pointer 0x", port
);
317 scm_uintprint (scm_to_uintptr_t (scm_pointer_address (pointer
)), 16, port
);
318 scm_putc_unlocked ('>', port
);
322 /* Non-primitive helpers functions. These procedures could be
323 implemented in terms of the primitives above but would be inefficient
324 (heap allocation overhead, Scheme/C round trips, etc.) */
326 SCM_DEFINE (scm_dereference_pointer
, "dereference-pointer", 1, 0, 0,
328 "Assuming @var{pointer} points to a memory region that\n"
329 "holds a pointer, return this pointer.")
330 #define FUNC_NAME s_scm_dereference_pointer
334 SCM_VALIDATE_POINTER (1, pointer
);
336 ptr
= SCM_POINTER_VALUE (pointer
);
337 if (SCM_UNLIKELY (ptr
== NULL
))
338 null_pointer_error (FUNC_NAME
);
340 return scm_from_pointer (*ptr
, NULL
);
344 SCM_DEFINE (scm_string_to_pointer
, "string->pointer", 1, 1, 0,
345 (SCM string
, SCM encoding
),
346 "Return a foreign pointer to a nul-terminated copy of\n"
347 "@var{string} in the given @var{encoding}, defaulting to\n"
348 "the current locale encoding. The C string is freed when\n"
349 "the returned foreign pointer becomes unreachable.\n\n"
350 "This is the Scheme equivalent of @code{scm_to_stringn}.")
351 #define FUNC_NAME s_scm_string_to_pointer
353 SCM_VALIDATE_STRING (1, string
);
355 /* XXX: Finalizers slow down libgc; they could be avoided if
356 `scm_to_string' & co. were able to use libgc-allocated memory. */
358 if (SCM_UNBNDP (encoding
))
359 return scm_from_pointer (scm_to_locale_string (string
), free
);
365 SCM_VALIDATE_STRING (2, encoding
);
367 enc
= scm_to_locale_string (encoding
);
368 scm_dynwind_begin (0);
369 scm_dynwind_free (enc
);
371 ret
= scm_from_pointer
372 (scm_to_stringn (string
, NULL
, enc
,
373 scm_i_default_port_conversion_handler ()),
383 SCM_DEFINE (scm_pointer_to_string
, "pointer->string", 1, 2, 0,
384 (SCM pointer
, SCM length
, SCM encoding
),
385 "Return the string representing the C string pointed to by\n"
386 "@var{pointer}. If @var{length} is omitted or @code{-1}, the\n"
387 "string is assumed to be nul-terminated. Otherwise\n"
388 "@var{length} is the number of bytes in memory pointed to by\n"
389 "@var{pointer}. The C string is assumed to be in the given\n"
390 "@var{encoding}, defaulting to the current locale encoding.\n\n"
391 "This is the Scheme equivalent of @code{scm_from_stringn}.")
392 #define FUNC_NAME s_scm_pointer_to_string
396 SCM_VALIDATE_POINTER (1, pointer
);
398 if (SCM_UNBNDP (length
)
399 || scm_is_true (scm_eqv_p (length
, scm_from_int (-1))))
402 len
= scm_to_size_t (length
);
404 if (SCM_UNBNDP (encoding
))
405 return scm_from_locale_stringn (SCM_POINTER_VALUE (pointer
), len
);
411 SCM_VALIDATE_STRING (3, encoding
);
413 enc
= scm_to_locale_string (encoding
);
414 scm_dynwind_begin (0);
415 scm_dynwind_free (enc
);
417 ret
= scm_from_stringn (SCM_POINTER_VALUE (pointer
), len
, enc
,
418 scm_i_default_port_conversion_handler ());
429 SCM_DEFINE (scm_alignof
, "alignof", 1, 0, 0, (SCM type
),
430 "Return the alignment of @var{type}, in bytes.\n\n"
431 "@var{type} should be a valid C type, like @code{int}.\n"
432 "Alternately @var{type} may be the symbol @code{*}, in which\n"
433 "case the alignment of a pointer is returned. @var{type} may\n"
434 "also be a list of types, in which case the alignment of a\n"
435 "@code{struct} with ABI-conventional packing is returned.")
436 #define FUNC_NAME s_scm_alignof
438 if (SCM_I_INUMP (type
))
440 switch (SCM_I_INUM (type
))
442 case SCM_FOREIGN_TYPE_FLOAT
:
443 return scm_from_size_t (alignof_type (float));
444 case SCM_FOREIGN_TYPE_DOUBLE
:
445 return scm_from_size_t (alignof_type (double));
446 case SCM_FOREIGN_TYPE_UINT8
:
447 return scm_from_size_t (alignof_type (scm_t_uint8
));
448 case SCM_FOREIGN_TYPE_INT8
:
449 return scm_from_size_t (alignof_type (scm_t_int8
));
450 case SCM_FOREIGN_TYPE_UINT16
:
451 return scm_from_size_t (alignof_type (scm_t_uint16
));
452 case SCM_FOREIGN_TYPE_INT16
:
453 return scm_from_size_t (alignof_type (scm_t_int16
));
454 case SCM_FOREIGN_TYPE_UINT32
:
455 return scm_from_size_t (alignof_type (scm_t_uint32
));
456 case SCM_FOREIGN_TYPE_INT32
:
457 return scm_from_size_t (alignof_type (scm_t_int32
));
458 case SCM_FOREIGN_TYPE_UINT64
:
459 return scm_from_size_t (alignof_type (scm_t_uint64
));
460 case SCM_FOREIGN_TYPE_INT64
:
461 return scm_from_size_t (alignof_type (scm_t_int64
));
463 scm_wrong_type_arg (FUNC_NAME
, 1, type
);
466 else if (scm_is_eq (type
, sym_asterisk
))
468 return scm_from_size_t (alignof_type (void*));
469 else if (scm_is_pair (type
))
471 /* TYPE is a structure. Section 3-3 of the i386, x86_64, PowerPC,
472 and SPARC P.S. of the System V ABI all say: "Aggregates
473 (structures and arrays) and unions assume the alignment of
474 their most strictly aligned component." */
477 for (max
= 0; scm_is_pair (type
); type
= SCM_CDR (type
))
481 align
= scm_to_size_t (scm_alignof (SCM_CAR (type
)));
486 return scm_from_size_t (max
);
489 scm_wrong_type_arg (FUNC_NAME
, 1, type
);
493 SCM_DEFINE (scm_sizeof
, "sizeof", 1, 0, 0, (SCM type
),
494 "Return the size of @var{type}, in bytes.\n\n"
495 "@var{type} should be a valid C type, like @code{int}.\n"
496 "Alternately @var{type} may be the symbol @code{*}, in which\n"
497 "case the size of a pointer is returned. @var{type} may also\n"
498 "be a list of types, in which case the size of a @code{struct}\n"
499 "with ABI-conventional packing is returned.")
500 #define FUNC_NAME s_scm_sizeof
502 if (SCM_I_INUMP (type
))
504 switch (SCM_I_INUM (type
))
506 case SCM_FOREIGN_TYPE_FLOAT
:
507 return scm_from_size_t (sizeof (float));
508 case SCM_FOREIGN_TYPE_DOUBLE
:
509 return scm_from_size_t (sizeof (double));
510 case SCM_FOREIGN_TYPE_UINT8
:
511 return scm_from_size_t (sizeof (scm_t_uint8
));
512 case SCM_FOREIGN_TYPE_INT8
:
513 return scm_from_size_t (sizeof (scm_t_int8
));
514 case SCM_FOREIGN_TYPE_UINT16
:
515 return scm_from_size_t (sizeof (scm_t_uint16
));
516 case SCM_FOREIGN_TYPE_INT16
:
517 return scm_from_size_t (sizeof (scm_t_int16
));
518 case SCM_FOREIGN_TYPE_UINT32
:
519 return scm_from_size_t (sizeof (scm_t_uint32
));
520 case SCM_FOREIGN_TYPE_INT32
:
521 return scm_from_size_t (sizeof (scm_t_int32
));
522 case SCM_FOREIGN_TYPE_UINT64
:
523 return scm_from_size_t (sizeof (scm_t_uint64
));
524 case SCM_FOREIGN_TYPE_INT64
:
525 return scm_from_size_t (sizeof (scm_t_int64
));
527 scm_wrong_type_arg (FUNC_NAME
, 1, type
);
530 else if (scm_is_eq (type
, sym_asterisk
))
532 return scm_from_size_t (sizeof (void*));
533 else if (scm_is_pair (type
))
537 size_t align
= scm_to_size_t (scm_alignof(type
));
538 while (scm_is_pair (type
))
540 off
= ROUND_UP (off
, scm_to_size_t (scm_alignof (scm_car (type
))));
541 off
+= scm_to_size_t (scm_sizeof (scm_car (type
)));
542 type
= scm_cdr (type
);
544 return scm_from_size_t (ROUND_UP(off
, align
));
547 scm_wrong_type_arg (FUNC_NAME
, 1, type
);
552 /* return 1 on success, 0 on failure */
554 parse_ffi_type (SCM type
, int return_p
, long *n_structs
, long *n_struct_elts
)
556 if (SCM_I_INUMP (type
))
558 if ((SCM_I_INUM (type
) < 0 )
559 || (SCM_I_INUM (type
) > SCM_FOREIGN_TYPE_LAST
))
561 else if (SCM_I_INUM (type
) == SCM_FOREIGN_TYPE_VOID
&& !return_p
)
566 else if (scm_is_eq (type
, sym_asterisk
))
573 len
= scm_ilength (type
);
578 if (!parse_ffi_type (scm_car (type
), 0, n_structs
, n_struct_elts
))
581 type
= scm_cdr (type
);
589 fill_ffi_type (SCM type
, ffi_type
*ftype
, ffi_type
***type_ptrs
,
592 if (SCM_I_INUMP (type
))
594 switch (SCM_I_INUM (type
))
596 case SCM_FOREIGN_TYPE_FLOAT
:
597 *ftype
= ffi_type_float
;
599 case SCM_FOREIGN_TYPE_DOUBLE
:
600 *ftype
= ffi_type_double
;
602 case SCM_FOREIGN_TYPE_UINT8
:
603 *ftype
= ffi_type_uint8
;
605 case SCM_FOREIGN_TYPE_INT8
:
606 *ftype
= ffi_type_sint8
;
608 case SCM_FOREIGN_TYPE_UINT16
:
609 *ftype
= ffi_type_uint16
;
611 case SCM_FOREIGN_TYPE_INT16
:
612 *ftype
= ffi_type_sint16
;
614 case SCM_FOREIGN_TYPE_UINT32
:
615 *ftype
= ffi_type_uint32
;
617 case SCM_FOREIGN_TYPE_INT32
:
618 *ftype
= ffi_type_sint32
;
620 case SCM_FOREIGN_TYPE_UINT64
:
621 *ftype
= ffi_type_uint64
;
623 case SCM_FOREIGN_TYPE_INT64
:
624 *ftype
= ffi_type_sint64
;
626 case SCM_FOREIGN_TYPE_VOID
:
627 *ftype
= ffi_type_void
;
630 scm_wrong_type_arg_msg ("pointer->procedure", 0, type
,
634 else if (scm_is_eq (type
, sym_asterisk
))
637 *ftype
= ffi_type_pointer
;
644 len
= scm_ilength (type
);
647 ftype
->alignment
= 0;
648 ftype
->type
= FFI_TYPE_STRUCT
;
649 ftype
->elements
= *type_ptrs
;
650 *type_ptrs
+= len
+ 1;
652 for (i
= 0; i
< len
; i
++)
654 ftype
->elements
[i
] = *types
;
656 fill_ffi_type (scm_car (type
), ftype
->elements
[i
],
658 type
= scm_cdr (type
);
660 ftype
->elements
[i
] = NULL
;
664 /* Return a "cif" (call interface) for the given RETURN_TYPE and
667 make_cif (SCM return_type
, SCM arg_types
, const char *caller
)
668 #define FUNC_NAME caller
671 long i
, nargs
, n_structs
, n_struct_elts
;
675 ffi_type
**type_ptrs
;
678 nargs
= scm_ilength (arg_types
);
679 SCM_ASSERT (nargs
>= 0, arg_types
, 3, FUNC_NAME
);
680 /* fixme: assert nargs < 1<<32 */
681 n_structs
= n_struct_elts
= 0;
683 /* For want of talloc, we're going to have to do this in two passes: first we
684 figure out how much memory is needed for all types, then we allocate the
685 cif and the types all in one block. */
686 if (!parse_ffi_type (return_type
, 1, &n_structs
, &n_struct_elts
))
687 scm_wrong_type_arg (FUNC_NAME
, 1, return_type
);
688 for (walk
= arg_types
; scm_is_pair (walk
); walk
= scm_cdr (walk
))
689 if (!parse_ffi_type (scm_car (walk
), 0, &n_structs
, &n_struct_elts
))
690 scm_wrong_type_arg (FUNC_NAME
, 3, scm_car (walk
));
692 /* the memory: with space for the cif itself */
693 cif_len
= sizeof (ffi_cif
);
695 /* then ffi_type pointers: one for each arg, one for each struct
696 element, and one for each struct (for null-termination) */
697 cif_len
= (ROUND_UP (cif_len
, alignof_type (void *))
698 + (nargs
+ n_structs
+ n_struct_elts
)*sizeof(void*));
700 /* then the ffi_type structs themselves, one per arg and struct element, and
701 one for the return val */
702 cif_len
= (ROUND_UP (cif_len
, alignof_type (ffi_type
))
703 + (nargs
+ n_struct_elts
+ 1)*sizeof(ffi_type
));
705 mem
= scm_gc_malloc_pointerless (cif_len
, "foreign");
706 /* ensure all the memory is initialized, even the holes */
707 memset (mem
, 0, cif_len
);
708 cif
= (ffi_cif
*) mem
;
710 /* reuse cif_len to walk through the mem */
711 cif_len
= ROUND_UP (sizeof (ffi_cif
), alignof_type (void *));
712 type_ptrs
= (ffi_type
**)(mem
+ cif_len
);
713 cif_len
= ROUND_UP (cif_len
714 + (nargs
+ n_structs
+ n_struct_elts
)*sizeof(void*),
715 alignof_type (ffi_type
));
716 types
= (ffi_type
*)(mem
+ cif_len
);
718 /* whew. now knit the pointers together. */
719 cif
->rtype
= types
++;
720 fill_ffi_type (return_type
, cif
->rtype
, &type_ptrs
, &types
);
721 cif
->arg_types
= type_ptrs
;
723 for (walk
= arg_types
, i
= 0; scm_is_pair (walk
); walk
= scm_cdr (walk
), i
++)
725 cif
->arg_types
[i
] = types
++;
726 fill_ffi_type (scm_car (walk
), cif
->arg_types
[i
], &type_ptrs
, &types
);
729 /* round out the cif, and we're done. */
730 cif
->abi
= FFI_DEFAULT_ABI
;
735 if (FFI_OK
!= ffi_prep_cif (cif
, FFI_DEFAULT_ABI
, cif
->nargs
, cif
->rtype
,
737 SCM_MISC_ERROR ("ffi_prep_cif failed", SCM_EOL
);
743 SCM_DEFINE (scm_pointer_to_procedure
, "pointer->procedure", 3, 0, 0,
744 (SCM return_type
, SCM func_ptr
, SCM arg_types
),
745 "Make a foreign function.\n\n"
746 "Given the foreign void pointer @var{func_ptr}, its argument and\n"
747 "return types @var{arg_types} and @var{return_type}, return a\n"
748 "procedure that will pass arguments to the foreign function\n"
749 "and return appropriate values.\n\n"
750 "@var{arg_types} should be a list of foreign types.\n"
751 "@code{return_type} should be a foreign type.")
752 #define FUNC_NAME s_scm_pointer_to_procedure
756 SCM_VALIDATE_POINTER (2, func_ptr
);
758 cif
= make_cif (return_type
, arg_types
, FUNC_NAME
);
760 return cif_to_procedure (scm_from_pointer (cif
, NULL
), func_ptr
);
766 /* We support calling foreign functions with up to 100 arguments. */
769 SCM_PACK_OP_24 (assert_nargs_ee, nreq + 1), \
770 SCM_PACK_OP_12_12 (foreign_call, 0, 1)
773 CODE (n + 0), CODE (n + 1), CODE (n + 2), CODE (n + 3), CODE (n + 4), \
774 CODE (n + 5), CODE (n + 6), CODE (n + 7), CODE (n + 8), CODE (n + 9)
776 static const scm_t_uint32 foreign_stub_code
[] =
778 CODE_10 (0), CODE_10 (10), CODE_10 (20), CODE_10 (30), CODE_10 (40),
779 CODE_10 (50), CODE_10 (60), CODE_10 (70), CODE_10 (80), CODE_10 (90)
785 static const scm_t_uint32
*
786 get_foreign_stub_code (unsigned int nargs
)
789 scm_misc_error ("make-foreign-function", "args >= 100 currently unimplemented",
792 return &foreign_stub_code
[nargs
* 2];
795 /* Given a foreign procedure, determine its minimum arity. */
797 scm_i_foreign_arity (SCM foreign
, int *req
, int *opt
, int *rest
)
799 const scm_t_uint32
*code
= SCM_PROGRAM_CODE (foreign
);
801 if (code
< foreign_stub_code
)
803 if (code
> (foreign_stub_code
804 + (sizeof(foreign_stub_code
) / sizeof(scm_t_uint32
))))
807 *req
= (code
- foreign_stub_code
) / 2;
815 cif_to_procedure (SCM cif
, SCM func_ptr
)
819 scm_t_bits nfree
= 2;
820 scm_t_bits flags
= SCM_F_PROGRAM_IS_FOREIGN
;
822 c_cif
= (ffi_cif
*) SCM_POINTER_VALUE (cif
);
824 ret
= scm_words (scm_tc7_program
| (nfree
<< 16) | flags
, nfree
+ 2);
825 SCM_SET_CELL_WORD_1 (ret
, get_foreign_stub_code (c_cif
->nargs
));
826 SCM_PROGRAM_FREE_VARIABLE_SET (ret
, 0, cif
);
827 SCM_PROGRAM_FREE_VARIABLE_SET (ret
, 1, func_ptr
);
832 /* Set *LOC to the foreign representation of X with TYPE. */
834 unpack (const ffi_type
*type
, void *loc
, SCM x
, int return_value_p
)
835 #define FUNC_NAME "scm_i_foreign_call"
840 *(float *) loc
= scm_to_double (x
);
842 case FFI_TYPE_DOUBLE
:
843 *(double *) loc
= scm_to_double (x
);
846 /* For integer return values smaller than `int', libffi expects the
847 result in an `ffi_arg'-long buffer. */
851 *(ffi_arg
*) loc
= scm_to_uint8 (x
);
853 *(scm_t_uint8
*) loc
= scm_to_uint8 (x
);
857 *(ffi_arg
*) loc
= scm_to_int8 (x
);
859 *(scm_t_int8
*) loc
= scm_to_int8 (x
);
861 case FFI_TYPE_UINT16
:
863 *(ffi_arg
*) loc
= scm_to_uint16 (x
);
865 *(scm_t_uint16
*) loc
= scm_to_uint16 (x
);
867 case FFI_TYPE_SINT16
:
869 *(ffi_arg
*) loc
= scm_to_int16 (x
);
871 *(scm_t_int16
*) loc
= scm_to_int16 (x
);
873 case FFI_TYPE_UINT32
:
875 *(ffi_arg
*) loc
= scm_to_uint32 (x
);
877 *(scm_t_uint32
*) loc
= scm_to_uint32 (x
);
879 case FFI_TYPE_SINT32
:
881 *(ffi_arg
*) loc
= scm_to_int32 (x
);
883 *(scm_t_int32
*) loc
= scm_to_int32 (x
);
885 case FFI_TYPE_UINT64
:
886 *(scm_t_uint64
*) loc
= scm_to_uint64 (x
);
888 case FFI_TYPE_SINT64
:
889 *(scm_t_int64
*) loc
= scm_to_int64 (x
);
891 case FFI_TYPE_STRUCT
:
892 SCM_VALIDATE_POINTER (1, x
);
893 memcpy (loc
, SCM_POINTER_VALUE (x
), type
->size
);
895 case FFI_TYPE_POINTER
:
896 SCM_VALIDATE_POINTER (1, x
);
897 *(void **) loc
= SCM_POINTER_VALUE (x
);
908 /* Return a Scheme representation of the foreign value at LOC of type
909 TYPE. When RETURN_VALUE_P is true, LOC is assumed to point to a
910 return value buffer; otherwise LOC is assumed to point to an
913 pack (const ffi_type
* type
, const void *loc
, int return_value_p
)
918 return SCM_UNSPECIFIED
;
920 return scm_from_double (*(float *) loc
);
921 case FFI_TYPE_DOUBLE
:
922 return scm_from_double (*(double *) loc
);
924 /* For integer return values smaller than `int', libffi stores the
925 result in an `ffi_arg'-long buffer, of which only the
926 significant bits must be kept---hence the pair of casts below.
927 See <http://thread.gmane.org/gmane.comp.lib.ffi.general/406>
932 return scm_from_uint8 ((scm_t_uint8
) *(ffi_arg
*) loc
);
934 return scm_from_uint8 (* (scm_t_uint8
*) loc
);
937 return scm_from_int8 ((scm_t_int8
) *(ffi_arg
*) loc
);
939 return scm_from_int8 (* (scm_t_int8
*) loc
);
940 case FFI_TYPE_UINT16
:
942 return scm_from_uint16 ((scm_t_uint16
) *(ffi_arg
*) loc
);
944 return scm_from_uint16 (* (scm_t_uint16
*) loc
);
945 case FFI_TYPE_SINT16
:
947 return scm_from_int16 ((scm_t_int16
) *(ffi_arg
*) loc
);
949 return scm_from_int16 (* (scm_t_int16
*) loc
);
950 case FFI_TYPE_UINT32
:
952 return scm_from_uint32 ((scm_t_uint32
) *(ffi_arg
*) loc
);
954 return scm_from_uint32 (* (scm_t_uint32
*) loc
);
955 case FFI_TYPE_SINT32
:
957 return scm_from_int32 ((scm_t_int32
) *(ffi_arg
*) loc
);
959 return scm_from_int32 (* (scm_t_int32
*) loc
);
960 case FFI_TYPE_UINT64
:
961 return scm_from_uint64 (*(scm_t_uint64
*) loc
);
962 case FFI_TYPE_SINT64
:
963 return scm_from_int64 (*(scm_t_int64
*) loc
);
965 case FFI_TYPE_STRUCT
:
967 void *mem
= scm_gc_malloc_pointerless (type
->size
, "foreign");
968 memcpy (mem
, loc
, type
->size
);
969 return scm_from_pointer (mem
, NULL
);
971 case FFI_TYPE_POINTER
:
972 return scm_from_pointer (*(void **) loc
, NULL
);
980 scm_i_foreign_call (SCM foreign
, const SCM
*argv
)
982 /* FOREIGN is the pair that cif_to_procedure set as the 0th element of the
993 cif
= SCM_POINTER_VALUE (SCM_CAR (foreign
));
994 func
= SCM_POINTER_VALUE (SCM_CDR (foreign
));
996 /* Argument pointers. */
997 args
= alloca (sizeof (void *) * cif
->nargs
);
999 /* Compute the worst-case amount of memory needed to store all the argument
1000 values. Note: as of libffi 3.0.9 `cif->bytes' is undocumented and is zero,
1001 so it can't be used for that purpose. */
1002 for (i
= 0, arg_size
= 0; i
< cif
->nargs
; i
++)
1003 arg_size
+= cif
->arg_types
[i
]->size
+ cif
->arg_types
[i
]->alignment
- 1;
1005 /* Space for argument values, followed by return value. */
1006 data
= alloca (arg_size
+ cif
->rtype
->size
1007 + max (sizeof (void *), cif
->rtype
->alignment
));
1009 /* Unpack ARGV to native values, setting ARGV pointers. */
1010 for (i
= 0, off
= 0;
1012 off
= (scm_t_uint8
*) args
[i
] - data
+ cif
->arg_types
[i
]->size
,
1015 /* Suitably align the storage area for argument I. */
1016 args
[i
] = (void *) ROUND_UP ((scm_t_uintptr
) data
+ off
,
1017 cif
->arg_types
[i
]->alignment
);
1018 assert ((scm_t_uintptr
) args
[i
] % cif
->arg_types
[i
]->alignment
== 0);
1019 unpack (cif
->arg_types
[i
], args
[i
], argv
[i
], 0);
1022 /* Prepare space for the return value. On some platforms, such as
1023 `armv5tel-*-linux-gnueabi', the return value has to be at least
1024 word-aligned, even if its type doesn't have any alignment requirement as is
1025 the case with `char'. */
1026 rvalue
= (void *) ROUND_UP ((scm_t_uintptr
) data
+ off
,
1027 max (sizeof (void *), cif
->rtype
->alignment
));
1030 ffi_call (cif
, func
, rvalue
, args
);
1032 return pack (cif
->rtype
, rvalue
, 1);
1036 /* Function pointers aka. "callbacks" or "closures". */
1040 /* Trampoline to invoke a libffi closure that wraps a Scheme
1043 invoke_closure (ffi_cif
*cif
, void *ret
, void **args
, void *data
)
1046 SCM proc
, *argv
, result
;
1048 proc
= SCM_PACK_POINTER (data
);
1050 argv
= alloca (cif
->nargs
* sizeof (*argv
));
1052 /* Pack ARGS to SCM values, setting ARGV pointers. */
1053 for (i
= 0; i
< cif
->nargs
; i
++)
1054 argv
[i
] = pack (cif
->arg_types
[i
], args
[i
], 0);
1056 result
= scm_call_n (proc
, argv
, cif
->nargs
);
1058 unpack (cif
->rtype
, ret
, result
, 1);
1061 SCM_DEFINE (scm_procedure_to_pointer
, "procedure->pointer", 3, 0, 0,
1062 (SCM return_type
, SCM proc
, SCM arg_types
),
1063 "Return a pointer to a C function of type @var{return_type}\n"
1064 "taking arguments of types @var{arg_types} (a list) and\n"
1065 "behaving as a proxy to procedure @var{proc}. Thus\n"
1066 "@var{proc}'s arity, supported argument types, and return\n"
1067 "type should match @var{return_type} and @var{arg_types}.\n")
1068 #define FUNC_NAME s_scm_procedure_to_pointer
1070 SCM cif_pointer
, pointer
;
1073 void *closure
, *executable
;
1075 cif
= make_cif (return_type
, arg_types
, FUNC_NAME
);
1077 closure
= ffi_closure_alloc (sizeof (ffi_closure
), &executable
);
1078 err
= ffi_prep_closure_loc ((ffi_closure
*) closure
, cif
,
1079 invoke_closure
, SCM_UNPACK_POINTER (proc
),
1083 ffi_closure_free (closure
);
1084 SCM_MISC_ERROR ("`ffi_prep_closure_loc' failed", SCM_EOL
);
1087 /* CIF points to GC-managed memory and it should remain as long as
1088 POINTER (see below) is live. Wrap it in a Scheme pointer to then
1089 hold a weak reference on it. */
1090 cif_pointer
= scm_from_pointer (cif
, NULL
);
1092 if (closure
== executable
)
1094 pointer
= scm_from_pointer (executable
, ffi_closure_free
);
1095 register_weak_reference (pointer
,
1096 scm_list_2 (proc
, cif_pointer
));
1100 /* CLOSURE needs to be freed eventually. However, since
1101 `GC_all_interior_pointers' is disabled, we can't just register
1102 a finalizer for CLOSURE. Instead, we create a pointer object
1103 for CLOSURE, with a finalizer, and register it as a weak
1104 reference of POINTER. */
1107 pointer
= scm_from_pointer (executable
, NULL
);
1108 friend = scm_from_pointer (closure
, ffi_closure_free
);
1110 register_weak_reference (pointer
,
1111 scm_list_3 (proc
, cif_pointer
, friend));
1118 #endif /* FFI_CLOSURES */
1123 scm_init_foreign (void)
1125 #ifndef SCM_MAGIC_SNARFER
1126 #include "libguile/foreign.x"
1128 scm_define (sym_void
, scm_from_uint8 (SCM_FOREIGN_TYPE_VOID
));
1129 scm_define (sym_float
, scm_from_uint8 (SCM_FOREIGN_TYPE_FLOAT
));
1130 scm_define (sym_double
, scm_from_uint8 (SCM_FOREIGN_TYPE_DOUBLE
));
1131 scm_define (sym_uint8
, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT8
));
1132 scm_define (sym_int8
, scm_from_uint8 (SCM_FOREIGN_TYPE_INT8
));
1133 scm_define (sym_uint16
, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT16
));
1134 scm_define (sym_int16
, scm_from_uint8 (SCM_FOREIGN_TYPE_INT16
));
1135 scm_define (sym_uint32
, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32
));
1136 scm_define (sym_int32
, scm_from_uint8 (SCM_FOREIGN_TYPE_INT32
));
1137 scm_define (sym_uint64
, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64
));
1138 scm_define (sym_int64
, scm_from_uint8 (SCM_FOREIGN_TYPE_INT64
));
1140 scm_define (sym_short
,
1141 #if SIZEOF_SHORT == 8
1142 scm_from_uint8 (SCM_FOREIGN_TYPE_INT64
)
1143 #elif SIZEOF_SHORT == 4
1144 scm_from_uint8 (SCM_FOREIGN_TYPE_INT32
)
1145 #elif SIZEOF_SHORT == 2
1146 scm_from_uint8 (SCM_FOREIGN_TYPE_INT16
)
1148 # error unsupported sizeof (short)
1152 scm_define (sym_unsigned_short
,
1153 #if SIZEOF_SHORT == 8
1154 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64
)
1155 #elif SIZEOF_SHORT == 4
1156 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32
)
1157 #elif SIZEOF_SHORT == 2
1158 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT16
)
1160 # error unsupported sizeof (short)
1164 scm_define (sym_int
,
1166 scm_from_uint8 (SCM_FOREIGN_TYPE_INT64
)
1167 #elif SIZEOF_INT == 4
1168 scm_from_uint8 (SCM_FOREIGN_TYPE_INT32
)
1170 # error unsupported sizeof (int)
1174 scm_define (sym_unsigned_int
,
1175 #if SIZEOF_UNSIGNED_INT == 8
1176 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64
)
1177 #elif SIZEOF_UNSIGNED_INT == 4
1178 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32
)
1180 # error unsupported sizeof (unsigned int)
1184 scm_define (sym_long
,
1185 #if SIZEOF_LONG == 8
1186 scm_from_uint8 (SCM_FOREIGN_TYPE_INT64
)
1187 #elif SIZEOF_LONG == 4
1188 scm_from_uint8 (SCM_FOREIGN_TYPE_INT32
)
1190 # error unsupported sizeof (long)
1194 scm_define (sym_unsigned_long
,
1195 #if SIZEOF_UNSIGNED_LONG == 8
1196 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64
)
1197 #elif SIZEOF_UNSIGNED_LONG == 4
1198 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32
)
1200 # error unsupported sizeof (unsigned long)
1204 scm_define (sym_size_t
,
1205 #if SIZEOF_SIZE_T == 8
1206 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64
)
1207 #elif SIZEOF_SIZE_T == 4
1208 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32
)
1210 # error unsupported sizeof (size_t)
1214 scm_define (sym_ssize_t
,
1215 #if SIZEOF_SIZE_T == 8
1216 scm_from_uint8 (SCM_FOREIGN_TYPE_INT64
)
1217 #elif SIZEOF_SIZE_T == 4
1218 scm_from_uint8 (SCM_FOREIGN_TYPE_INT32
)
1220 # error unsupported sizeof (ssize_t)
1224 scm_define (sym_ptrdiff_t
,
1225 #if SCM_SIZEOF_SCM_T_PTRDIFF == 8
1226 scm_from_uint8 (SCM_FOREIGN_TYPE_INT64
)
1227 #elif SCM_SIZEOF_SCM_T_PTRDIFF == 4
1228 scm_from_uint8 (SCM_FOREIGN_TYPE_INT32
)
1230 # error unsupported sizeof (scm_t_ptrdiff)
1234 null_pointer
= scm_cell (scm_tc7_pointer
, 0);
1235 scm_define (sym_null
, null_pointer
);
1239 scm_register_foreign (void)
1241 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1243 (scm_t_extension_init_func
)scm_init_foreign
,
1245 pointer_weak_refs
= scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY
);