1 /* Copyright (C) 2010 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful, but
9 * WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
29 #include "libguile/_scm.h"
30 #include "libguile/bytevectors.h"
31 #include "libguile/instructions.h"
32 #include "libguile/foreign.h"
36 SCM_SYMBOL (sym_void
, "void");
37 SCM_SYMBOL (sym_float
, "float");
38 SCM_SYMBOL (sym_double
, "double");
39 SCM_SYMBOL (sym_uint8
, "uint8");
40 SCM_SYMBOL (sym_int8
, "int8");
41 SCM_SYMBOL (sym_uint16
, "uint16");
42 SCM_SYMBOL (sym_int16
, "int16");
43 SCM_SYMBOL (sym_uint32
, "uint32");
44 SCM_SYMBOL (sym_int32
, "int32");
45 SCM_SYMBOL (sym_uint64
, "uint64");
46 SCM_SYMBOL (sym_int64
, "int64");
47 SCM_SYMBOL (sym_int
, "int");
48 SCM_SYMBOL (sym_long
, "long");
49 SCM_SYMBOL (sym_unsigned_int
, "unsigned-int");
50 SCM_SYMBOL (sym_unsigned_long
, "unsigned-long");
51 SCM_SYMBOL (sym_size_t
, "size_t");
53 /* that's for pointers, you know. */
54 SCM_SYMBOL (sym_asterisk
, "*");
56 SCM_SYMBOL (sym_null
, "%null-pointer");
57 SCM_SYMBOL (sym_null_pointer_error
, "null-pointer-error");
59 /* The cell representing the null pointer. */
60 static SCM null_pointer
;
62 #if SIZEOF_VOID_P == 4
63 # define scm_to_uintptr scm_to_uint32
64 # define scm_from_uintptr scm_from_uint32
65 #elif SIZEOF_VOID_P == 8
66 # define scm_to_uintptr scm_to_uint64
67 # define scm_from_uintptr scm_from_uint64
69 # error unsupported pointer size
73 /* Raise a null pointer dereference error. */
75 null_pointer_error (const char *func_name
)
77 scm_error (sym_null_pointer_error
, func_name
,
78 "null pointer dereference", SCM_EOL
, SCM_EOL
);
82 static SCM
cif_to_procedure (SCM cif
, SCM func_ptr
);
85 static SCM pointer_weak_refs
= SCM_BOOL_F
;
88 register_weak_reference (SCM from
, SCM to
)
90 scm_hashq_set_x (pointer_weak_refs
, from
, to
);
94 pointer_finalizer_trampoline (GC_PTR ptr
, GC_PTR data
)
96 scm_t_pointer_finalizer finalizer
= data
;
97 finalizer (SCM_POINTER_VALUE (PTR2SCM (ptr
)));
100 SCM_DEFINE (scm_make_pointer
, "make-pointer", 1, 1, 0,
101 (SCM address
, SCM finalizer
),
102 "Return a foreign pointer object pointing to @var{address}. "
103 "If @var{finalizer} is passed, it should be a pointer to a "
104 "one-argument C function that will be called when the pointer "
105 "object becomes unreachable.")
106 #define FUNC_NAME s_scm_make_pointer
109 scm_t_uintptr c_address
;
111 c_address
= scm_to_uintptr (address
);
112 if (SCM_UNBNDP (finalizer
))
116 SCM_VALIDATE_POINTER (2, finalizer
);
117 c_finalizer
= SCM_POINTER_VALUE (finalizer
);
120 return scm_from_pointer ((void *) c_address
, c_finalizer
);
125 scm_from_pointer (void *ptr
, scm_t_pointer_finalizer finalizer
)
129 if (ptr
== NULL
&& finalizer
== NULL
)
135 type
= scm_tc7_pointer
| (finalizer
? (1 << 16UL) : 0UL);
136 ret
= scm_cell (type
, (scm_t_bits
) ptr
);
140 /* Register a finalizer for the newly created instance. */
141 GC_finalization_proc prev_finalizer
;
142 GC_PTR prev_finalizer_data
;
143 GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (ret
),
144 pointer_finalizer_trampoline
,
147 &prev_finalizer_data
);
154 SCM_DEFINE (scm_pointer_address
, "pointer-address", 1, 0, 0,
156 "Return the numerical value of @var{pointer}.")
157 #define FUNC_NAME s_scm_pointer_address
159 SCM_VALIDATE_POINTER (1, pointer
);
161 return scm_from_uintptr ((scm_t_uintptr
) SCM_POINTER_VALUE (pointer
));
165 SCM_DEFINE (scm_dereference_pointer
, "dereference-pointer", 1, 0, 0,
167 "Assuming @var{pointer} points to a memory region that\n"
168 "holds a pointer, return this pointer.")
169 #define FUNC_NAME s_scm_dereference_pointer
171 SCM_VALIDATE_POINTER (1, pointer
);
173 return scm_from_pointer (* (void **) SCM_POINTER_VALUE (pointer
), NULL
);
177 SCM_DEFINE (scm_pointer_to_bytevector
, "pointer->bytevector", 2, 2, 0,
178 (SCM pointer
, SCM len
, SCM offset
, SCM uvec_type
),
179 "Return a bytevector aliasing the @var{len} bytes pointed\n"
180 "to by @var{pointer}.\n\n"
181 "The user may specify an alternate default interpretation for\n"
182 "the memory by passing the @var{uvec_type} argument, to indicate\n"
183 "that the memory is an array of elements of that type.\n"
184 "@var{uvec_type} should be something that\n"
185 "@code{uniform-vector-element-type} would return, like @code{f32}\n"
187 "When @var{offset} is passed, it specifies the offset in bytes\n"
188 "relative to @var{pointer} of the memory region aliased by the\n"
189 "returned bytevector.")
190 #define FUNC_NAME s_scm_pointer_to_bytevector
194 size_t boffset
, blen
;
195 scm_t_array_element_type btype
;
197 SCM_VALIDATE_POINTER (1, pointer
);
198 ptr
= SCM_POINTER_VALUE (pointer
);
200 if (SCM_UNLIKELY (ptr
== NULL
))
201 null_pointer_error (FUNC_NAME
);
203 if (SCM_UNBNDP (uvec_type
))
204 btype
= SCM_ARRAY_ELEMENT_TYPE_VU8
;
208 for (i
= 0; i
<= SCM_ARRAY_ELEMENT_TYPE_LAST
; i
++)
209 if (scm_is_eq (uvec_type
, scm_i_array_element_types
[i
]))
213 case SCM_ARRAY_ELEMENT_TYPE_VU8
:
214 case SCM_ARRAY_ELEMENT_TYPE_U8
:
215 case SCM_ARRAY_ELEMENT_TYPE_S8
:
216 case SCM_ARRAY_ELEMENT_TYPE_U16
:
217 case SCM_ARRAY_ELEMENT_TYPE_S16
:
218 case SCM_ARRAY_ELEMENT_TYPE_U32
:
219 case SCM_ARRAY_ELEMENT_TYPE_S32
:
220 case SCM_ARRAY_ELEMENT_TYPE_U64
:
221 case SCM_ARRAY_ELEMENT_TYPE_S64
:
222 case SCM_ARRAY_ELEMENT_TYPE_F32
:
223 case SCM_ARRAY_ELEMENT_TYPE_F64
:
224 case SCM_ARRAY_ELEMENT_TYPE_C32
:
225 case SCM_ARRAY_ELEMENT_TYPE_C64
:
229 scm_wrong_type_arg_msg (FUNC_NAME
, SCM_ARG1
, uvec_type
,
230 "uniform vector type");
234 if (SCM_UNBNDP (offset
))
237 boffset
= scm_to_size_t (offset
);
239 blen
= scm_to_size_t (len
);
241 ret
= scm_c_take_typed_bytevector (ptr
+ boffset
, blen
, btype
);
242 register_weak_reference (ret
, pointer
);
247 SCM_DEFINE (scm_bytevector_to_pointer
, "bytevector->pointer", 1, 1, 0,
248 (SCM bv
, SCM offset
),
249 "Return a pointer pointer aliasing the memory pointed to by\n"
250 "@var{bv} or @var{offset} bytes after @var{bv} when @var{offset}\n"
252 #define FUNC_NAME s_scm_bytevector_to_pointer
258 SCM_VALIDATE_BYTEVECTOR (1, bv
);
259 ptr
= SCM_BYTEVECTOR_CONTENTS (bv
);
261 if (SCM_UNBNDP (offset
))
264 boffset
= scm_to_unsigned_integer (offset
, 0,
265 SCM_BYTEVECTOR_LENGTH (bv
) - 1);
267 ret
= scm_from_pointer (ptr
+ boffset
, NULL
);
268 register_weak_reference (ret
, bv
);
273 SCM_DEFINE (scm_set_pointer_finalizer_x
, "set-pointer-finalizer!", 2, 0, 0,
274 (SCM pointer
, SCM finalizer
),
275 "Arrange for the C procedure wrapped by @var{finalizer} to be\n"
276 "called on the pointer wrapped by @var{pointer} when @var{pointer}\n"
277 "becomes unreachable. Note: the C procedure should not call into\n"
278 "Scheme. If you need a Scheme finalizer, use guardians.")
279 #define FUNC_NAME s_scm_set_pointer_finalizer_x
282 GC_finalization_proc prev_finalizer
;
283 GC_PTR prev_finalizer_data
;
285 SCM_VALIDATE_POINTER (1, pointer
);
286 SCM_VALIDATE_POINTER (2, finalizer
);
288 c_finalizer
= SCM_POINTER_VALUE (finalizer
);
290 SCM_SET_CELL_WORD_0 (pointer
, SCM_CELL_WORD_0 (pointer
) | (1 << 16UL));
292 GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (pointer
),
293 pointer_finalizer_trampoline
,
296 &prev_finalizer_data
);
298 return SCM_UNSPECIFIED
;
305 scm_i_pointer_print (SCM pointer
, SCM port
, scm_print_state
*pstate
)
307 scm_puts ("#<pointer ", port
);
308 scm_display (scm_pointer_address (pointer
), port
);
309 scm_putc ('>', port
);
314 SCM_DEFINE (scm_alignof
, "alignof", 1, 0, 0, (SCM type
),
315 "Return the alignment of @var{type}, in bytes.\n\n"
316 "@var{type} should be a valid C type, like @code{int}.\n"
317 "Alternately @var{type} may be the symbol @code{*}, in which\n"
318 "case the alignment of a pointer is returned. @var{type} may\n"
319 "also be a list of types, in which case the alignment of a\n"
320 "@code{struct} with ABI-conventional packing is returned.")
321 #define FUNC_NAME s_scm_alignof
323 if (SCM_I_INUMP (type
))
325 switch (SCM_I_INUM (type
))
327 case SCM_FOREIGN_TYPE_FLOAT
:
328 return scm_from_size_t (alignof (float));
329 case SCM_FOREIGN_TYPE_DOUBLE
:
330 return scm_from_size_t (alignof (double));
331 case SCM_FOREIGN_TYPE_UINT8
:
332 return scm_from_size_t (alignof (scm_t_uint8
));
333 case SCM_FOREIGN_TYPE_INT8
:
334 return scm_from_size_t (alignof (scm_t_int8
));
335 case SCM_FOREIGN_TYPE_UINT16
:
336 return scm_from_size_t (alignof (scm_t_uint16
));
337 case SCM_FOREIGN_TYPE_INT16
:
338 return scm_from_size_t (alignof (scm_t_int16
));
339 case SCM_FOREIGN_TYPE_UINT32
:
340 return scm_from_size_t (alignof (scm_t_uint32
));
341 case SCM_FOREIGN_TYPE_INT32
:
342 return scm_from_size_t (alignof (scm_t_int32
));
343 case SCM_FOREIGN_TYPE_UINT64
:
344 return scm_from_size_t (alignof (scm_t_uint64
));
345 case SCM_FOREIGN_TYPE_INT64
:
346 return scm_from_size_t (alignof (scm_t_int64
));
348 scm_wrong_type_arg (FUNC_NAME
, 1, type
);
351 else if (scm_is_eq (type
, sym_asterisk
))
353 return scm_from_size_t (alignof (void*));
354 else if (scm_is_pair (type
))
356 return scm_alignof (scm_car (type
));
358 scm_wrong_type_arg (FUNC_NAME
, 1, type
);
362 SCM_DEFINE (scm_sizeof
, "sizeof", 1, 0, 0, (SCM type
),
363 "Return the size of @var{type}, in bytes.\n\n"
364 "@var{type} should be a valid C type, like @code{int}.\n"
365 "Alternately @var{type} may be the symbol @code{*}, in which\n"
366 "case the size of a pointer is returned. @var{type} may also\n"
367 "be a list of types, in which case the size of a @code{struct}\n"
368 "with ABI-conventional packing is returned.")
369 #define FUNC_NAME s_scm_sizeof
371 if (SCM_I_INUMP (type
))
373 switch (SCM_I_INUM (type
))
375 case SCM_FOREIGN_TYPE_FLOAT
:
376 return scm_from_size_t (sizeof (float));
377 case SCM_FOREIGN_TYPE_DOUBLE
:
378 return scm_from_size_t (sizeof (double));
379 case SCM_FOREIGN_TYPE_UINT8
:
380 return scm_from_size_t (sizeof (scm_t_uint8
));
381 case SCM_FOREIGN_TYPE_INT8
:
382 return scm_from_size_t (sizeof (scm_t_int8
));
383 case SCM_FOREIGN_TYPE_UINT16
:
384 return scm_from_size_t (sizeof (scm_t_uint16
));
385 case SCM_FOREIGN_TYPE_INT16
:
386 return scm_from_size_t (sizeof (scm_t_int16
));
387 case SCM_FOREIGN_TYPE_UINT32
:
388 return scm_from_size_t (sizeof (scm_t_uint32
));
389 case SCM_FOREIGN_TYPE_INT32
:
390 return scm_from_size_t (sizeof (scm_t_int32
));
391 case SCM_FOREIGN_TYPE_UINT64
:
392 return scm_from_size_t (sizeof (scm_t_uint64
));
393 case SCM_FOREIGN_TYPE_INT64
:
394 return scm_from_size_t (sizeof (scm_t_int64
));
396 scm_wrong_type_arg (FUNC_NAME
, 1, type
);
399 else if (scm_is_eq (type
, sym_asterisk
))
401 return scm_from_size_t (sizeof (void*));
402 else if (scm_is_pair (type
))
406 while (scm_is_pair (type
))
408 off
= ROUND_UP (off
, scm_to_size_t (scm_alignof (scm_car (type
))));
409 off
+= scm_to_size_t (scm_sizeof (scm_car (type
)));
410 type
= scm_cdr (type
);
412 return scm_from_size_t (off
);
415 scm_wrong_type_arg (FUNC_NAME
, 1, type
);
420 /* return 1 on success, 0 on failure */
422 parse_ffi_type (SCM type
, int return_p
, long *n_structs
, long *n_struct_elts
)
424 if (SCM_I_INUMP (type
))
426 if ((SCM_I_INUM (type
) < 0 )
427 || (SCM_I_INUM (type
) > SCM_FOREIGN_TYPE_LAST
))
429 else if (SCM_I_INUM (type
) == SCM_FOREIGN_TYPE_VOID
&& !return_p
)
434 else if (scm_is_eq (type
, sym_asterisk
))
441 len
= scm_ilength (type
);
446 if (!parse_ffi_type (scm_car (type
), 0, n_structs
, n_struct_elts
))
449 type
= scm_cdr (type
);
457 fill_ffi_type (SCM type
, ffi_type
*ftype
, ffi_type
***type_ptrs
,
460 if (SCM_I_INUMP (type
))
462 switch (SCM_I_INUM (type
))
464 case SCM_FOREIGN_TYPE_FLOAT
:
465 *ftype
= ffi_type_float
;
467 case SCM_FOREIGN_TYPE_DOUBLE
:
468 *ftype
= ffi_type_double
;
470 case SCM_FOREIGN_TYPE_UINT8
:
471 *ftype
= ffi_type_uint8
;
473 case SCM_FOREIGN_TYPE_INT8
:
474 *ftype
= ffi_type_sint8
;
476 case SCM_FOREIGN_TYPE_UINT16
:
477 *ftype
= ffi_type_uint16
;
479 case SCM_FOREIGN_TYPE_INT16
:
480 *ftype
= ffi_type_sint16
;
482 case SCM_FOREIGN_TYPE_UINT32
:
483 *ftype
= ffi_type_uint32
;
485 case SCM_FOREIGN_TYPE_INT32
:
486 *ftype
= ffi_type_sint32
;
488 case SCM_FOREIGN_TYPE_UINT64
:
489 *ftype
= ffi_type_uint64
;
491 case SCM_FOREIGN_TYPE_INT64
:
492 *ftype
= ffi_type_sint64
;
494 case SCM_FOREIGN_TYPE_VOID
:
495 *ftype
= ffi_type_void
;
498 scm_wrong_type_arg_msg ("make-foreign-function", 0, type
,
502 else if (scm_is_eq (type
, sym_asterisk
))
505 *ftype
= ffi_type_pointer
;
512 len
= scm_ilength (type
);
515 ftype
->alignment
= 0;
516 ftype
->type
= FFI_TYPE_STRUCT
;
517 ftype
->elements
= *type_ptrs
;
518 *type_ptrs
+= len
+ 1;
520 for (i
= 0; i
< len
; i
++)
522 ftype
->elements
[i
] = *types
;
524 fill_ffi_type (scm_car (type
), ftype
->elements
[i
],
526 type
= scm_cdr (type
);
528 ftype
->elements
[i
] = NULL
;
532 SCM_DEFINE (scm_make_foreign_function
, "make-foreign-function", 3, 0, 0,
533 (SCM return_type
, SCM func_ptr
, SCM arg_types
),
534 "Make a foreign function.\n\n"
535 "Given the foreign void pointer @var{func_ptr}, its argument and\n"
536 "return types @var{arg_types} and @var{return_type}, return a\n"
537 "procedure that will pass arguments to the foreign function\n"
538 "and return appropriate values.\n\n"
539 "@var{arg_types} should be a list of foreign types.\n"
540 "@code{return_type} should be a foreign type.")
541 #define FUNC_NAME s_scm_make_foreign_function
544 long i
, nargs
, n_structs
, n_struct_elts
;
548 ffi_type
**type_ptrs
;
551 SCM_VALIDATE_POINTER (2, func_ptr
);
553 nargs
= scm_ilength (arg_types
);
554 SCM_ASSERT (nargs
>= 0, arg_types
, 3, FUNC_NAME
);
555 /* fixme: assert nargs < 1<<32 */
556 n_structs
= n_struct_elts
= 0;
558 /* For want of talloc, we're going to have to do this in two passes: first we
559 figure out how much memory is needed for all types, then we allocate the
560 cif and the types all in one block. */
561 if (!parse_ffi_type (return_type
, 1, &n_structs
, &n_struct_elts
))
562 scm_wrong_type_arg (FUNC_NAME
, 1, return_type
);
563 for (walk
= arg_types
; scm_is_pair (walk
); walk
= scm_cdr (walk
))
564 if (!parse_ffi_type (scm_car (walk
), 0, &n_structs
, &n_struct_elts
))
565 scm_wrong_type_arg (FUNC_NAME
, 3, scm_car (walk
));
567 /* the memory: with space for the cif itself */
568 cif_len
= sizeof (ffi_cif
);
570 /* then ffi_type pointers: one for each arg, one for each struct
571 element, and one for each struct (for null-termination) */
572 cif_len
= (ROUND_UP (cif_len
, alignof(void*))
573 + (nargs
+ n_structs
+ n_struct_elts
)*sizeof(void*));
575 /* then the ffi_type structs themselves, one per arg and struct element, and
576 one for the return val */
577 cif_len
= (ROUND_UP (cif_len
, alignof(ffi_type
))
578 + (nargs
+ n_struct_elts
+ 1)*sizeof(ffi_type
));
580 mem
= scm_gc_malloc_pointerless (cif_len
, "foreign");
581 scm_cif
= scm_from_pointer (mem
, NULL
);
582 cif
= (ffi_cif
*) mem
;
584 /* reuse cif_len to walk through the mem */
585 cif_len
= ROUND_UP (sizeof (ffi_cif
), alignof(void*));
586 type_ptrs
= (ffi_type
**)(mem
+ cif_len
);
587 cif_len
= ROUND_UP (cif_len
588 + (nargs
+ n_structs
+ n_struct_elts
)*sizeof(void*),
590 types
= (ffi_type
*)(mem
+ cif_len
);
592 /* whew. now knit the pointers together. */
593 cif
->rtype
= types
++;
594 fill_ffi_type (return_type
, cif
->rtype
, &type_ptrs
, &types
);
595 cif
->arg_types
= type_ptrs
;
597 for (walk
= arg_types
, i
= 0; scm_is_pair (walk
); walk
= scm_cdr (walk
), i
++)
599 cif
->arg_types
[i
] = types
++;
600 fill_ffi_type (scm_car (walk
), cif
->arg_types
[i
], &type_ptrs
, &types
);
603 /* round out the cif, and we're done. */
604 cif
->abi
= FFI_DEFAULT_ABI
;
609 if (FFI_OK
!= ffi_prep_cif (cif
, FFI_DEFAULT_ABI
, cif
->nargs
, cif
->rtype
,
611 scm_misc_error (FUNC_NAME
, "ffi_prep_cif failed", SCM_EOL
);
613 return cif_to_procedure (scm_cif
, func_ptr
);
619 /* Pre-generate trampolines for less than 10 arguments. */
621 #ifdef WORDS_BIGENDIAN
622 #define OBJCODE_HEADER 0, 0, 0, 8, 0, 0, 0, 40
623 #define META_HEADER 0, 0, 0, 32, 0, 0, 0, 0
625 #define OBJCODE_HEADER 8, 0, 0, 0, 40, 0, 0, 0
626 #define META_HEADER 32, 0, 0, 0, 0, 0, 0, 0
631 /* 0 */ scm_op_assert_nargs_ee, 0, nreq, /* assert number of args */ \
632 /* 3 */ scm_op_object_ref, 0, /* push the pair with the cif and the function pointer */ \
633 /* 5 */ scm_op_foreign_call, nreq, /* and call (will return value as well) */ \
634 /* 7 */ scm_op_nop, \
635 /* 8 */ META (3, 7, nreq)
637 #define META(start, end, nreq) \
639 /* 0 */ scm_op_make_eol, /* bindings */ \
640 /* 1 */ scm_op_make_eol, /* sources */ \
641 /* 2 */ scm_op_make_int8, start, scm_op_make_int8, end, /* arity: from ip N to ip N */ \
642 /* 6 */ scm_op_make_int8, nreq, /* the arity is N required args */ \
643 /* 8 */ scm_op_list, 0, 3, /* make a list of those 3 vals */ \
644 /* 11 */ scm_op_list, 0, 1, /* and the arities will be a list of that one list */ \
645 /* 14 */ scm_op_load_symbol, 0, 0, 4, 'n', 'a', 'm', 'e', /* `name' */ \
646 /* 22 */ scm_op_object_ref, 1, /* the name from the object table */ \
647 /* 24 */ scm_op_cons, /* make a pair for the properties */ \
648 /* 25 */ scm_op_list, 0, 4, /* pack bindings, sources, and arities into list */ \
649 /* 28 */ scm_op_return, /* and return */ \
650 /* 29 */ scm_op_nop, scm_op_nop, scm_op_nop \
655 scm_t_uint64 dummy
; /* ensure 8-byte alignment; perhaps there's a better way */
656 const scm_t_uint8 bytes
[10 * (sizeof (struct scm_objcode
) + 8
657 + sizeof (struct scm_objcode
) + 32)];
661 CODE (0), CODE (1), CODE (2), CODE (3), CODE (4),
662 CODE (5), CODE (6), CODE (7), CODE (8), CODE (9)
668 #undef OBJCODE_HEADER
672 (defun generate-objcode-cells (n)
673 "Generate objcode cells for up to N arguments"
678 (format " { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + %d) },\n"
679 (* (+ 4 4 8 4 4 32) i)))
680 (insert " { SCM_BOOL_F, SCM_PACK (0) },\n")
683 #define STATIC_OBJCODE_TAG \
684 SCM_PACK (scm_tc7_objcode | (SCM_F_OBJCODE_IS_STATIC << 8))
688 scm_t_uint64 dummy
; /* alignment */
689 scm_t_cell cells
[10 * 2]; /* 10 double cells */
692 /* C-u 1 0 M-x generate-objcode-cells RET */
694 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 0) },
695 { SCM_BOOL_F
, SCM_PACK (0) },
696 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 56) },
697 { SCM_BOOL_F
, SCM_PACK (0) },
698 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 112) },
699 { SCM_BOOL_F
, SCM_PACK (0) },
700 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 168) },
701 { SCM_BOOL_F
, SCM_PACK (0) },
702 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 224) },
703 { SCM_BOOL_F
, SCM_PACK (0) },
704 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 280) },
705 { SCM_BOOL_F
, SCM_PACK (0) },
706 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 336) },
707 { SCM_BOOL_F
, SCM_PACK (0) },
708 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 392) },
709 { SCM_BOOL_F
, SCM_PACK (0) },
710 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 448) },
711 { SCM_BOOL_F
, SCM_PACK (0) },
712 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 504) },
713 { SCM_BOOL_F
, SCM_PACK (0) }
717 static const SCM objcode_trampolines
[10] = {
718 SCM_PACK (objcode_cells
.cells
+0),
719 SCM_PACK (objcode_cells
.cells
+2),
720 SCM_PACK (objcode_cells
.cells
+4),
721 SCM_PACK (objcode_cells
.cells
+6),
722 SCM_PACK (objcode_cells
.cells
+8),
723 SCM_PACK (objcode_cells
.cells
+10),
724 SCM_PACK (objcode_cells
.cells
+12),
725 SCM_PACK (objcode_cells
.cells
+14),
726 SCM_PACK (objcode_cells
.cells
+16),
727 SCM_PACK (objcode_cells
.cells
+18),
731 cif_to_procedure (SCM cif
, SCM func_ptr
)
735 SCM objcode
, table
, ret
;
737 c_cif
= (ffi_cif
*) SCM_POINTER_VALUE (cif
);
738 nargs
= c_cif
->nargs
;
741 objcode
= objcode_trampolines
[nargs
];
743 scm_misc_error ("make-foreign-function", "args >= 10 currently unimplemented",
746 table
= scm_c_make_vector (2, SCM_UNDEFINED
);
747 SCM_SIMPLE_VECTOR_SET (table
, 0, scm_cons (cif
, func_ptr
));
748 SCM_SIMPLE_VECTOR_SET (table
, 1, SCM_BOOL_F
); /* name */
749 ret
= scm_make_program (objcode
, table
, SCM_BOOL_F
);
754 /* Set *LOC to the foreign representation of X with TYPE. */
756 unpack (const ffi_type
*type
, void *loc
, SCM x
)
761 *(float *) loc
= scm_to_double (x
);
763 case FFI_TYPE_DOUBLE
:
764 *(double *) loc
= scm_to_double (x
);
767 *(scm_t_uint8
*) loc
= scm_to_uint8 (x
);
770 *(scm_t_int8
*) loc
= scm_to_int8 (x
);
772 case FFI_TYPE_UINT16
:
773 *(scm_t_uint16
*) loc
= scm_to_uint16 (x
);
775 case FFI_TYPE_SINT16
:
776 *(scm_t_int16
*) loc
= scm_to_int16 (x
);
778 case FFI_TYPE_UINT32
:
779 *(scm_t_uint32
*) loc
= scm_to_uint32 (x
);
781 case FFI_TYPE_SINT32
:
782 *(scm_t_int32
*) loc
= scm_to_int32 (x
);
784 case FFI_TYPE_UINT64
:
785 *(scm_t_uint64
*) loc
= scm_to_uint64 (x
);
787 case FFI_TYPE_SINT64
:
788 *(scm_t_int64
*) loc
= scm_to_int64 (x
);
790 case FFI_TYPE_STRUCT
:
791 memcpy (loc
, SCM_POINTER_VALUE (x
), type
->size
);
793 case FFI_TYPE_POINTER
:
794 *(void **) loc
= SCM_POINTER_VALUE (x
);
801 /* Return a Scheme representation of the foreign value at LOC of type TYPE. */
803 pack (const ffi_type
* type
, const void *loc
)
808 return SCM_UNSPECIFIED
;
810 return scm_from_double (*(float *) loc
);
811 case FFI_TYPE_DOUBLE
:
812 return scm_from_double (*(double *) loc
);
814 return scm_from_uint8 (*(scm_t_uint8
*) loc
);
816 return scm_from_int8 (*(scm_t_int8
*) loc
);
817 case FFI_TYPE_UINT16
:
818 return scm_from_uint16 (*(scm_t_uint16
*) loc
);
819 case FFI_TYPE_SINT16
:
820 return scm_from_int16 (*(scm_t_int16
*) loc
);
821 case FFI_TYPE_UINT32
:
822 return scm_from_uint32 (*(scm_t_uint32
*) loc
);
823 case FFI_TYPE_SINT32
:
824 return scm_from_int32 (*(scm_t_int32
*) loc
);
825 case FFI_TYPE_UINT64
:
826 return scm_from_uint64 (*(scm_t_uint64
*) loc
);
827 case FFI_TYPE_SINT64
:
828 return scm_from_int64 (*(scm_t_int64
*) loc
);
829 case FFI_TYPE_STRUCT
:
831 void *mem
= scm_gc_malloc_pointerless (type
->size
, "foreign");
832 memcpy (mem
, loc
, type
->size
);
833 return scm_from_pointer (mem
, NULL
);
835 case FFI_TYPE_POINTER
:
836 return scm_from_pointer (*(void **) loc
, NULL
);
844 scm_i_foreign_call (SCM foreign
, const SCM
*argv
)
846 /* FOREIGN is the pair that cif_to_procedure set as the 0th element of the
857 cif
= SCM_POINTER_VALUE (SCM_CAR (foreign
));
858 func
= SCM_POINTER_VALUE (SCM_CDR (foreign
));
860 /* Argument pointers. */
861 args
= alloca (sizeof (void *) * cif
->nargs
);
863 /* Compute the worst-case amount of memory needed to store all the argument
864 values. Note: as of libffi 3.0.9 `cif->bytes' is undocumented and is zero,
865 so it can't be used for that purpose. */
866 for (i
= 0, arg_size
= 0; i
< cif
->nargs
; i
++)
867 arg_size
+= cif
->arg_types
[i
]->size
+ cif
->arg_types
[i
]->alignment
- 1;
869 /* Space for argument values, followed by return value. */
870 data
= alloca (arg_size
+ cif
->rtype
->size
871 + max (sizeof (void *), cif
->rtype
->alignment
));
873 /* Unpack ARGV to native values, setting ARGV pointers. */
876 off
= (scm_t_uint8
*) args
[i
] - data
+ cif
->arg_types
[i
]->size
,
879 /* Suitably align the storage area for argument I. */
880 args
[i
] = (void *) ROUND_UP ((scm_t_uintptr
) data
+ off
,
881 cif
->arg_types
[i
]->alignment
);
882 assert ((scm_t_uintptr
) args
[i
] % cif
->arg_types
[i
]->alignment
== 0);
883 unpack (cif
->arg_types
[i
], args
[i
], argv
[i
]);
886 /* Prepare space for the return value. On some platforms, such as
887 `armv5tel-*-linux-gnueabi', the return value has to be at least
888 word-aligned, even if its type doesn't have any alignment requirement as is
889 the case with `char'. */
890 rvalue
= (void *) ROUND_UP ((scm_t_uintptr
) data
+ off
,
891 max (sizeof (void *), cif
->rtype
->alignment
));
894 ffi_call (cif
, func
, rvalue
, args
);
896 return pack (cif
->rtype
, rvalue
);
902 scm_init_foreign (void)
904 #ifndef SCM_MAGIC_SNARFER
905 #include "libguile/foreign.x"
907 scm_define (sym_void
, scm_from_uint8 (SCM_FOREIGN_TYPE_VOID
));
908 scm_define (sym_float
, scm_from_uint8 (SCM_FOREIGN_TYPE_FLOAT
));
909 scm_define (sym_double
, scm_from_uint8 (SCM_FOREIGN_TYPE_DOUBLE
));
910 scm_define (sym_uint8
, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT8
));
911 scm_define (sym_int8
, scm_from_uint8 (SCM_FOREIGN_TYPE_INT8
));
912 scm_define (sym_uint16
, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT16
));
913 scm_define (sym_int16
, scm_from_uint8 (SCM_FOREIGN_TYPE_INT16
));
914 scm_define (sym_uint32
, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32
));
915 scm_define (sym_int32
, scm_from_uint8 (SCM_FOREIGN_TYPE_INT32
));
916 scm_define (sym_uint64
, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64
));
917 scm_define (sym_int64
, scm_from_uint8 (SCM_FOREIGN_TYPE_INT64
));
921 scm_from_uint8 (SCM_FOREIGN_TYPE_INT64
)
922 #elif SIZEOF_INT == 4
923 scm_from_uint8 (SCM_FOREIGN_TYPE_INT32
)
925 # error unsupported sizeof (int)
929 scm_define (sym_unsigned_int
,
930 #if SIZEOF_UNSIGNED_INT == 8
931 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64
)
932 #elif SIZEOF_UNSIGNED_INT == 4
933 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32
)
935 # error unsupported sizeof (unsigned int)
939 scm_define (sym_long
,
941 scm_from_uint8 (SCM_FOREIGN_TYPE_INT64
)
942 #elif SIZEOF_LONG == 4
943 scm_from_uint8 (SCM_FOREIGN_TYPE_INT32
)
945 # error unsupported sizeof (long)
949 scm_define (sym_unsigned_long
,
950 #if SIZEOF_UNSIGNED_LONG == 8
951 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64
)
952 #elif SIZEOF_UNSIGNED_LONG == 4
953 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32
)
955 # error unsupported sizeof (unsigned long)
959 scm_define (sym_size_t
,
960 #if SIZEOF_SIZE_T == 8
961 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64
)
962 #elif SIZEOF_SIZE_T == 4
963 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32
)
965 # error unsupported sizeof (size_t)
969 null_pointer
= scm_cell (scm_tc7_pointer
, 0);
970 scm_define (sym_null
, null_pointer
);
974 scm_register_foreign (void)
976 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
978 (scm_t_extension_init_func
)scm_init_foreign
,
980 pointer_weak_refs
= scm_make_weak_key_hash_table (SCM_UNDEFINED
);