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
27 #include "libguile/_scm.h"
28 #include "libguile/bytevectors.h"
29 #include "libguile/instructions.h"
30 #include "libguile/foreign.h"
34 SCM_SYMBOL (sym_void
, "void");
35 SCM_SYMBOL (sym_float
, "float");
36 SCM_SYMBOL (sym_double
, "double");
37 SCM_SYMBOL (sym_uint8
, "uint8");
38 SCM_SYMBOL (sym_int8
, "int8");
39 SCM_SYMBOL (sym_uint16
, "uint16");
40 SCM_SYMBOL (sym_int16
, "int16");
41 SCM_SYMBOL (sym_uint32
, "uint32");
42 SCM_SYMBOL (sym_int32
, "int32");
43 SCM_SYMBOL (sym_uint64
, "uint64");
44 SCM_SYMBOL (sym_int64
, "int64");
45 SCM_SYMBOL (sym_int
, "int");
46 SCM_SYMBOL (sym_long
, "long");
47 SCM_SYMBOL (sym_unsigned_int
, "unsigned-int");
48 SCM_SYMBOL (sym_unsigned_long
, "unsigned-long");
49 SCM_SYMBOL (sym_size_t
, "size_t");
51 /* that's for pointers, you know. */
52 SCM_SYMBOL (sym_asterisk
, "*");
54 SCM_SYMBOL (sym_null
, "%null-pointer");
55 SCM_SYMBOL (sym_null_pointer_error
, "null-pointer-error");
57 /* The cell representing the null pointer. */
58 static SCM null_pointer
;
60 /* Raise a null pointer dereference error. */
62 null_pointer_error (const char *func_name
)
64 scm_error (sym_null_pointer_error
, func_name
,
65 "null pointer dereference", SCM_EOL
, SCM_EOL
);
69 static SCM
cif_to_procedure (SCM cif
, SCM func_ptr
);
72 static SCM foreign_weak_refs
= SCM_BOOL_F
;
75 register_weak_reference (SCM from
, SCM to
)
77 scm_hashq_set_x (foreign_weak_refs
, from
, to
);
81 foreign_finalizer_trampoline (GC_PTR ptr
, GC_PTR data
)
83 scm_t_foreign_finalizer finalizer
= data
;
84 finalizer (SCM_FOREIGN_POINTER (PTR2SCM (ptr
), void));
88 scm_take_foreign_pointer (scm_t_foreign_type type
, void *ptr
, size_t len
,
89 scm_t_foreign_finalizer finalizer
)
94 word0
= (scm_t_bits
)(scm_tc7_foreign
| (type
<<8)
95 | (finalizer
? (1<<16) : 0) | (len
<<17));
96 if (SCM_UNLIKELY ((word0
>> 17) != len
))
97 scm_out_of_range ("scm_take_foreign_pointer", scm_from_size_t (len
));
99 ret
= scm_cell (word0
, (scm_t_bits
) ptr
);
102 /* Register a finalizer for the newly created instance. */
103 GC_finalization_proc prev_finalizer
;
104 GC_PTR prev_finalizer_data
;
105 GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (ret
),
106 foreign_finalizer_trampoline
,
109 &prev_finalizer_data
);
115 SCM_DEFINE (scm_foreign_ref
, "foreign-ref", 1, 0, 0,
117 "Reference the foreign value pointed to by @var{foreign}.\n\n"
118 "The value will be referenced according to its type.")
119 #define FUNC_NAME s_scm_foreign_ref
121 scm_t_foreign_type ftype
;
124 SCM_VALIDATE_FOREIGN (1, foreign
);
125 ptr
= SCM_FOREIGN_POINTER (foreign
, scm_t_uint8
);
126 ftype
= SCM_FOREIGN_TYPE (foreign
);
128 /* FIXME: is there a window in which we can see ptr but not foreign? */
129 /* FIXME: accessing unaligned pointers */
132 case SCM_FOREIGN_TYPE_VOID
:
133 return scm_from_ulong ((unsigned long)ptr
);
134 case SCM_FOREIGN_TYPE_FLOAT
:
135 return scm_from_double (*(float*)ptr
);
136 case SCM_FOREIGN_TYPE_DOUBLE
:
137 return scm_from_double (*(double*)ptr
);
138 case SCM_FOREIGN_TYPE_UINT8
:
139 return scm_from_uint8 (*(scm_t_uint8
*)ptr
);
140 case SCM_FOREIGN_TYPE_INT8
:
141 return scm_from_int8 (*(scm_t_int8
*)ptr
);
142 case SCM_FOREIGN_TYPE_UINT16
:
143 return scm_from_uint16 (*(scm_t_uint16
*)ptr
);
144 case SCM_FOREIGN_TYPE_INT16
:
145 return scm_from_int16 (*(scm_t_int16
*)ptr
);
146 case SCM_FOREIGN_TYPE_UINT32
:
147 return scm_from_uint32 (*(scm_t_uint32
*)ptr
);
148 case SCM_FOREIGN_TYPE_INT32
:
149 return scm_from_int32 (*(scm_t_int32
*)ptr
);
150 case SCM_FOREIGN_TYPE_UINT64
:
151 return scm_from_uint64 (*(scm_t_uint64
*)ptr
);
152 case SCM_FOREIGN_TYPE_INT64
:
153 return scm_from_int64 (*(scm_t_int64
*)ptr
);
155 scm_wrong_type_arg_msg (FUNC_NAME
, 1, foreign
, "foreign");
160 SCM_DEFINE (scm_foreign_set_x
, "foreign-set!", 2, 0, 0,
161 (SCM foreign
, SCM val
),
162 "Set the foreign value pointed to by @var{foreign}.\n\n"
163 "The value will be set according to its type.")
164 #define FUNC_NAME s_scm_foreign_set_x
166 scm_t_foreign_type ftype
;
169 SCM_VALIDATE_FOREIGN (1, foreign
);
171 if (SCM_UNLIKELY (scm_is_eq (foreign
, null_pointer
)))
172 /* Attempting to modify the pointer value of NULL_POINTER (which is
173 read-only anyway), so raise an error. */
174 null_pointer_error (FUNC_NAME
);
176 ptr
= SCM_FOREIGN_POINTER (foreign
, scm_t_uint8
);
177 ftype
= SCM_FOREIGN_TYPE (foreign
);
179 /* FIXME: is there a window in which we can see ptr but not foreign? */
180 /* FIXME: unaligned access */
183 case SCM_FOREIGN_TYPE_VOID
:
184 SCM_SET_CELL_WORD_1 (foreign
, scm_to_ulong (val
));
186 case SCM_FOREIGN_TYPE_FLOAT
:
187 *(float*)ptr
= scm_to_double (val
);
189 case SCM_FOREIGN_TYPE_DOUBLE
:
190 *(double*)ptr
= scm_to_double (val
);
192 case SCM_FOREIGN_TYPE_UINT8
:
193 *(scm_t_uint8
*)ptr
= scm_to_uint8 (val
);
195 case SCM_FOREIGN_TYPE_INT8
:
196 *(scm_t_int8
*)ptr
= scm_to_int8 (val
);
198 case SCM_FOREIGN_TYPE_UINT16
:
199 *(scm_t_uint16
*)ptr
= scm_to_uint16 (val
);
201 case SCM_FOREIGN_TYPE_INT16
:
202 *(scm_t_int16
*)ptr
= scm_to_int16 (val
);
204 case SCM_FOREIGN_TYPE_UINT32
:
205 *(scm_t_uint32
*)ptr
= scm_to_uint32 (val
);
207 case SCM_FOREIGN_TYPE_INT32
:
208 *(scm_t_int32
*)ptr
= scm_to_int32 (val
);
210 case SCM_FOREIGN_TYPE_UINT64
:
211 *(scm_t_uint64
*)ptr
= scm_to_uint64 (val
);
213 case SCM_FOREIGN_TYPE_INT64
:
214 *(scm_t_int64
*)ptr
= scm_to_int64 (val
);
217 scm_wrong_type_arg_msg (FUNC_NAME
, 1, val
, "foreign");
220 return SCM_UNSPECIFIED
;
224 SCM_DEFINE (scm_foreign_to_bytevector
, "foreign->bytevector", 1, 3, 0,
225 (SCM foreign
, SCM uvec_type
, SCM offset
, SCM len
),
226 "Return a bytevector aliasing the memory pointed to by\n"
228 "@var{foreign} must be a void pointer, a foreign whose type is\n"
229 "@var{void}. By default, the resulting bytevector will alias\n"
230 "all of the memory pointed to by @var{foreign}, from beginning\n"
231 "to end, treated as a @code{vu8} array.\n\n"
232 "The user may specify an alternate default interpretation for\n"
233 "the memory by passing the @var{uvec_type} argument, to indicate\n"
234 "that the memory is an array of elements of that type.\n"
235 "@var{uvec_type} should be something that\n"
236 "@code{uniform-vector-element-type} would return, like @code{f32}\n"
238 "Users may also specify that the bytevector should only alias a\n"
239 "subset of the memory, by specifying @var{offset} and @var{len}\n"
241 #define FUNC_NAME s_scm_foreign_to_bytevector
245 size_t boffset
, blen
;
246 scm_t_array_element_type btype
;
248 SCM_VALIDATE_FOREIGN_TYPED (1, foreign
, VOID
);
249 ptr
= SCM_FOREIGN_POINTER (foreign
, scm_t_int8
);
251 if (SCM_UNLIKELY (ptr
== NULL
))
252 null_pointer_error (FUNC_NAME
);
254 if (SCM_UNBNDP (uvec_type
))
255 btype
= SCM_ARRAY_ELEMENT_TYPE_VU8
;
259 for (i
= 0; i
<= SCM_ARRAY_ELEMENT_TYPE_LAST
; i
++)
260 if (scm_is_eq (uvec_type
, scm_i_array_element_types
[i
]))
264 case SCM_ARRAY_ELEMENT_TYPE_VU8
:
265 case SCM_ARRAY_ELEMENT_TYPE_U8
:
266 case SCM_ARRAY_ELEMENT_TYPE_S8
:
267 case SCM_ARRAY_ELEMENT_TYPE_U16
:
268 case SCM_ARRAY_ELEMENT_TYPE_S16
:
269 case SCM_ARRAY_ELEMENT_TYPE_U32
:
270 case SCM_ARRAY_ELEMENT_TYPE_S32
:
271 case SCM_ARRAY_ELEMENT_TYPE_U64
:
272 case SCM_ARRAY_ELEMENT_TYPE_S64
:
273 case SCM_ARRAY_ELEMENT_TYPE_F32
:
274 case SCM_ARRAY_ELEMENT_TYPE_F64
:
275 case SCM_ARRAY_ELEMENT_TYPE_C32
:
276 case SCM_ARRAY_ELEMENT_TYPE_C64
:
280 scm_wrong_type_arg_msg (FUNC_NAME
, SCM_ARG1
, uvec_type
,
281 "uniform vector type");
285 if (SCM_UNBNDP (offset
))
287 else if (SCM_FOREIGN_LEN (foreign
))
288 boffset
= scm_to_unsigned_integer (offset
, 0,
289 SCM_FOREIGN_LEN (foreign
) - 1);
291 boffset
= scm_to_size_t (offset
);
293 if (SCM_UNBNDP (len
))
295 if (SCM_FOREIGN_LEN (foreign
))
296 blen
= SCM_FOREIGN_LEN (foreign
) - boffset
;
298 scm_misc_error (FUNC_NAME
,
299 "length needed to convert foreign pointer to bytevector",
304 if (SCM_FOREIGN_LEN (foreign
))
305 blen
= scm_to_unsigned_integer (len
, 0,
306 SCM_FOREIGN_LEN (foreign
) - boffset
);
308 blen
= scm_to_size_t (len
);
311 ret
= scm_c_take_typed_bytevector (ptr
+ boffset
, blen
, btype
);
312 register_weak_reference (ret
, foreign
);
317 SCM_DEFINE (scm_bytevector_to_foreign
, "bytevector->foreign", 1, 2, 0,
318 (SCM bv
, SCM offset
, SCM len
),
319 "Return a foreign pointer aliasing the memory pointed to by\n"
321 "The resulting foreign will be a void pointer, a foreign whose\n"
322 "type is @code{void}. By default it will alias all of the\n"
323 "memory pointed to by @var{bv}, from beginning to end.\n\n"
324 "Users may explicily specify that the foreign should only alias a\n"
325 "subset of the memory, by specifying @var{offset} and @var{len}\n"
327 #define FUNC_NAME s_scm_bytevector_to_foreign
331 size_t boffset
, blen
;
333 SCM_VALIDATE_BYTEVECTOR (1, bv
);
334 ptr
= SCM_BYTEVECTOR_CONTENTS (bv
);
336 if (SCM_UNBNDP (offset
))
339 boffset
= scm_to_unsigned_integer (offset
, 0,
340 SCM_BYTEVECTOR_LENGTH (bv
) - 1);
342 if (SCM_UNBNDP (len
))
343 blen
= SCM_BYTEVECTOR_LENGTH (bv
) - boffset
;
345 blen
= scm_to_unsigned_integer (len
, 0,
346 SCM_BYTEVECTOR_LENGTH (bv
) - boffset
);
348 ret
= scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID
, ptr
+ boffset
, blen
,
350 register_weak_reference (ret
, bv
);
355 SCM_DEFINE (scm_foreign_set_finalizer_x
, "foreign-set-finalizer!", 2, 0, 0,
356 (SCM foreign
, SCM finalizer
),
357 "Arrange for the C procedure wrapped by @var{finalizer} to be\n"
358 "called on the pointer wrapped by @var{foreign} when @var{foreign}\n"
359 "becomes unreachable. Note: the C procedure should not call into\n"
360 "Scheme. If you need a Scheme finalizer, use guardians.")
361 #define FUNC_NAME s_scm_foreign_set_finalizer_x
364 GC_finalization_proc prev_finalizer
;
365 GC_PTR prev_finalizer_data
;
367 SCM_VALIDATE_FOREIGN_TYPED (1, foreign
, VOID
);
368 SCM_VALIDATE_FOREIGN_TYPED (2, finalizer
, VOID
);
370 c_finalizer
= SCM_FOREIGN_POINTER (finalizer
, void);
372 SCM_SET_CELL_WORD_0 (foreign
, SCM_CELL_WORD_0 (foreign
) | (1<<16));
374 GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (foreign
),
375 foreign_finalizer_trampoline
,
378 &prev_finalizer_data
);
380 return SCM_UNSPECIFIED
;
387 scm_i_foreign_print (SCM foreign
, SCM port
, scm_print_state
*pstate
)
389 scm_puts ("#<foreign ", port
);
390 switch (SCM_FOREIGN_TYPE (foreign
))
392 case SCM_FOREIGN_TYPE_FLOAT
:
393 scm_puts ("float ", port
);
395 case SCM_FOREIGN_TYPE_DOUBLE
:
396 scm_puts ("double ", port
);
398 case SCM_FOREIGN_TYPE_UINT8
:
399 scm_puts ("uint8 ", port
);
401 case SCM_FOREIGN_TYPE_INT8
:
402 scm_puts ("int8 ", port
);
404 case SCM_FOREIGN_TYPE_UINT16
:
405 scm_puts ("uint16 ", port
);
407 case SCM_FOREIGN_TYPE_INT16
:
408 scm_puts ("int16 ", port
);
410 case SCM_FOREIGN_TYPE_UINT32
:
411 scm_puts ("uint32 ", port
);
413 case SCM_FOREIGN_TYPE_INT32
:
414 scm_puts ("int32 ", port
);
416 case SCM_FOREIGN_TYPE_UINT64
:
417 scm_puts ("uint64 ", port
);
419 case SCM_FOREIGN_TYPE_INT64
:
420 scm_puts ("int64 ", port
);
422 case SCM_FOREIGN_TYPE_VOID
:
423 scm_puts ("pointer ", port
);
426 scm_wrong_type_arg_msg ("%print-foreign", 1, foreign
, "foreign");
428 scm_display (scm_foreign_ref (foreign
), port
);
429 scm_putc ('>', port
);
435 #define ROUND_UP(len,align) (align?(((len-1)|(align-1))+1):len)
437 SCM_DEFINE (scm_alignof
, "alignof", 1, 0, 0, (SCM type
),
438 "Return the alignment of @var{type}, in bytes.\n\n"
439 "@var{type} should be a valid C type, like @code{int}.\n"
440 "Alternately @var{type} may be the symbol @code{*}, in which\n"
441 "case the alignment of a pointer is returned. @var{type} may\n"
442 "also be a list of types, in which case the alignment of a\n"
443 "@code{struct} with ABI-conventional packing is returned.")
444 #define FUNC_NAME s_scm_alignof
446 if (SCM_I_INUMP (type
))
448 switch (SCM_I_INUM (type
))
450 case SCM_FOREIGN_TYPE_FLOAT
:
451 return scm_from_size_t (alignof (float));
452 case SCM_FOREIGN_TYPE_DOUBLE
:
453 return scm_from_size_t (alignof (double));
454 case SCM_FOREIGN_TYPE_UINT8
:
455 return scm_from_size_t (alignof (scm_t_uint8
));
456 case SCM_FOREIGN_TYPE_INT8
:
457 return scm_from_size_t (alignof (scm_t_int8
));
458 case SCM_FOREIGN_TYPE_UINT16
:
459 return scm_from_size_t (alignof (scm_t_uint16
));
460 case SCM_FOREIGN_TYPE_INT16
:
461 return scm_from_size_t (alignof (scm_t_int16
));
462 case SCM_FOREIGN_TYPE_UINT32
:
463 return scm_from_size_t (alignof (scm_t_uint32
));
464 case SCM_FOREIGN_TYPE_INT32
:
465 return scm_from_size_t (alignof (scm_t_int32
));
466 case SCM_FOREIGN_TYPE_UINT64
:
467 return scm_from_size_t (alignof (scm_t_uint64
));
468 case SCM_FOREIGN_TYPE_INT64
:
469 return scm_from_size_t (alignof (scm_t_int64
));
471 scm_wrong_type_arg (FUNC_NAME
, 1, type
);
474 else if (scm_is_eq (type
, sym_asterisk
))
476 return scm_from_size_t (alignof (void*));
477 else if (scm_is_pair (type
))
479 return scm_alignof (scm_car (type
));
481 scm_wrong_type_arg (FUNC_NAME
, 1, type
);
485 SCM_DEFINE (scm_sizeof
, "sizeof", 1, 0, 0, (SCM type
),
486 "Return the size of @var{type}, in bytes.\n\n"
487 "@var{type} should be a valid C type, like @code{int}.\n"
488 "Alternately @var{type} may be the symbol @code{*}, in which\n"
489 "case the size of a pointer is returned. @var{type} may also\n"
490 "be a list of types, in which case the size of a @code{struct}\n"
491 "with ABI-conventional packing is returned.")
492 #define FUNC_NAME s_scm_sizeof
494 if (SCM_I_INUMP (type
))
496 switch (SCM_I_INUM (type
))
498 case SCM_FOREIGN_TYPE_FLOAT
:
499 return scm_from_size_t (sizeof (float));
500 case SCM_FOREIGN_TYPE_DOUBLE
:
501 return scm_from_size_t (sizeof (double));
502 case SCM_FOREIGN_TYPE_UINT8
:
503 return scm_from_size_t (sizeof (scm_t_uint8
));
504 case SCM_FOREIGN_TYPE_INT8
:
505 return scm_from_size_t (sizeof (scm_t_int8
));
506 case SCM_FOREIGN_TYPE_UINT16
:
507 return scm_from_size_t (sizeof (scm_t_uint16
));
508 case SCM_FOREIGN_TYPE_INT16
:
509 return scm_from_size_t (sizeof (scm_t_int16
));
510 case SCM_FOREIGN_TYPE_UINT32
:
511 return scm_from_size_t (sizeof (scm_t_uint32
));
512 case SCM_FOREIGN_TYPE_INT32
:
513 return scm_from_size_t (sizeof (scm_t_int32
));
514 case SCM_FOREIGN_TYPE_UINT64
:
515 return scm_from_size_t (sizeof (scm_t_uint64
));
516 case SCM_FOREIGN_TYPE_INT64
:
517 return scm_from_size_t (sizeof (scm_t_int64
));
519 scm_wrong_type_arg (FUNC_NAME
, 1, type
);
522 else if (scm_is_eq (type
, sym_asterisk
))
524 return scm_from_size_t (sizeof (void*));
525 else if (scm_is_pair (type
))
529 while (scm_is_pair (type
))
531 off
= ROUND_UP (off
, scm_to_size_t (scm_alignof (scm_car (type
))));
532 off
+= scm_to_size_t (scm_sizeof (scm_car (type
)));
533 type
= scm_cdr (type
);
535 return scm_from_size_t (off
);
538 scm_wrong_type_arg (FUNC_NAME
, 1, type
);
543 /* return 1 on success, 0 on failure */
545 parse_ffi_type (SCM type
, int return_p
, long *n_structs
, long *n_struct_elts
)
547 if (SCM_I_INUMP (type
))
549 if ((SCM_I_INUM (type
) < 0 )
550 || (SCM_I_INUM (type
) > SCM_FOREIGN_TYPE_LAST
))
552 else if (SCM_I_INUM (type
) == SCM_FOREIGN_TYPE_VOID
&& !return_p
)
557 else if (scm_is_eq (type
, sym_asterisk
))
564 len
= scm_ilength (type
);
569 if (!parse_ffi_type (scm_car (type
), 0, n_structs
, n_struct_elts
))
572 type
= scm_cdr (type
);
580 fill_ffi_type (SCM type
, ffi_type
*ftype
, ffi_type
***type_ptrs
,
583 if (SCM_I_INUMP (type
))
585 switch (SCM_I_INUM (type
))
587 case SCM_FOREIGN_TYPE_FLOAT
:
588 *ftype
= ffi_type_float
;
590 case SCM_FOREIGN_TYPE_DOUBLE
:
591 *ftype
= ffi_type_double
;
593 case SCM_FOREIGN_TYPE_UINT8
:
594 *ftype
= ffi_type_uint8
;
596 case SCM_FOREIGN_TYPE_INT8
:
597 *ftype
= ffi_type_sint8
;
599 case SCM_FOREIGN_TYPE_UINT16
:
600 *ftype
= ffi_type_uint16
;
602 case SCM_FOREIGN_TYPE_INT16
:
603 *ftype
= ffi_type_sint16
;
605 case SCM_FOREIGN_TYPE_UINT32
:
606 *ftype
= ffi_type_uint32
;
608 case SCM_FOREIGN_TYPE_INT32
:
609 *ftype
= ffi_type_sint32
;
611 case SCM_FOREIGN_TYPE_UINT64
:
612 *ftype
= ffi_type_uint64
;
614 case SCM_FOREIGN_TYPE_INT64
:
615 *ftype
= ffi_type_sint64
;
617 case SCM_FOREIGN_TYPE_VOID
:
618 *ftype
= ffi_type_void
;
621 scm_wrong_type_arg_msg ("make-foreign-function", 0, type
,
625 else if (scm_is_eq (type
, sym_asterisk
))
628 *ftype
= ffi_type_pointer
;
635 len
= scm_ilength (type
);
638 ftype
->alignment
= 0;
639 ftype
->type
= FFI_TYPE_STRUCT
;
640 ftype
->elements
= *type_ptrs
;
641 *type_ptrs
+= len
+ 1;
643 for (i
= 0; i
< len
; i
++)
645 ftype
->elements
[i
] = *types
;
647 fill_ffi_type (scm_car (type
), ftype
->elements
[i
],
649 type
= scm_cdr (type
);
651 ftype
->elements
[i
] = NULL
;
655 SCM_DEFINE (scm_make_foreign_function
, "make-foreign-function", 3, 0, 0,
656 (SCM return_type
, SCM func_ptr
, SCM arg_types
),
657 "Make a foreign function.\n\n"
658 "Given the foreign void pointer @var{func_ptr}, its argument and\n"
659 "return types @var{arg_types} and @var{return_type}, return a\n"
660 "procedure that will pass arguments to the foreign function\n"
661 "and return appropriate values.\n\n"
662 "@var{arg_types} should be a list of foreign types.\n"
663 "@code{return_type} should be a foreign type.")
664 #define FUNC_NAME s_scm_make_foreign_function
667 long i
, nargs
, n_structs
, n_struct_elts
;
671 ffi_type
**type_ptrs
;
674 SCM_VALIDATE_FOREIGN_TYPED (2, func_ptr
, VOID
);
675 nargs
= scm_ilength (arg_types
);
676 SCM_ASSERT (nargs
>= 0, arg_types
, 3, FUNC_NAME
);
677 /* fixme: assert nargs < 1<<32 */
678 n_structs
= n_struct_elts
= 0;
680 /* For want of talloc, we're going to have to do this in two passes: first we
681 figure out how much memory is needed for all types, then we allocate the
682 cif and the types all in one block. */
683 if (!parse_ffi_type (return_type
, 1, &n_structs
, &n_struct_elts
))
684 scm_wrong_type_arg (FUNC_NAME
, 1, return_type
);
685 for (walk
= arg_types
; scm_is_pair (walk
); walk
= scm_cdr (walk
))
686 if (!parse_ffi_type (scm_car (walk
), 0, &n_structs
, &n_struct_elts
))
687 scm_wrong_type_arg (FUNC_NAME
, 3, scm_car (walk
));
689 /* the memory: with space for the cif itself */
690 cif_len
= sizeof (ffi_cif
);
692 /* then ffi_type pointers: one for each arg, one for each struct
693 element, and one for each struct (for null-termination) */
694 cif_len
= (ROUND_UP (cif_len
, alignof(void*))
695 + (nargs
+ n_structs
+ n_struct_elts
)*sizeof(void*));
697 /* then the ffi_type structs themselves, one per arg and struct element, and
698 one for the return val */
699 cif_len
= (ROUND_UP (cif_len
, alignof(ffi_type
))
700 + (nargs
+ n_struct_elts
+ 1)*sizeof(ffi_type
));
702 mem
= scm_gc_malloc_pointerless (cif_len
, "foreign");
703 scm_cif
= scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID
, mem
,
705 cif
= (ffi_cif
*) mem
;
707 /* reuse cif_len to walk through the mem */
708 cif_len
= ROUND_UP (sizeof (ffi_cif
), alignof(void*));
709 type_ptrs
= (ffi_type
**)(mem
+ cif_len
);
710 cif_len
= ROUND_UP (cif_len
711 + (nargs
+ n_structs
+ n_struct_elts
)*sizeof(void*),
713 types
= (ffi_type
*)(mem
+ cif_len
);
715 /* whew. now knit the pointers together. */
716 cif
->rtype
= types
++;
717 fill_ffi_type (return_type
, cif
->rtype
, &type_ptrs
, &types
);
718 cif
->arg_types
= type_ptrs
;
720 for (walk
= arg_types
, i
= 0; scm_is_pair (walk
); walk
= scm_cdr (walk
), i
++)
722 cif
->arg_types
[i
] = types
++;
723 fill_ffi_type (scm_car (walk
), cif
->arg_types
[i
], &type_ptrs
, &types
);
726 /* round out the cif, and we're done. */
727 cif
->abi
= FFI_DEFAULT_ABI
;
732 if (FFI_OK
!= ffi_prep_cif (cif
, FFI_DEFAULT_ABI
, cif
->nargs
, cif
->rtype
,
734 scm_misc_error (FUNC_NAME
, "ffi_prep_cif failed", SCM_EOL
);
736 return cif_to_procedure (scm_cif
, func_ptr
);
742 /* Pre-generate trampolines for less than 10 arguments. */
744 #ifdef WORDS_BIGENDIAN
745 #define OBJCODE_HEADER 0, 0, 0, 8, 0, 0, 0, 40
746 #define META_HEADER 0, 0, 0, 32, 0, 0, 0, 0
748 #define OBJCODE_HEADER 8, 0, 0, 0, 40, 0, 0, 0
749 #define META_HEADER 32, 0, 0, 0, 0, 0, 0, 0
754 /* 0 */ scm_op_assert_nargs_ee, 0, nreq, /* assert number of args */ \
755 /* 3 */ scm_op_object_ref, 0, /* push the pair with the cif and the function pointer */ \
756 /* 5 */ scm_op_foreign_call, nreq, /* and call (will return value as well) */ \
757 /* 7 */ scm_op_nop, \
758 /* 8 */ META (3, 7, nreq)
760 #define META(start, end, nreq) \
762 /* 0 */ scm_op_make_eol, /* bindings */ \
763 /* 1 */ scm_op_make_eol, /* sources */ \
764 /* 2 */ scm_op_make_int8, start, scm_op_make_int8, end, /* arity: from ip N to ip N */ \
765 /* 6 */ scm_op_make_int8, nreq, /* the arity is N required args */ \
766 /* 8 */ scm_op_list, 0, 3, /* make a list of those 3 vals */ \
767 /* 11 */ scm_op_list, 0, 1, /* and the arities will be a list of that one list */ \
768 /* 14 */ scm_op_load_symbol, 0, 0, 4, 'n', 'a', 'm', 'e', /* `name' */ \
769 /* 22 */ scm_op_object_ref, 1, /* the name from the object table */ \
770 /* 24 */ scm_op_cons, /* make a pair for the properties */ \
771 /* 25 */ scm_op_list, 0, 4, /* pack bindings, sources, and arities into list */ \
772 /* 28 */ scm_op_return, /* and return */ \
773 /* 29 */ scm_op_nop, scm_op_nop, scm_op_nop \
778 scm_t_uint64 dummy
; /* ensure 8-byte alignment; perhaps there's a better way */
779 const scm_t_uint8 bytes
[10 * (sizeof (struct scm_objcode
) + 8
780 + sizeof (struct scm_objcode
) + 32)];
784 CODE (0), CODE (1), CODE (2), CODE (3), CODE (4),
785 CODE (5), CODE (6), CODE (7), CODE (8), CODE (9)
791 #undef OBJCODE_HEADER
795 (defun generate-objcode-cells (n)
796 "Generate objcode cells for up to N arguments"
801 (format " { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + %d) },\n"
802 (* (+ 4 4 8 4 4 32) i)))
803 (insert " { SCM_BOOL_F, SCM_PACK (0) },\n")
806 #define STATIC_OBJCODE_TAG \
807 SCM_PACK (scm_tc7_objcode | (SCM_F_OBJCODE_IS_STATIC << 8))
811 scm_t_uint64 dummy
; /* alignment */
812 scm_t_cell cells
[10 * 2]; /* 10 double cells */
815 /* C-u 1 0 M-x generate-objcode-cells RET */
817 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 0) },
818 { SCM_BOOL_F
, SCM_PACK (0) },
819 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 56) },
820 { SCM_BOOL_F
, SCM_PACK (0) },
821 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 112) },
822 { SCM_BOOL_F
, SCM_PACK (0) },
823 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 168) },
824 { SCM_BOOL_F
, SCM_PACK (0) },
825 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 224) },
826 { SCM_BOOL_F
, SCM_PACK (0) },
827 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 280) },
828 { SCM_BOOL_F
, SCM_PACK (0) },
829 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 336) },
830 { SCM_BOOL_F
, SCM_PACK (0) },
831 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 392) },
832 { SCM_BOOL_F
, SCM_PACK (0) },
833 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 448) },
834 { SCM_BOOL_F
, SCM_PACK (0) },
835 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 504) },
836 { SCM_BOOL_F
, SCM_PACK (0) }
840 static const SCM objcode_trampolines
[10] = {
841 SCM_PACK (objcode_cells
.cells
+0),
842 SCM_PACK (objcode_cells
.cells
+2),
843 SCM_PACK (objcode_cells
.cells
+4),
844 SCM_PACK (objcode_cells
.cells
+6),
845 SCM_PACK (objcode_cells
.cells
+8),
846 SCM_PACK (objcode_cells
.cells
+10),
847 SCM_PACK (objcode_cells
.cells
+12),
848 SCM_PACK (objcode_cells
.cells
+14),
849 SCM_PACK (objcode_cells
.cells
+16),
850 SCM_PACK (objcode_cells
.cells
+18),
854 cif_to_procedure (SCM cif
, SCM func_ptr
)
856 unsigned nargs
= SCM_FOREIGN_POINTER (cif
, ffi_cif
)->nargs
;
857 SCM objcode
, table
, ret
;
860 objcode
= objcode_trampolines
[nargs
];
862 scm_misc_error ("make-foreign-function", "args >= 10 currently unimplemented",
865 table
= scm_c_make_vector (2, SCM_UNDEFINED
);
866 SCM_SIMPLE_VECTOR_SET (table
, 0, scm_cons (cif
, func_ptr
));
867 SCM_SIMPLE_VECTOR_SET (table
, 1, SCM_BOOL_F
); /* name */
868 ret
= scm_make_program (objcode
, table
, SCM_BOOL_F
);
873 /* Set *LOC to the foreign representation of X with TYPE. */
875 unpack (const ffi_type
*type
, void *loc
, SCM x
)
880 *(float *) loc
= scm_to_double (x
);
882 case FFI_TYPE_DOUBLE
:
883 *(double *) loc
= scm_to_double (x
);
886 *(scm_t_uint8
*) loc
= scm_to_uint8 (x
);
889 *(scm_t_int8
*) loc
= scm_to_int8 (x
);
891 case FFI_TYPE_UINT16
:
892 *(scm_t_uint16
*) loc
= scm_to_uint16 (x
);
894 case FFI_TYPE_SINT16
:
895 *(scm_t_int16
*) loc
= scm_to_int16 (x
);
897 case FFI_TYPE_UINT32
:
898 *(scm_t_uint32
*) loc
= scm_to_uint32 (x
);
900 case FFI_TYPE_SINT32
:
901 *(scm_t_int32
*) loc
= scm_to_int32 (x
);
903 case FFI_TYPE_UINT64
:
904 *(scm_t_uint64
*) loc
= scm_to_uint64 (x
);
906 case FFI_TYPE_SINT64
:
907 *(scm_t_int64
*) loc
= scm_to_int64 (x
);
909 case FFI_TYPE_STRUCT
:
910 if (!SCM_FOREIGN_TYPED_P (x
, VOID
))
911 scm_wrong_type_arg_msg ("foreign-call", 0, x
, "foreign void pointer");
912 if (SCM_FOREIGN_LEN (x
) && SCM_FOREIGN_LEN (x
) != type
->size
)
913 scm_wrong_type_arg_msg ("foreign-call", 0, x
,
914 "foreign void pointer of correct length");
915 memcpy (loc
, SCM_FOREIGN_POINTER (x
, void), type
->size
);
917 case FFI_TYPE_POINTER
:
918 if (!SCM_FOREIGN_TYPED_P (x
, VOID
))
919 scm_wrong_type_arg_msg ("foreign-call", 0, x
, "foreign void pointer");
920 *(void **) loc
= SCM_FOREIGN_POINTER (x
, void);
927 /* Return a Scheme representation of the foreign value at LOC of type TYPE. */
929 pack (const ffi_type
* type
, const void *loc
)
934 return SCM_UNSPECIFIED
;
936 return scm_from_double (*(float *) loc
);
937 case FFI_TYPE_DOUBLE
:
938 return scm_from_double (*(double *) loc
);
940 return scm_from_uint8 (*(scm_t_uint8
*) loc
);
942 return scm_from_int8 (*(scm_t_int8
*) loc
);
943 case FFI_TYPE_UINT16
:
944 return scm_from_uint16 (*(scm_t_uint16
*) loc
);
945 case FFI_TYPE_SINT16
:
946 return scm_from_int16 (*(scm_t_int16
*) loc
);
947 case FFI_TYPE_UINT32
:
948 return scm_from_uint32 (*(scm_t_uint32
*) loc
);
949 case FFI_TYPE_SINT32
:
950 return scm_from_int32 (*(scm_t_int32
*) loc
);
951 case FFI_TYPE_UINT64
:
952 return scm_from_uint64 (*(scm_t_uint64
*) loc
);
953 case FFI_TYPE_SINT64
:
954 return scm_from_int64 (*(scm_t_int64
*) loc
);
955 case FFI_TYPE_STRUCT
:
957 void *mem
= scm_gc_malloc_pointerless (type
->size
, "foreign");
958 memcpy (mem
, loc
, type
->size
);
959 return scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID
,
960 mem
, type
->size
, NULL
);
962 case FFI_TYPE_POINTER
:
963 return scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID
,
964 *(void **) loc
, 0, NULL
);
972 scm_i_foreign_call (SCM foreign
, const SCM
*argv
)
974 /* FOREIGN is the pair that cif_to_procedure set as the 0th element of the
985 cif
= SCM_FOREIGN_POINTER (SCM_CAR (foreign
), ffi_cif
);
986 func
= SCM_FOREIGN_POINTER (SCM_CDR (foreign
), void);
988 /* Argument pointers. */
989 args
= alloca (sizeof (void *) * cif
->nargs
);
991 /* Compute the amount of memory needed to store all the argument values.
992 Note: as of libffi 3.0.9 `cif->bytes' is undocumented and is zero, so it
993 can't be used for that purpose. */
994 for (i
= 0, arg_size
= 0;
997 arg_size
+= ROUND_UP (cif
->arg_types
[i
]->size
,
998 cif
->arg_types
[i
]->alignment
);
1000 /* Space for argument values, followed by return value. */
1001 data
= alloca (arg_size
1002 + ROUND_UP (cif
->rtype
->size
, cif
->rtype
->alignment
));
1004 /* Unpack ARGV to native values, setting ARGV pointers. */
1005 for (i
= 0, off
= 0;
1007 off
+= cif
->arg_types
[i
]->size
, i
++)
1009 off
= ROUND_UP (off
, cif
->arg_types
[i
]->alignment
);
1010 args
[i
] = data
+ off
;
1011 unpack (cif
->arg_types
[i
], args
[i
], argv
[i
]);
1014 /* Prepare space for the return value. */
1015 off
= ROUND_UP (off
, cif
->rtype
->alignment
);
1016 rvalue
= data
+ off
;
1019 ffi_call (cif
, func
, rvalue
, args
);
1021 return pack (cif
->rtype
, rvalue
);
1027 scm_init_foreign (void)
1029 #ifndef SCM_MAGIC_SNARFER
1030 #include "libguile/foreign.x"
1032 scm_define (sym_void
, scm_from_uint8 (SCM_FOREIGN_TYPE_VOID
));
1033 scm_define (sym_float
, scm_from_uint8 (SCM_FOREIGN_TYPE_FLOAT
));
1034 scm_define (sym_double
, scm_from_uint8 (SCM_FOREIGN_TYPE_DOUBLE
));
1035 scm_define (sym_uint8
, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT8
));
1036 scm_define (sym_int8
, scm_from_uint8 (SCM_FOREIGN_TYPE_INT8
));
1037 scm_define (sym_uint16
, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT16
));
1038 scm_define (sym_int16
, scm_from_uint8 (SCM_FOREIGN_TYPE_INT16
));
1039 scm_define (sym_uint32
, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32
));
1040 scm_define (sym_int32
, scm_from_uint8 (SCM_FOREIGN_TYPE_INT32
));
1041 scm_define (sym_uint64
, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64
));
1042 scm_define (sym_int64
, scm_from_uint8 (SCM_FOREIGN_TYPE_INT64
));
1044 scm_define (sym_int
,
1046 scm_from_uint8 (SCM_FOREIGN_TYPE_INT64
)
1047 #elif SIZEOF_INT == 4
1048 scm_from_uint8 (SCM_FOREIGN_TYPE_INT32
)
1050 # error unsupported sizeof (int)
1054 scm_define (sym_unsigned_int
,
1055 #if SIZEOF_UNSIGNED_INT == 8
1056 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64
)
1057 #elif SIZEOF_UNSIGNED_INT == 4
1058 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32
)
1060 # error unsupported sizeof (unsigned int)
1064 scm_define (sym_long
,
1065 #if SIZEOF_LONG == 8
1066 scm_from_uint8 (SCM_FOREIGN_TYPE_INT64
)
1067 #elif SIZEOF_LONG == 4
1068 scm_from_uint8 (SCM_FOREIGN_TYPE_INT32
)
1070 # error unsupported sizeof (long)
1074 scm_define (sym_unsigned_long
,
1075 #if SIZEOF_UNSIGNED_LONG == 8
1076 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64
)
1077 #elif SIZEOF_UNSIGNED_LONG == 4
1078 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32
)
1080 # error unsupported sizeof (unsigned long)
1084 scm_define (sym_size_t
,
1085 #if SIZEOF_SIZE_T == 8
1086 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64
)
1087 #elif SIZEOF_SIZE_T == 4
1088 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32
)
1090 # error unsupported sizeof (size_t)
1094 null_pointer
= scm_cell (scm_tc7_foreign
| (SCM_FOREIGN_TYPE_VOID
<< 8UL),
1096 scm_define (sym_null
, null_pointer
);
1100 scm_register_foreign (void)
1102 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1104 (scm_t_extension_init_func
)scm_init_foreign
,
1106 foreign_weak_refs
= scm_make_weak_key_hash_table (SCM_UNDEFINED
);