1 /* Copyright (C) 2010, 2011 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/foreign.h"
37 SCM_SYMBOL (sym_void
, "void");
38 SCM_SYMBOL (sym_float
, "float");
39 SCM_SYMBOL (sym_double
, "double");
40 SCM_SYMBOL (sym_uint8
, "uint8");
41 SCM_SYMBOL (sym_int8
, "int8");
42 SCM_SYMBOL (sym_uint16
, "uint16");
43 SCM_SYMBOL (sym_int16
, "int16");
44 SCM_SYMBOL (sym_uint32
, "uint32");
45 SCM_SYMBOL (sym_int32
, "int32");
46 SCM_SYMBOL (sym_uint64
, "uint64");
47 SCM_SYMBOL (sym_int64
, "int64");
48 SCM_SYMBOL (sym_short
, "short");
49 SCM_SYMBOL (sym_int
, "int");
50 SCM_SYMBOL (sym_long
, "long");
51 SCM_SYMBOL (sym_unsigned_short
, "unsigned-short");
52 SCM_SYMBOL (sym_unsigned_int
, "unsigned-int");
53 SCM_SYMBOL (sym_unsigned_long
, "unsigned-long");
54 SCM_SYMBOL (sym_size_t
, "size_t");
56 /* that's for pointers, you know. */
57 SCM_SYMBOL (sym_asterisk
, "*");
59 SCM_SYMBOL (sym_null
, "%null-pointer");
60 SCM_SYMBOL (sym_null_pointer_error
, "null-pointer-error");
62 /* The cell representing the null pointer. */
63 static SCM null_pointer
;
65 #if SIZEOF_VOID_P == 4
66 # define scm_to_uintptr scm_to_uint32
67 # define scm_from_uintptr scm_from_uint32
68 #elif SIZEOF_VOID_P == 8
69 # define scm_to_uintptr scm_to_uint64
70 # define scm_from_uintptr scm_from_uint64
72 # error unsupported pointer size
76 /* Raise a null pointer dereference error. */
78 null_pointer_error (const char *func_name
)
80 scm_error (sym_null_pointer_error
, func_name
,
81 "null pointer dereference", SCM_EOL
, SCM_EOL
);
85 static SCM
cif_to_procedure (SCM cif
, SCM func_ptr
);
88 static SCM pointer_weak_refs
= SCM_BOOL_F
;
91 register_weak_reference (SCM from
, SCM to
)
93 scm_hashq_set_x (pointer_weak_refs
, from
, to
);
97 pointer_finalizer_trampoline (GC_PTR ptr
, GC_PTR data
)
99 scm_t_pointer_finalizer finalizer
= data
;
100 finalizer (SCM_POINTER_VALUE (PTR2SCM (ptr
)));
103 SCM_DEFINE (scm_pointer_p
, "pointer?", 1, 0, 0,
105 "Return @code{#t} if @var{obj} is a pointer object, "
106 "@code{#f} otherwise.\n")
107 #define FUNC_NAME s_scm_pointer_p
109 return scm_from_bool (SCM_POINTER_P (obj
));
113 SCM_DEFINE (scm_make_pointer
, "make-pointer", 1, 1, 0,
114 (SCM address
, SCM finalizer
),
115 "Return a foreign pointer object pointing to @var{address}. "
116 "If @var{finalizer} is passed, it should be a pointer to a "
117 "one-argument C function that will be called when the pointer "
118 "object becomes unreachable.")
119 #define FUNC_NAME s_scm_make_pointer
122 scm_t_uintptr c_address
;
124 c_address
= scm_to_uintptr (address
);
125 if (SCM_UNBNDP (finalizer
))
129 SCM_VALIDATE_POINTER (2, finalizer
);
130 c_finalizer
= SCM_POINTER_VALUE (finalizer
);
133 return scm_from_pointer ((void *) c_address
, c_finalizer
);
138 scm_from_pointer (void *ptr
, scm_t_pointer_finalizer finalizer
)
142 if (ptr
== NULL
&& finalizer
== NULL
)
146 ret
= scm_cell (scm_tc7_pointer
, (scm_t_bits
) ptr
);
150 /* Register a finalizer for the newly created instance. */
151 GC_finalization_proc prev_finalizer
;
152 GC_PTR prev_finalizer_data
;
153 GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (ret
),
154 pointer_finalizer_trampoline
,
157 &prev_finalizer_data
);
164 SCM_DEFINE (scm_pointer_address
, "pointer-address", 1, 0, 0,
166 "Return the numerical value of @var{pointer}.")
167 #define FUNC_NAME s_scm_pointer_address
169 SCM_VALIDATE_POINTER (1, pointer
);
171 return scm_from_uintptr ((scm_t_uintptr
) SCM_POINTER_VALUE (pointer
));
175 SCM_DEFINE (scm_pointer_to_bytevector
, "pointer->bytevector", 2, 2, 0,
176 (SCM pointer
, SCM len
, SCM offset
, SCM uvec_type
),
177 "Return a bytevector aliasing the @var{len} bytes pointed\n"
178 "to by @var{pointer}.\n\n"
179 "The user may specify an alternate default interpretation for\n"
180 "the memory by passing the @var{uvec_type} argument, to indicate\n"
181 "that the memory is an array of elements of that type.\n"
182 "@var{uvec_type} should be something that\n"
183 "@code{uniform-vector-element-type} would return, like @code{f32}\n"
185 "When @var{offset} is passed, it specifies the offset in bytes\n"
186 "relative to @var{pointer} of the memory region aliased by the\n"
187 "returned bytevector.")
188 #define FUNC_NAME s_scm_pointer_to_bytevector
192 size_t boffset
, blen
;
193 scm_t_array_element_type btype
;
195 SCM_VALIDATE_POINTER (1, pointer
);
196 ptr
= SCM_POINTER_VALUE (pointer
);
198 if (SCM_UNLIKELY (ptr
== NULL
))
199 null_pointer_error (FUNC_NAME
);
201 if (SCM_UNBNDP (uvec_type
))
202 btype
= SCM_ARRAY_ELEMENT_TYPE_VU8
;
206 for (i
= 0; i
<= SCM_ARRAY_ELEMENT_TYPE_LAST
; i
++)
207 if (scm_is_eq (uvec_type
, scm_i_array_element_types
[i
]))
211 case SCM_ARRAY_ELEMENT_TYPE_VU8
:
212 case SCM_ARRAY_ELEMENT_TYPE_U8
:
213 case SCM_ARRAY_ELEMENT_TYPE_S8
:
214 case SCM_ARRAY_ELEMENT_TYPE_U16
:
215 case SCM_ARRAY_ELEMENT_TYPE_S16
:
216 case SCM_ARRAY_ELEMENT_TYPE_U32
:
217 case SCM_ARRAY_ELEMENT_TYPE_S32
:
218 case SCM_ARRAY_ELEMENT_TYPE_U64
:
219 case SCM_ARRAY_ELEMENT_TYPE_S64
:
220 case SCM_ARRAY_ELEMENT_TYPE_F32
:
221 case SCM_ARRAY_ELEMENT_TYPE_F64
:
222 case SCM_ARRAY_ELEMENT_TYPE_C32
:
223 case SCM_ARRAY_ELEMENT_TYPE_C64
:
227 scm_wrong_type_arg_msg (FUNC_NAME
, SCM_ARG1
, uvec_type
,
228 "uniform vector type");
232 if (SCM_UNBNDP (offset
))
235 boffset
= scm_to_size_t (offset
);
237 blen
= scm_to_size_t (len
);
239 ret
= scm_c_take_typed_bytevector (ptr
+ boffset
, blen
, btype
);
240 register_weak_reference (ret
, pointer
);
245 SCM_DEFINE (scm_bytevector_to_pointer
, "bytevector->pointer", 1, 1, 0,
246 (SCM bv
, SCM offset
),
247 "Return a pointer pointer aliasing the memory pointed to by\n"
248 "@var{bv} or @var{offset} bytes after @var{bv} when @var{offset}\n"
250 #define FUNC_NAME s_scm_bytevector_to_pointer
256 SCM_VALIDATE_BYTEVECTOR (1, bv
);
257 ptr
= SCM_BYTEVECTOR_CONTENTS (bv
);
259 if (SCM_UNBNDP (offset
))
262 boffset
= scm_to_unsigned_integer (offset
, 0,
263 SCM_BYTEVECTOR_LENGTH (bv
) - 1);
265 ret
= scm_from_pointer (ptr
+ boffset
, NULL
);
266 register_weak_reference (ret
, bv
);
271 SCM_DEFINE (scm_set_pointer_finalizer_x
, "set-pointer-finalizer!", 2, 0, 0,
272 (SCM pointer
, SCM finalizer
),
273 "Arrange for the C procedure wrapped by @var{finalizer} to be\n"
274 "called on the pointer wrapped by @var{pointer} when @var{pointer}\n"
275 "becomes unreachable. Note: the C procedure should not call into\n"
276 "Scheme. If you need a Scheme finalizer, use guardians.")
277 #define FUNC_NAME s_scm_set_pointer_finalizer_x
280 GC_finalization_proc prev_finalizer
;
281 GC_PTR prev_finalizer_data
;
283 SCM_VALIDATE_POINTER (1, pointer
);
284 SCM_VALIDATE_POINTER (2, finalizer
);
286 c_finalizer
= SCM_POINTER_VALUE (finalizer
);
288 SCM_SET_CELL_WORD_0 (pointer
, SCM_CELL_WORD_0 (pointer
) | (1 << 16UL));
290 GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (pointer
),
291 pointer_finalizer_trampoline
,
294 &prev_finalizer_data
);
296 return SCM_UNSPECIFIED
;
301 scm_i_pointer_print (SCM pointer
, SCM port
, scm_print_state
*pstate
)
303 scm_puts ("#<pointer 0x", port
);
304 scm_uintprint (scm_to_uintptr (scm_pointer_address (pointer
)), 16, port
);
305 scm_putc ('>', port
);
309 /* Non-primitive helpers functions. These procedures could be
310 implemented in terms of the primitives above but would be inefficient
311 (heap allocation overhead, Scheme/C round trips, etc.) */
313 SCM_DEFINE (scm_dereference_pointer
, "dereference-pointer", 1, 0, 0,
315 "Assuming @var{pointer} points to a memory region that\n"
316 "holds a pointer, return this pointer.")
317 #define FUNC_NAME s_scm_dereference_pointer
319 SCM_VALIDATE_POINTER (1, pointer
);
321 return scm_from_pointer (* (void **) SCM_POINTER_VALUE (pointer
), NULL
);
325 SCM_DEFINE (scm_string_to_pointer
, "string->pointer", 1, 0, 0,
327 "Return a foreign pointer to a nul-terminated copy of\n"
328 "@var{string} in the current locale encoding. The C\n"
329 "string is freed when the returned foreign pointer\n"
330 "becomes unreachable.\n\n"
331 "This is the Scheme equivalent of @code{scm_to_locale_string}.")
332 #define FUNC_NAME s_scm_string_to_pointer
334 SCM_VALIDATE_STRING (1, string
);
336 /* XXX: Finalizers slow down libgc; they could be avoided if
337 `scm_to_string' & co. were able to use libgc-allocated memory. */
339 return scm_from_pointer (scm_to_locale_string (string
), free
);
343 SCM_DEFINE (scm_pointer_to_string
, "pointer->string", 1, 0, 0,
345 "Return the string representing the C nul-terminated string\n"
346 "pointed to by @var{pointer}. The C string is assumed to be\n"
347 "in the current locale encoding.\n\n"
348 "This is the Scheme equivalent of @code{scm_from_locale_string}.")
349 #define FUNC_NAME s_scm_pointer_to_string
351 SCM_VALIDATE_POINTER (1, pointer
);
353 return scm_from_locale_string (SCM_POINTER_VALUE (pointer
));
359 SCM_DEFINE (scm_alignof
, "alignof", 1, 0, 0, (SCM type
),
360 "Return the alignment of @var{type}, in bytes.\n\n"
361 "@var{type} should be a valid C type, like @code{int}.\n"
362 "Alternately @var{type} may be the symbol @code{*}, in which\n"
363 "case the alignment of a pointer is returned. @var{type} may\n"
364 "also be a list of types, in which case the alignment of a\n"
365 "@code{struct} with ABI-conventional packing is returned.")
366 #define FUNC_NAME s_scm_alignof
368 if (SCM_I_INUMP (type
))
370 switch (SCM_I_INUM (type
))
372 case SCM_FOREIGN_TYPE_FLOAT
:
373 return scm_from_size_t (alignof (float));
374 case SCM_FOREIGN_TYPE_DOUBLE
:
375 return scm_from_size_t (alignof (double));
376 case SCM_FOREIGN_TYPE_UINT8
:
377 return scm_from_size_t (alignof (scm_t_uint8
));
378 case SCM_FOREIGN_TYPE_INT8
:
379 return scm_from_size_t (alignof (scm_t_int8
));
380 case SCM_FOREIGN_TYPE_UINT16
:
381 return scm_from_size_t (alignof (scm_t_uint16
));
382 case SCM_FOREIGN_TYPE_INT16
:
383 return scm_from_size_t (alignof (scm_t_int16
));
384 case SCM_FOREIGN_TYPE_UINT32
:
385 return scm_from_size_t (alignof (scm_t_uint32
));
386 case SCM_FOREIGN_TYPE_INT32
:
387 return scm_from_size_t (alignof (scm_t_int32
));
388 case SCM_FOREIGN_TYPE_UINT64
:
389 return scm_from_size_t (alignof (scm_t_uint64
));
390 case SCM_FOREIGN_TYPE_INT64
:
391 return scm_from_size_t (alignof (scm_t_int64
));
393 scm_wrong_type_arg (FUNC_NAME
, 1, type
);
396 else if (scm_is_eq (type
, sym_asterisk
))
398 return scm_from_size_t (alignof (void*));
399 else if (scm_is_pair (type
))
401 return scm_alignof (scm_car (type
));
403 scm_wrong_type_arg (FUNC_NAME
, 1, type
);
407 SCM_DEFINE (scm_sizeof
, "sizeof", 1, 0, 0, (SCM type
),
408 "Return the size of @var{type}, in bytes.\n\n"
409 "@var{type} should be a valid C type, like @code{int}.\n"
410 "Alternately @var{type} may be the symbol @code{*}, in which\n"
411 "case the size of a pointer is returned. @var{type} may also\n"
412 "be a list of types, in which case the size of a @code{struct}\n"
413 "with ABI-conventional packing is returned.")
414 #define FUNC_NAME s_scm_sizeof
416 if (SCM_I_INUMP (type
))
418 switch (SCM_I_INUM (type
))
420 case SCM_FOREIGN_TYPE_FLOAT
:
421 return scm_from_size_t (sizeof (float));
422 case SCM_FOREIGN_TYPE_DOUBLE
:
423 return scm_from_size_t (sizeof (double));
424 case SCM_FOREIGN_TYPE_UINT8
:
425 return scm_from_size_t (sizeof (scm_t_uint8
));
426 case SCM_FOREIGN_TYPE_INT8
:
427 return scm_from_size_t (sizeof (scm_t_int8
));
428 case SCM_FOREIGN_TYPE_UINT16
:
429 return scm_from_size_t (sizeof (scm_t_uint16
));
430 case SCM_FOREIGN_TYPE_INT16
:
431 return scm_from_size_t (sizeof (scm_t_int16
));
432 case SCM_FOREIGN_TYPE_UINT32
:
433 return scm_from_size_t (sizeof (scm_t_uint32
));
434 case SCM_FOREIGN_TYPE_INT32
:
435 return scm_from_size_t (sizeof (scm_t_int32
));
436 case SCM_FOREIGN_TYPE_UINT64
:
437 return scm_from_size_t (sizeof (scm_t_uint64
));
438 case SCM_FOREIGN_TYPE_INT64
:
439 return scm_from_size_t (sizeof (scm_t_int64
));
441 scm_wrong_type_arg (FUNC_NAME
, 1, type
);
444 else if (scm_is_eq (type
, sym_asterisk
))
446 return scm_from_size_t (sizeof (void*));
447 else if (scm_is_pair (type
))
451 while (scm_is_pair (type
))
453 off
= ROUND_UP (off
, scm_to_size_t (scm_alignof (scm_car (type
))));
454 off
+= scm_to_size_t (scm_sizeof (scm_car (type
)));
455 type
= scm_cdr (type
);
457 return scm_from_size_t (off
);
460 scm_wrong_type_arg (FUNC_NAME
, 1, type
);
465 /* return 1 on success, 0 on failure */
467 parse_ffi_type (SCM type
, int return_p
, long *n_structs
, long *n_struct_elts
)
469 if (SCM_I_INUMP (type
))
471 if ((SCM_I_INUM (type
) < 0 )
472 || (SCM_I_INUM (type
) > SCM_FOREIGN_TYPE_LAST
))
474 else if (SCM_I_INUM (type
) == SCM_FOREIGN_TYPE_VOID
&& !return_p
)
479 else if (scm_is_eq (type
, sym_asterisk
))
486 len
= scm_ilength (type
);
491 if (!parse_ffi_type (scm_car (type
), 0, n_structs
, n_struct_elts
))
494 type
= scm_cdr (type
);
502 fill_ffi_type (SCM type
, ffi_type
*ftype
, ffi_type
***type_ptrs
,
505 if (SCM_I_INUMP (type
))
507 switch (SCM_I_INUM (type
))
509 case SCM_FOREIGN_TYPE_FLOAT
:
510 *ftype
= ffi_type_float
;
512 case SCM_FOREIGN_TYPE_DOUBLE
:
513 *ftype
= ffi_type_double
;
515 case SCM_FOREIGN_TYPE_UINT8
:
516 *ftype
= ffi_type_uint8
;
518 case SCM_FOREIGN_TYPE_INT8
:
519 *ftype
= ffi_type_sint8
;
521 case SCM_FOREIGN_TYPE_UINT16
:
522 *ftype
= ffi_type_uint16
;
524 case SCM_FOREIGN_TYPE_INT16
:
525 *ftype
= ffi_type_sint16
;
527 case SCM_FOREIGN_TYPE_UINT32
:
528 *ftype
= ffi_type_uint32
;
530 case SCM_FOREIGN_TYPE_INT32
:
531 *ftype
= ffi_type_sint32
;
533 case SCM_FOREIGN_TYPE_UINT64
:
534 *ftype
= ffi_type_uint64
;
536 case SCM_FOREIGN_TYPE_INT64
:
537 *ftype
= ffi_type_sint64
;
539 case SCM_FOREIGN_TYPE_VOID
:
540 *ftype
= ffi_type_void
;
543 scm_wrong_type_arg_msg ("pointer->procedure", 0, type
,
547 else if (scm_is_eq (type
, sym_asterisk
))
550 *ftype
= ffi_type_pointer
;
557 len
= scm_ilength (type
);
560 ftype
->alignment
= 0;
561 ftype
->type
= FFI_TYPE_STRUCT
;
562 ftype
->elements
= *type_ptrs
;
563 *type_ptrs
+= len
+ 1;
565 for (i
= 0; i
< len
; i
++)
567 ftype
->elements
[i
] = *types
;
569 fill_ffi_type (scm_car (type
), ftype
->elements
[i
],
571 type
= scm_cdr (type
);
573 ftype
->elements
[i
] = NULL
;
577 /* Return a "cif" (call interface) for the given RETURN_TYPE and
580 make_cif (SCM return_type
, SCM arg_types
, const char *caller
)
581 #define FUNC_NAME caller
584 long i
, nargs
, n_structs
, n_struct_elts
;
588 ffi_type
**type_ptrs
;
591 nargs
= scm_ilength (arg_types
);
592 SCM_ASSERT (nargs
>= 0, arg_types
, 3, FUNC_NAME
);
593 /* fixme: assert nargs < 1<<32 */
594 n_structs
= n_struct_elts
= 0;
596 /* For want of talloc, we're going to have to do this in two passes: first we
597 figure out how much memory is needed for all types, then we allocate the
598 cif and the types all in one block. */
599 if (!parse_ffi_type (return_type
, 1, &n_structs
, &n_struct_elts
))
600 scm_wrong_type_arg (FUNC_NAME
, 1, return_type
);
601 for (walk
= arg_types
; scm_is_pair (walk
); walk
= scm_cdr (walk
))
602 if (!parse_ffi_type (scm_car (walk
), 0, &n_structs
, &n_struct_elts
))
603 scm_wrong_type_arg (FUNC_NAME
, 3, scm_car (walk
));
605 /* the memory: with space for the cif itself */
606 cif_len
= sizeof (ffi_cif
);
608 /* then ffi_type pointers: one for each arg, one for each struct
609 element, and one for each struct (for null-termination) */
610 cif_len
= (ROUND_UP (cif_len
, alignof(void*))
611 + (nargs
+ n_structs
+ n_struct_elts
)*sizeof(void*));
613 /* then the ffi_type structs themselves, one per arg and struct element, and
614 one for the return val */
615 cif_len
= (ROUND_UP (cif_len
, alignof(ffi_type
))
616 + (nargs
+ n_struct_elts
+ 1)*sizeof(ffi_type
));
618 mem
= scm_gc_malloc_pointerless (cif_len
, "foreign");
619 /* ensure all the memory is initialized, even the holes */
620 memset (mem
, 0, cif_len
);
621 cif
= (ffi_cif
*) mem
;
623 /* reuse cif_len to walk through the mem */
624 cif_len
= ROUND_UP (sizeof (ffi_cif
), alignof(void*));
625 type_ptrs
= (ffi_type
**)(mem
+ cif_len
);
626 cif_len
= ROUND_UP (cif_len
627 + (nargs
+ n_structs
+ n_struct_elts
)*sizeof(void*),
629 types
= (ffi_type
*)(mem
+ cif_len
);
631 /* whew. now knit the pointers together. */
632 cif
->rtype
= types
++;
633 fill_ffi_type (return_type
, cif
->rtype
, &type_ptrs
, &types
);
634 cif
->arg_types
= type_ptrs
;
636 for (walk
= arg_types
, i
= 0; scm_is_pair (walk
); walk
= scm_cdr (walk
), i
++)
638 cif
->arg_types
[i
] = types
++;
639 fill_ffi_type (scm_car (walk
), cif
->arg_types
[i
], &type_ptrs
, &types
);
642 /* round out the cif, and we're done. */
643 cif
->abi
= FFI_DEFAULT_ABI
;
648 if (FFI_OK
!= ffi_prep_cif (cif
, FFI_DEFAULT_ABI
, cif
->nargs
, cif
->rtype
,
650 SCM_MISC_ERROR ("ffi_prep_cif failed", SCM_EOL
);
656 SCM_DEFINE (scm_pointer_to_procedure
, "pointer->procedure", 3, 0, 0,
657 (SCM return_type
, SCM func_ptr
, SCM arg_types
),
658 "Make a foreign function.\n\n"
659 "Given the foreign void pointer @var{func_ptr}, its argument and\n"
660 "return types @var{arg_types} and @var{return_type}, return a\n"
661 "procedure that will pass arguments to the foreign function\n"
662 "and return appropriate values.\n\n"
663 "@var{arg_types} should be a list of foreign types.\n"
664 "@code{return_type} should be a foreign type.")
665 #define FUNC_NAME s_scm_pointer_to_procedure
669 SCM_VALIDATE_POINTER (2, func_ptr
);
671 cif
= make_cif (return_type
, arg_types
, FUNC_NAME
);
673 return cif_to_procedure (scm_from_pointer (cif
, NULL
), func_ptr
);
679 /* Pre-generate trampolines for less than 10 arguments. */
681 #ifdef WORDS_BIGENDIAN
682 #define OBJCODE_HEADER 0, 0, 0, 8, 0, 0, 0, 40
683 #define META_HEADER 0, 0, 0, 32, 0, 0, 0, 0
685 #define OBJCODE_HEADER 8, 0, 0, 0, 40, 0, 0, 0
686 #define META_HEADER 32, 0, 0, 0, 0, 0, 0, 0
691 /* 0 */ scm_op_assert_nargs_ee, 0, nreq, /* assert number of args */ \
692 /* 3 */ scm_op_object_ref, 0, /* push the pair with the cif and the function pointer */ \
693 /* 5 */ scm_op_foreign_call, nreq, /* and call (will return value as well) */ \
694 /* 7 */ scm_op_nop, \
695 /* 8 */ META (3, 7, nreq)
697 #define META(start, end, nreq) \
699 /* 0 */ scm_op_make_eol, /* bindings */ \
700 /* 1 */ scm_op_make_eol, /* sources */ \
701 /* 2 */ scm_op_make_int8, start, scm_op_make_int8, end, /* arity: from ip N to ip N */ \
702 /* 6 */ scm_op_make_int8, nreq, /* the arity is N required args */ \
703 /* 8 */ scm_op_list, 0, 3, /* make a list of those 3 vals */ \
704 /* 11 */ scm_op_list, 0, 1, /* and the arities will be a list of that one list */ \
705 /* 14 */ scm_op_load_symbol, 0, 0, 4, 'n', 'a', 'm', 'e', /* `name' */ \
706 /* 22 */ scm_op_object_ref, 1, /* the name from the object table */ \
707 /* 24 */ scm_op_cons, /* make a pair for the properties */ \
708 /* 25 */ scm_op_list, 0, 4, /* pack bindings, sources, and arities into list */ \
709 /* 28 */ scm_op_return, /* and return */ \
710 /* 29 */ scm_op_nop, scm_op_nop, scm_op_nop \
715 scm_t_uint64 dummy
; /* ensure 8-byte alignment; perhaps there's a better way */
716 const scm_t_uint8 bytes
[10 * (sizeof (struct scm_objcode
) + 8
717 + sizeof (struct scm_objcode
) + 32)];
721 CODE (0), CODE (1), CODE (2), CODE (3), CODE (4),
722 CODE (5), CODE (6), CODE (7), CODE (8), CODE (9)
728 #undef OBJCODE_HEADER
732 (defun generate-objcode-cells (n)
733 "Generate objcode cells for up to N arguments"
738 (format " { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + %d) },\n"
739 (* (+ 4 4 8 4 4 32) i)))
740 (insert " { SCM_BOOL_F, SCM_PACK (0) },\n")
743 #define STATIC_OBJCODE_TAG \
744 SCM_PACK (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_STATIC, 0))
748 scm_t_uint64 dummy
; /* alignment */
749 scm_t_cell cells
[10 * 2]; /* 10 double cells */
752 /* C-u 1 0 M-x generate-objcode-cells RET */
754 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 0) },
755 { SCM_BOOL_F
, SCM_PACK (0) },
756 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 56) },
757 { SCM_BOOL_F
, SCM_PACK (0) },
758 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 112) },
759 { SCM_BOOL_F
, SCM_PACK (0) },
760 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 168) },
761 { SCM_BOOL_F
, SCM_PACK (0) },
762 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 224) },
763 { SCM_BOOL_F
, SCM_PACK (0) },
764 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 280) },
765 { SCM_BOOL_F
, SCM_PACK (0) },
766 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 336) },
767 { SCM_BOOL_F
, SCM_PACK (0) },
768 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 392) },
769 { SCM_BOOL_F
, SCM_PACK (0) },
770 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 448) },
771 { SCM_BOOL_F
, SCM_PACK (0) },
772 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 504) },
773 { SCM_BOOL_F
, SCM_PACK (0) }
777 static const SCM objcode_trampolines
[10] = {
778 SCM_PACK (objcode_cells
.cells
+0),
779 SCM_PACK (objcode_cells
.cells
+2),
780 SCM_PACK (objcode_cells
.cells
+4),
781 SCM_PACK (objcode_cells
.cells
+6),
782 SCM_PACK (objcode_cells
.cells
+8),
783 SCM_PACK (objcode_cells
.cells
+10),
784 SCM_PACK (objcode_cells
.cells
+12),
785 SCM_PACK (objcode_cells
.cells
+14),
786 SCM_PACK (objcode_cells
.cells
+16),
787 SCM_PACK (objcode_cells
.cells
+18),
791 cif_to_procedure (SCM cif
, SCM func_ptr
)
795 SCM objcode
, table
, ret
;
797 c_cif
= (ffi_cif
*) SCM_POINTER_VALUE (cif
);
798 nargs
= c_cif
->nargs
;
801 objcode
= objcode_trampolines
[nargs
];
803 scm_misc_error ("make-foreign-function", "args >= 10 currently unimplemented",
806 table
= scm_c_make_vector (2, SCM_UNDEFINED
);
807 SCM_SIMPLE_VECTOR_SET (table
, 0, scm_cons (cif
, func_ptr
));
808 SCM_SIMPLE_VECTOR_SET (table
, 1, SCM_BOOL_F
); /* name */
809 ret
= scm_make_program (objcode
, table
, SCM_BOOL_F
);
814 /* Set *LOC to the foreign representation of X with TYPE. */
816 unpack (const ffi_type
*type
, void *loc
, SCM x
)
821 *(float *) loc
= scm_to_double (x
);
823 case FFI_TYPE_DOUBLE
:
824 *(double *) loc
= scm_to_double (x
);
827 *(scm_t_uint8
*) loc
= scm_to_uint8 (x
);
830 *(scm_t_int8
*) loc
= scm_to_int8 (x
);
832 case FFI_TYPE_UINT16
:
833 *(scm_t_uint16
*) loc
= scm_to_uint16 (x
);
835 case FFI_TYPE_SINT16
:
836 *(scm_t_int16
*) loc
= scm_to_int16 (x
);
838 case FFI_TYPE_UINT32
:
839 *(scm_t_uint32
*) loc
= scm_to_uint32 (x
);
841 case FFI_TYPE_SINT32
:
842 *(scm_t_int32
*) loc
= scm_to_int32 (x
);
844 case FFI_TYPE_UINT64
:
845 *(scm_t_uint64
*) loc
= scm_to_uint64 (x
);
847 case FFI_TYPE_SINT64
:
848 *(scm_t_int64
*) loc
= scm_to_int64 (x
);
850 case FFI_TYPE_STRUCT
:
851 memcpy (loc
, SCM_POINTER_VALUE (x
), type
->size
);
853 case FFI_TYPE_POINTER
:
854 *(void **) loc
= SCM_POINTER_VALUE (x
);
861 /* Return a Scheme representation of the foreign value at LOC of type TYPE. */
863 pack (const ffi_type
* type
, const void *loc
)
868 return SCM_UNSPECIFIED
;
870 return scm_from_double (*(float *) loc
);
871 case FFI_TYPE_DOUBLE
:
872 return scm_from_double (*(double *) loc
);
874 return scm_from_uint8 (*(scm_t_uint8
*) loc
);
876 return scm_from_int8 (*(scm_t_int8
*) loc
);
877 case FFI_TYPE_UINT16
:
878 return scm_from_uint16 (*(scm_t_uint16
*) loc
);
879 case FFI_TYPE_SINT16
:
880 return scm_from_int16 (*(scm_t_int16
*) loc
);
881 case FFI_TYPE_UINT32
:
882 return scm_from_uint32 (*(scm_t_uint32
*) loc
);
883 case FFI_TYPE_SINT32
:
884 return scm_from_int32 (*(scm_t_int32
*) loc
);
885 case FFI_TYPE_UINT64
:
886 return scm_from_uint64 (*(scm_t_uint64
*) loc
);
887 case FFI_TYPE_SINT64
:
888 return scm_from_int64 (*(scm_t_int64
*) loc
);
889 case FFI_TYPE_STRUCT
:
891 void *mem
= scm_gc_malloc_pointerless (type
->size
, "foreign");
892 memcpy (mem
, loc
, type
->size
);
893 return scm_from_pointer (mem
, NULL
);
895 case FFI_TYPE_POINTER
:
896 return scm_from_pointer (*(void **) loc
, NULL
);
904 scm_i_foreign_call (SCM foreign
, const SCM
*argv
)
906 /* FOREIGN is the pair that cif_to_procedure set as the 0th element of the
917 cif
= SCM_POINTER_VALUE (SCM_CAR (foreign
));
918 func
= SCM_POINTER_VALUE (SCM_CDR (foreign
));
920 /* Argument pointers. */
921 args
= alloca (sizeof (void *) * cif
->nargs
);
923 /* Compute the worst-case amount of memory needed to store all the argument
924 values. Note: as of libffi 3.0.9 `cif->bytes' is undocumented and is zero,
925 so it can't be used for that purpose. */
926 for (i
= 0, arg_size
= 0; i
< cif
->nargs
; i
++)
927 arg_size
+= cif
->arg_types
[i
]->size
+ cif
->arg_types
[i
]->alignment
- 1;
929 /* Space for argument values, followed by return value. */
930 data
= alloca (arg_size
+ cif
->rtype
->size
931 + max (sizeof (void *), cif
->rtype
->alignment
));
933 /* Unpack ARGV to native values, setting ARGV pointers. */
936 off
= (scm_t_uint8
*) args
[i
] - data
+ cif
->arg_types
[i
]->size
,
939 /* Suitably align the storage area for argument I. */
940 args
[i
] = (void *) ROUND_UP ((scm_t_uintptr
) data
+ off
,
941 cif
->arg_types
[i
]->alignment
);
942 assert ((scm_t_uintptr
) args
[i
] % cif
->arg_types
[i
]->alignment
== 0);
943 unpack (cif
->arg_types
[i
], args
[i
], argv
[i
]);
946 /* Prepare space for the return value. On some platforms, such as
947 `armv5tel-*-linux-gnueabi', the return value has to be at least
948 word-aligned, even if its type doesn't have any alignment requirement as is
949 the case with `char'. */
950 rvalue
= (void *) ROUND_UP ((scm_t_uintptr
) data
+ off
,
951 max (sizeof (void *), cif
->rtype
->alignment
));
954 ffi_call (cif
, func
, rvalue
, args
);
956 return pack (cif
->rtype
, rvalue
);
960 /* Function pointers aka. "callbacks" or "closures". */
964 /* Trampoline to invoke a libffi closure that wraps a Scheme
967 invoke_closure (ffi_cif
*cif
, void *ret
, void **args
, void *data
)
970 SCM proc
, *argv
, result
;
972 proc
= PTR2SCM (data
);
974 argv
= alloca (cif
->nargs
* sizeof (*argv
));
976 /* Pack ARGS to SCM values, setting ARGV pointers. */
977 for (i
= 0; i
< cif
->nargs
; i
++)
978 argv
[i
] = pack (cif
->arg_types
[i
], args
[i
]);
980 result
= scm_call_n (proc
, argv
, cif
->nargs
);
982 unpack (cif
->rtype
, ret
, result
);
985 SCM_DEFINE (scm_procedure_to_pointer
, "procedure->pointer", 3, 0, 0,
986 (SCM return_type
, SCM proc
, SCM arg_types
),
987 "Return a pointer to a C function of type @var{return-type}\n"
988 "taking arguments of types @var{arg-types} (a list) and\n"
989 "behaving as a proxy to procedure @var{proc}. Thus\n"
990 "@var{proc}'s arity, supported argument types, and return\n"
991 "type should match @var{return-type} and @var{arg-types}.\n")
992 #define FUNC_NAME s_scm_procedure_to_pointer
997 void *closure
, *executable
;
999 cif
= make_cif (return_type
, arg_types
, FUNC_NAME
);
1001 closure
= ffi_closure_alloc (sizeof (ffi_closure
), &executable
);
1002 err
= ffi_prep_closure_loc ((ffi_closure
*) closure
, cif
,
1003 invoke_closure
, SCM2PTR (proc
),
1007 ffi_closure_free (closure
);
1008 SCM_MISC_ERROR ("`ffi_prep_closure_loc' failed", SCM_EOL
);
1011 if (closure
== executable
)
1012 pointer
= scm_from_pointer (executable
, ffi_closure_free
);
1015 /* CLOSURE needs to be freed eventually. However, since
1016 `GC_all_interior_pointers' is disabled, we can't just register
1017 a finalizer for CLOSURE. Instead, we create a pointer object
1018 for CLOSURE, with a finalizer, and register it as a weak
1019 reference of POINTER. */
1022 pointer
= scm_from_pointer (executable
, NULL
);
1023 friend = scm_from_pointer (closure
, ffi_closure_free
);
1025 register_weak_reference (pointer
, friend);
1032 #endif /* FFI_CLOSURES */
1037 scm_init_foreign (void)
1039 #ifndef SCM_MAGIC_SNARFER
1040 #include "libguile/foreign.x"
1042 scm_define (sym_void
, scm_from_uint8 (SCM_FOREIGN_TYPE_VOID
));
1043 scm_define (sym_float
, scm_from_uint8 (SCM_FOREIGN_TYPE_FLOAT
));
1044 scm_define (sym_double
, scm_from_uint8 (SCM_FOREIGN_TYPE_DOUBLE
));
1045 scm_define (sym_uint8
, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT8
));
1046 scm_define (sym_int8
, scm_from_uint8 (SCM_FOREIGN_TYPE_INT8
));
1047 scm_define (sym_uint16
, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT16
));
1048 scm_define (sym_int16
, scm_from_uint8 (SCM_FOREIGN_TYPE_INT16
));
1049 scm_define (sym_uint32
, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32
));
1050 scm_define (sym_int32
, scm_from_uint8 (SCM_FOREIGN_TYPE_INT32
));
1051 scm_define (sym_uint64
, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64
));
1052 scm_define (sym_int64
, scm_from_uint8 (SCM_FOREIGN_TYPE_INT64
));
1054 scm_define (sym_short
,
1055 #if SIZEOF_SHORT == 8
1056 scm_from_uint8 (SCM_FOREIGN_TYPE_INT64
)
1057 #elif SIZEOF_SHORT == 4
1058 scm_from_uint8 (SCM_FOREIGN_TYPE_INT32
)
1059 #elif SIZEOF_SHORT == 2
1060 scm_from_uint8 (SCM_FOREIGN_TYPE_INT16
)
1062 # error unsupported sizeof (short)
1066 scm_define (sym_unsigned_short
,
1067 #if SIZEOF_SHORT == 8
1068 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64
)
1069 #elif SIZEOF_SHORT == 4
1070 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32
)
1071 #elif SIZEOF_SHORT == 2
1072 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT16
)
1074 # error unsupported sizeof (short)
1078 scm_define (sym_int
,
1080 scm_from_uint8 (SCM_FOREIGN_TYPE_INT64
)
1081 #elif SIZEOF_INT == 4
1082 scm_from_uint8 (SCM_FOREIGN_TYPE_INT32
)
1084 # error unsupported sizeof (int)
1088 scm_define (sym_unsigned_int
,
1089 #if SIZEOF_UNSIGNED_INT == 8
1090 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64
)
1091 #elif SIZEOF_UNSIGNED_INT == 4
1092 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32
)
1094 # error unsupported sizeof (unsigned int)
1098 scm_define (sym_long
,
1099 #if SIZEOF_LONG == 8
1100 scm_from_uint8 (SCM_FOREIGN_TYPE_INT64
)
1101 #elif SIZEOF_LONG == 4
1102 scm_from_uint8 (SCM_FOREIGN_TYPE_INT32
)
1104 # error unsupported sizeof (long)
1108 scm_define (sym_unsigned_long
,
1109 #if SIZEOF_UNSIGNED_LONG == 8
1110 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64
)
1111 #elif SIZEOF_UNSIGNED_LONG == 4
1112 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32
)
1114 # error unsupported sizeof (unsigned long)
1118 scm_define (sym_size_t
,
1119 #if SIZEOF_SIZE_T == 8
1120 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64
)
1121 #elif SIZEOF_SIZE_T == 4
1122 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32
)
1124 # error unsupported sizeof (size_t)
1128 null_pointer
= scm_cell (scm_tc7_pointer
, 0);
1129 scm_define (sym_null
, null_pointer
);
1133 scm_register_foreign (void)
1135 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1137 (scm_t_extension_init_func
)scm_init_foreign
,
1139 pointer_weak_refs
= scm_make_weak_key_hash_table (SCM_UNDEFINED
);