suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

ffi: fix use of struct malloc mode for function results

Browse Source 
Relevant to #2702
This commit is contained in:
Matthew Flatt 2019-06-17 14:51:12 -06:00
parent 1824fe5e41
commit 6184de2389
6 changed files with 216 additions and 85 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
pkgs/racket-doc/scribblings/foreign/types.scrbl
View File

@ -1188,7 +1188,11 @@ results.
@defproc[(make-cstruct-type [types (non-empty-listof ctype?)]
[abi (or/c #f 'default 'stdcall 'sysv) #f]
[alignment (or/c #f 1 2 4 8 16) #f])
[alignment (or/c #f 1 2 4 8 16) #f]
[malloc-mode (one-of/c 'raw 'atomic 'nonatomic 'tagged
'atomic-interior 'interior
'stubborn 'uncollectable 'eternal)
'atomic])
ctype?]{
The primitive type constructor for creating new C struct types. These
@ -1202,14 +1206,22 @@ known according to the given list of @racket[types] list.
If @racket[alignment] is @racket[#f], then the natural alignment of
each type in @racket[types] is used for its alignment within the
struct type. Otherwise, @racket[alignment] is used for all struct type
members.}
members.
The @racket[malloc-mode] argument is used when an instance of the type
is allocated to represent the result of a function call. This
allocation mode is @emph{not} used for an argument to a
@tech{callback}, because temporary space allocated on the C stack
(possibly by the calling convention) is used in that case.
@history[#:changed "7.3.0.8" @elem{Added the @racket[malloc-mode] argument.}]}
@defproc[(_list-struct [#:alignment alignment (or/c #f 1 2 4 8 16) #f]
[#:malloc-mode malloc-mode
(one-of/c 'raw 'atomic 'nonatomic 'tagged
'atomic-interior 'interior
'stubborn 'uncollectable 'eternal)
'atomic-interior 'interior
'stubborn 'uncollectable 'eternal)
'atomic]
[type ctype?] ...+)
ctype?]{
@ -1369,7 +1381,9 @@ addition for the new fields. This adjustment of the constructor is,
again, in analogy to using a supertype with @racket[define-struct].
Structs are allocated using @racket[malloc] with the result of
@racket[malloc-mode-expr], which default to @racket['atomic].
@racket[malloc-mode-expr], which defaults to @racket['atomic].
(This allocation mode does not apply to arguments of a @tech{callback};
see also @racket[define-cstruct-type].)
The default allocation of @racket['atomic] means that the
garbage collector ignores the content of a struct; thus, struct fields can hold
only non-pointer values, pointers to memory outside the GC's control,
@ -1642,7 +1656,8 @@ and from an underlying C array.}
The primitive type constructor for creating new C union types. Like C
struct types, union types are new primitive types with no conversion
functions associated. Unions are always treated like structs.
functions associated. Unions are always treated like structs with
@racket['atomic] allocation mode.
@examples[#:eval ffi-eval
(make-union-type (_list-struct _int _int)

11
pkgs/racket-test-core/tests/racket/foreign-test.rktl
View File

@ -307,6 +307,17 @@
(t 1212 'charint_to_int (_fun _charint -> _int) '(12 1200))
(t '(123 123) 'int_to_charint (_fun _int -> _charint) 123)
(t '(255 1) 'charint_swap (_fun _charint -> _charint) '(1 255)))
;; Make sure allocation mode is used for function result
(let ()
(define-cstruct _charint ([b _byte]
[i _int])
#:malloc-mode 'atomic-interior)
(define v ((ffi 'int_to_charint (_fun _int -> _charint)) 77))
(define addr (cast v _pointer _intptr))
(test 77 charint-b v)
(test 77 charint-b v)
(collect-garbage)
(test #t eqv? (cast v _pointer _intptr) addr))
;; ---
;; test sending a callback for C to hold, preventing the callback from GCing
(let ([with-keeper

4
racket/collects/ffi/unsafe.rkt
View File

@ -1545,7 +1545,7 @@
#:malloc-mode [malloc-mode 'atomic]
type . types)
(let* ([types (cons type types)]
[stype (make-cstruct-type types #f alignment)]
[stype (make-cstruct-type types #f alignment malloc-mode)]
[offsets (compute-offsets types alignment (map (lambda (x) #f) types))]
[len (length types)])
(make-ctype stype
@ -1725,7 +1725,7 @@
(define all-tags (cons ^TYPE-tag super-tags))
(define _TYPE
;; c->scheme adjusts all tags
(let* ([cst (make-cstruct-type types #f alignment-v)]
(let* ([cst (make-cstruct-type types #f alignment-v malloc-mode)]
[t (_cpointer ^TYPE-tag cst)]
[c->s (ctype-c->scheme t)])
(wrap-TYPE-type

33
racket/src/cs/rumble/foreign.ss
View File

@ -298,7 +298,8 @@
(parent ctype)
(fields get-decls
size
alignment))
alignment
malloc-mode))
(define/who (make-ctype type racket-to-c c-to-racket)
(check who ctype? type)
@ -313,7 +314,8 @@
c-to-racket
(compound-ctype-get-decls type)
(compound-ctype-size type)
(compound-ctype-alignment type))]
(compound-ctype-alignment type)
(compound-ctype-malloc-mode type))]
[else
(create-ctype (ctype-host-rep type)
(ctype-our-rep type)
@ -510,9 +512,10 @@
(define make-cstruct-type
(case-lambda
[(types) (make-cstruct-type types #f #f)]
[(types abi) (make-cstruct-type types abi #f)]
[(types abi alignment)
[(types) (make-cstruct-type types #f #f 'atomic)]
[(types abi) (make-cstruct-type types abi #f 'atomic)]
[(types abi alignment) (make-cstruct-type types abi alignment 'atomic)]
[(types abi alignment malloc-mode)
(let ([make-decls
(escapes-ok
(lambda (id next!-id)
@ -530,7 +533,8 @@
(lambda (c) (memory->cpointer c))
make-decls
size
alignment)))]))
alignment
malloc-mode)))]))
(define/who (make-union-type . types)
(for-each (lambda (type) (check who ctype? type))
@ -553,7 +557,8 @@
(lambda (c) (memory->cpointer c))
make-decls
size
alignment)))
alignment
'atomic)))
(define/who (make-array-type type count)
(check who ctype? type)
@ -577,7 +582,8 @@
(lambda (c) (memory->cpointer c))
make-decls
size
alignment)))
alignment
#f)))
(define (compiler-sizeof sl)
(let ([rest (lambda (sl) (if (pair? sl) (cdr sl) '()))])
@ -1570,6 +1576,7 @@
((compound-ctype-get-decls out-type) ret-id next!-id)
'())]
[ret-size (and ret-id (ctype-sizeof out-type))]
[ret-malloc-mode (and ret-id (compound-ctype-malloc-mode out-type))]
[gen-proc+ret-maker+arg-makers
(let ([expr `(let ()
,@decls
@ -1724,7 +1731,7 @@
orig-args in-types)]
[r (let ([ret-ptr (and ret-id
;; result is a struct type; need to allocate space for it
(make-bytevector ret-size))])
(normalized-malloc ret-size ret-malloc-mode))])
(when lock (mutex-acquire lock))
(with-interrupts-disabled
(when blocking? (currently-blocking? #t))
@ -1733,7 +1740,7 @@
(let ([r (#%apply (gen-proc (cpointer-address proc-p))
(append
(if ret-ptr
(list (ret-maker (memory-address ret-ptr)))
(list (ret-maker (cpointer-address ret-ptr)))
'())
(map (lambda (arg in-type maker)
(let ([host-rep (array-rep-to-pointer-rep
@ -1750,8 +1757,7 @@
[(posix) (thread-cell-set! errno-cell (get-errno))]
[(windows) (thread-cell-set! errno-cell (get-last-error))])
(cond
[ret-ptr
(make-cpointer ret-ptr #f)]
[ret-ptr ret-ptr]
[(eq? (ctype-our-rep out-type) 'gcpointer)
(addr->gcpointer-memory r)]
[else r])))))])
@ -1780,6 +1786,9 @@
[arg (c->s type
(case (ctype-host-rep type)
[(struct union)
;; Like old Racket, refer to argument on stack:
(make-cpointer (ftype-pointer-address arg) #f)
#;
(let* ([size (compound-ctype-size type)]
[addr (ftype-pointer-address arg)]
[bstr (make-bytevector size)])

128
racket/src/foreign/foreign.c
View File

@ -85,6 +85,20 @@
#include "ffi.h"
typedef void *(*Scheme_Malloc_Proc)(size_t);
static Scheme_Malloc_Proc mode_to_allocator(const char *who, Scheme_Object *mode);
static Scheme_Object *nonatomic_sym;
static Scheme_Object *atomic_sym;
static Scheme_Object *stubborn_sym;
static Scheme_Object *uncollectable_sym;
static Scheme_Object *eternal_sym;
static Scheme_Object *interior_sym;
static Scheme_Object *atomic_interior_sym;
static Scheme_Object *raw_sym;
static Scheme_Object *tagged_sym;
static Scheme_Object *fail_ok_sym;
#ifndef MZ_PRECISE_GC
# define XFORM_OK_PLUS +
# define GC_CAN_IGNORE /* empty */
@ -921,8 +935,8 @@ XFORM_NONGCING static int is_gcable_pointer(Scheme_Object *o) {
* struct types). If it is a user type then basetype will be another ctype,
* otherwise,
* - if it's a primitive type, then basetype will be a symbol naming that type
* - if it's a struct, then basetype will be the list of ctypes that
* made this struct
* - if it's a struct or union, then basetype will be the list of ctypes that
* made this struct, prefixed with a symbol if the allocation mode is not 'atomic
* scheme_to_c will have the &ffi_type pointer, and c_to_scheme will have an
* integer (a label value) for non-struct type. (Note that the
* integer is not really needed, since it is possible to identify the
@ -982,9 +996,15 @@ static ffi_type ffi_type_gcpointer;
#define MYNAME "ctype-basetype"
static Scheme_Object *foreign_ctype_basetype(int argc, Scheme_Object *argv[])
{
Scheme_Object *r;
if (!SCHEME_CTYPEP(argv[0]))
scheme_wrong_contract(MYNAME, "ctype?", 0, argc, argv);
return CTYPE_BASETYPE(argv[0]);
r = CTYPE_BASETYPE(argv[0]);
if (SCHEME_PAIRP(r) && SCHEME_SYMBOLP(SCHEME_CAR(r))) {
/* strip allocation mode for struct/union */
r = SCHEME_CDR(r);
}
return r;
}
#undef MYNAME
@ -1166,7 +1186,7 @@ static void wrong_void(const char *who, Scheme_Object *list_element, int specifi
NULL);
}
/* (make-cstruct-type types [abi alignment]) -> ctype */
/* (make-cstruct-type types [abi alignment malloc-mode]) -> ctype */
/* This creates a new primitive type that is a struct. This type can be used
* with cpointer objects, except that the contents is used rather than the
* pointer value. Marshaling to lists or whatever should be done in Racket. */
@ -1182,7 +1202,8 @@ static Scheme_Object *foreign_make_cstruct_type(int argc, Scheme_Object *argv[])
ffi_cif cif;
int i, nargs, with_alignment;
ffi_abi abi;
nargs = scheme_proper_list_length(argv[0]);
Scheme_Object *fields = argv[0];
nargs = scheme_proper_list_length(fields);
if (nargs <= 0) scheme_wrong_contract(MYNAME, "(non-empty-listof ctype?)", 0, argc, argv);
abi = GET_ABI(MYNAME,1);
if (argc > 2) {
@ -1196,9 +1217,16 @@ static Scheme_Object *foreign_make_cstruct_type(int argc, Scheme_Object *argv[])
with_alignment = SCHEME_INT_VAL(argv[2]);
} else
with_alignment = 0;
if (argc > 3) {
if (!SAME_OBJ(argv[3], atomic_sym)) {
(void)mode_to_allocator(MYNAME, argv[3]);
fields = scheme_make_pair(argv[3], fields);
}
}
} else
with_alignment = 0;
/* allocate the type elements */
/* allocate the type elements */
elements = malloc((nargs+1) * sizeof(ffi_type*));
elements[nargs] = NULL;
for (i=0, p=argv[0]; i<nargs; i++, p=SCHEME_CDR(p)) {
@ -1216,6 +1244,7 @@ static Scheme_Object *foreign_make_cstruct_type(int argc, Scheme_Object *argv[])
elements[i]->alignment = with_alignment;
}
}
/* allocate the new libffi type object */
libffi_type = malloc(sizeof(ffi_type));
libffi_type->size = 0;
@ -1228,7 +1257,7 @@ static Scheme_Object *foreign_make_cstruct_type(int argc, Scheme_Object *argv[])
scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
type = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
type->so.type = ctype_tag;
type->basetype = (argv[0]);
type->basetype = (fields);
type->scheme_to_c = ((Scheme_Object*)libffi_type);
type->c_to_scheme = ((Scheme_Object*)FOREIGN_struct);
if (with_alignment)
@ -2579,16 +2608,42 @@ static Scheme_Object *foreign_compiler_sizeof(int argc, Scheme_Object *argv[])
/*****************************************************************************/
/* Pointer type user functions */
static Scheme_Object *nonatomic_sym;
static Scheme_Object *atomic_sym;
static Scheme_Object *stubborn_sym;
static Scheme_Object *uncollectable_sym;
static Scheme_Object *eternal_sym;
static Scheme_Object *interior_sym;
static Scheme_Object *atomic_interior_sym;
static Scheme_Object *raw_sym;
static Scheme_Object *tagged_sym;
static Scheme_Object *fail_ok_sym;
static Scheme_Malloc_Proc mode_to_allocator(const char *who, Scheme_Object *mode)
{
Scheme_Malloc_Proc mf;
if (SAME_OBJ(mode, nonatomic_sym)) mf = scheme_malloc;
else if (SAME_OBJ(mode, atomic_sym)) mf = scheme_malloc_atomic;
else if (SAME_OBJ(mode, stubborn_sym)) mf = scheme_malloc_stubborn;
else if (SAME_OBJ(mode, eternal_sym)) mf = scheme_malloc_eternal;
else if (SAME_OBJ(mode, uncollectable_sym)) mf = scheme_malloc_uncollectable;
else if (SAME_OBJ(mode, interior_sym)) mf = scheme_malloc_allow_interior;
else if (SAME_OBJ(mode, atomic_interior_sym)) mf = scheme_malloc_atomic_allow_interior;
else if (SAME_OBJ(mode, raw_sym)) mf = malloc;
else if (SAME_OBJ(mode, tagged_sym)) mf = scheme_malloc_tagged;
else {
scheme_signal_error("%s: bad allocation mode: %V", who, mode);
return NULL; /* hush the compiler */
}
return mf;
}
static Scheme_Malloc_Proc ctype_allocator(Scheme_Object *type)
{
Scheme_Object *mode;
mode = CTYPE_BASETYPE(type);
if (!SCHEME_PAIRP(mode))
mode = atomic_sym;
else {
mode = SCHEME_CAR(mode);
if (!SCHEME_SYMBOLP(mode))
mode = atomic_sym;
}
return mode_to_allocator("_struct", mode);
}
/* (malloc num type cpointer mode) -> pointer */
/* The arguments for this function are:
@ -2612,7 +2667,7 @@ static Scheme_Object *foreign_malloc(int argc, Scheme_Object *argv[])
void *from = NULL, *res = NULL;
intptr_t foff = 0;
Scheme_Object *mode = NULL, *a, *base = NULL;
void *(*mf)(size_t);
Scheme_Malloc_Proc mf;
for (i=0; i<argc; i++) {
a = argv[i];
a = unwrap_cpointer_property(argv[i]);
@ -2660,19 +2715,8 @@ static Scheme_Object *foreign_malloc(int argc, Scheme_Object *argv[])
if (mode == NULL)
mf = (base != NULL && CTYPE_PRIMTYPE(base) == &ffi_type_gcpointer)
? scheme_malloc : scheme_malloc_atomic;
else if (SAME_OBJ(mode, nonatomic_sym)) mf = scheme_malloc;
else if (SAME_OBJ(mode, atomic_sym)) mf = scheme_malloc_atomic;
else if (SAME_OBJ(mode, stubborn_sym)) mf = scheme_malloc_stubborn;
else if (SAME_OBJ(mode, eternal_sym)) mf = scheme_malloc_eternal;
else if (SAME_OBJ(mode, uncollectable_sym)) mf = scheme_malloc_uncollectable;
else if (SAME_OBJ(mode, interior_sym)) mf = scheme_malloc_allow_interior;
else if (SAME_OBJ(mode, atomic_interior_sym)) mf = scheme_malloc_atomic_allow_interior;
else if (SAME_OBJ(mode, raw_sym)) mf = malloc;
else if (SAME_OBJ(mode, tagged_sym)) mf = scheme_malloc_tagged;
else {
scheme_signal_error(MYNAME": bad allocation mode: %V", mode);
return NULL; /* hush the compiler */
}
else
mf = mode_to_allocator(MYNAME, mode);
res = scheme_malloc_fail_ok(mf,size);
if (failok && (res == NULL)) scheme_signal_error("malloc: out of memory");
@ -3586,7 +3630,11 @@ static Scheme_Object *ffi_do_call(int argc, Scheme_Object *argv[], Scheme_Object
|| (CTYPE_PRIMLABEL(base) == FOREIGN_union)) {
/* need to have p be a pointer that is invisible to the GC */
p = malloc(CTYPE_PRIMTYPE(base)->size);
newp = scheme_malloc_atomic(CTYPE_PRIMTYPE(base)->size);
{
Scheme_Malloc_Proc mf;
mf = ctype_allocator(base);
newp = mf(CTYPE_PRIMTYPE(base)->size);
}
} else {
p = &oval;
newp = NULL;
@ -4807,12 +4855,6 @@ void scheme_init_foreign_globals()
GC_register_traversers(ffi_callback_tag, ffi_callback_SIZE, ffi_callback_MARK, ffi_callback_FIXUP, 1, 0);
# endif /* MZ_PRECISE_GC */
scheme_set_type_printer(scheme_ctype_type, ctype_printer);
MZ_REGISTER_STATIC(default_sym);
default_sym = scheme_intern_symbol("default");
MZ_REGISTER_STATIC(stdcall_sym);
stdcall_sym = scheme_intern_symbol("stdcall");
MZ_REGISTER_STATIC(sysv_sym);
sysv_sym = scheme_intern_symbol("sysv");
MZ_REGISTER_STATIC(nonatomic_sym);
nonatomic_sym = scheme_intern_symbol("nonatomic");
MZ_REGISTER_STATIC(atomic_sym);
@ -4833,6 +4875,12 @@ void scheme_init_foreign_globals()
tagged_sym = scheme_intern_symbol("tagged");
MZ_REGISTER_STATIC(fail_ok_sym);
fail_ok_sym = scheme_intern_symbol("fail-ok");
MZ_REGISTER_STATIC(default_sym);
default_sym = scheme_intern_symbol("default");
MZ_REGISTER_STATIC(stdcall_sym);
stdcall_sym = scheme_intern_symbol("stdcall");
MZ_REGISTER_STATIC(sysv_sym);
sysv_sym = scheme_intern_symbol("sysv");
MZ_REGISTER_STATIC(abs_sym);
abs_sym = scheme_intern_symbol("abs");
@ -4915,7 +4963,7 @@ void scheme_init_foreign(Scheme_Startup_Env *env)
scheme_addto_prim_instance("make-ctype",
scheme_make_noncm_prim(foreign_make_ctype, "make-ctype", 3, 3), env);
scheme_addto_prim_instance("make-cstruct-type",
scheme_make_noncm_prim(foreign_make_cstruct_type, "make-cstruct-type", 1, 3), env);
scheme_make_noncm_prim(foreign_make_cstruct_type, "make-cstruct-type", 1, 4), env);
scheme_addto_prim_instance("make-array-type",
scheme_make_noncm_prim(foreign_make_array_type, "make-array-type", 2, 2), env);
scheme_addto_prim_instance("make-union-type",
@ -5280,7 +5328,7 @@ void scheme_init_foreign(Scheme_Env *env)
scheme_addto_primitive_instance("make-ctype",
scheme_make_noncm_prim((Scheme_Prim *)foreign_make_ctype, "make-ctype", 3, 3), env);
scheme_addto_primitive_instance("make-cstruct-type",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "make-cstruct-type", 1, 3), env);
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "make-cstruct-type", 1, 4), env);
scheme_addto_primitive_instance("make-array-type",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "make-array-type", 2, 2), env);
scheme_addto_primitive_instance("make-union-type",

98
racket/src/foreign/foreign.rktc
View File

@ -88,6 +88,12 @@ exec racket "$0" > `echo "$0" | sed 's/rktc$/c/'` "$0"
#include "ffi.h"
typedef void *(*Scheme_Malloc_Proc)(size_t);
static Scheme_Malloc_Proc mode_to_allocator(const char *who, Scheme_Object *mode);
@defsymbols[nonatomic atomic stubborn uncollectable eternal
interior atomic-interior raw tagged fail-ok]
#ifndef MZ_PRECISE_GC
# define XFORM_OK_PLUS +
# define GC_CAN_IGNORE /* empty */
@ -827,8 +833,8 @@ XFORM_NONGCING static int is_gcable_pointer(Scheme_Object *o) {
* struct types). If it is a user type then basetype will be another ctype,
* otherwise,
* - if it's a primitive type, then basetype will be a symbol naming that type
* - if it's a struct, then basetype will be the list of ctypes that
* made this struct
* - if it's a struct or union, then basetype will be the list of ctypes that
* made this struct, prefixed with a symbol if the allocation mode is not 'atomic
* scheme_to_c will have the &ffi_type pointer, and c_to_scheme will have an
* integer (a label value) for non-struct type. (Note that the
* integer is not really needed, since it is possible to identify the
@ -853,9 +859,15 @@ static ffi_type ffi_type_gcpointer;
/* Returns #f for primitive types. */
@cdefine[ctype-basetype 1 #:kind immed]{
Scheme_Object *r;
if (!SCHEME_CTYPEP(argv[0]))
scheme_wrong_contract(MYNAME, "ctype?", 0, argc, argv);
return CTYPE_BASETYPE(argv[0]);
r = CTYPE_BASETYPE(argv[0]);
if (SCHEME_PAIRP(r) && SCHEME_SYMBOLP(SCHEME_CAR(r))) {
/* strip allocation mode for struct/union */
r = SCHEME_CDR(r);
}
return r;
}
@cdefine[ctype-scheme->c 1 #:kind immed]{
@ -995,11 +1007,11 @@ static void wrong_void(const char *who, Scheme_Object *list_element, int specifi
NULL);
}
/* (make-cstruct-type types [abi alignment]) -> ctype */
/* (make-cstruct-type types [abi alignment malloc-mode]) -> ctype */
/* This creates a new primitive type that is a struct. This type can be used
* with cpointer objects, except that the contents is used rather than the
* pointer value. Marshaling to lists or whatever should be done in Racket. */
@cdefine[make-cstruct-type 1 3]{
@cdefine[make-cstruct-type 1 4]{
Scheme_Object *p, *base;
/* since ffi_type objects can be used in callbacks, they are allocated using
* malloc so they don't move, and they are freed when the Scheme object is
@ -1009,7 +1021,8 @@ static void wrong_void(const char *who, Scheme_Object *list_element, int specifi
ffi_cif cif;
int i, nargs, with_alignment;
ffi_abi abi;
nargs = scheme_proper_list_length(argv[0]);
Scheme_Object *fields = argv[0];
nargs = scheme_proper_list_length(fields);
if (nargs <= 0) scheme_wrong_contract(MYNAME, "(non-empty-listof ctype?)", 0, argc, argv);
abi = GET_ABI(MYNAME,1);
if (argc > 2) {
@ -1023,9 +1036,16 @@ static void wrong_void(const char *who, Scheme_Object *list_element, int specifi
with_alignment = SCHEME_INT_VAL(argv[2]);
} else
with_alignment = 0;
if (argc > 3) {
if (!SAME_OBJ(argv[3], atomic_sym)) {
(void)mode_to_allocator(MYNAME, argv[3]);
fields = scheme_make_pair(argv[3], fields);
}
}
} else
with_alignment = 0;
/* allocate the type elements */
/* allocate the type elements */
elements = malloc((nargs+1) * sizeof(ffi_type*));
elements[nargs] = NULL;
for (i=0, p=argv[0]; i<nargs; i++, p=SCHEME_CDR(p)) {
@ -1043,6 +1063,7 @@ static void wrong_void(const char *who, Scheme_Object *list_element, int specifi
elements[i]->alignment = with_alignment;
}
}
/* allocate the new libffi type object */
libffi_type = malloc(sizeof(ffi_type));
libffi_type->size = 0;
@ -1053,7 +1074,7 @@ static void wrong_void(const char *who, Scheme_Object *list_element, int specifi
dummy = &libffi_type;
if (ffi_prep_cif(&cif, abi, 1, &ffi_type_void, dummy) != FFI_OK)
scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
@cmake["type" ctype "argv[0]"
@cmake["type" ctype "fields"
"(Scheme_Object*)libffi_type"
"(Scheme_Object*)FOREIGN_struct"]
if (with_alignment)
@ -1828,8 +1849,42 @@ static void* SCHEME2C(const char *who,
/*****************************************************************************/
/* Pointer type user functions */
@defsymbols[nonatomic atomic stubborn uncollectable eternal
interior atomic-interior raw tagged fail-ok]
static Scheme_Malloc_Proc mode_to_allocator(const char *who, Scheme_Object *mode)
{
Scheme_Malloc_Proc mf;
if (SAME_OBJ(mode, nonatomic_sym)) mf = scheme_malloc;
else if (SAME_OBJ(mode, atomic_sym)) mf = scheme_malloc_atomic;
else if (SAME_OBJ(mode, stubborn_sym)) mf = scheme_malloc_stubborn;
else if (SAME_OBJ(mode, eternal_sym)) mf = scheme_malloc_eternal;
else if (SAME_OBJ(mode, uncollectable_sym)) mf = scheme_malloc_uncollectable;
else if (SAME_OBJ(mode, interior_sym)) mf = scheme_malloc_allow_interior;
else if (SAME_OBJ(mode, atomic_interior_sym)) mf = scheme_malloc_atomic_allow_interior;
else if (SAME_OBJ(mode, raw_sym)) mf = malloc;
else if (SAME_OBJ(mode, tagged_sym)) mf = scheme_malloc_tagged;
else {
scheme_signal_error("%s: bad allocation mode: %V", who, mode);
return NULL; /* hush the compiler */
}
return mf;
}
static Scheme_Malloc_Proc ctype_allocator(Scheme_Object *type)
{
Scheme_Object *mode;
mode = CTYPE_BASETYPE(type);
if (!SCHEME_PAIRP(mode))
mode = atomic_sym;
else {
mode = SCHEME_CAR(mode);
if (!SCHEME_SYMBOLP(mode))
mode = atomic_sym;
}
return mode_to_allocator("_struct", mode);
}
/* (malloc num type cpointer mode) -> pointer */
/* The arguments for this function are:
@ -1851,7 +1906,7 @@ static void* SCHEME2C(const char *who,
void *from = NULL, *res = NULL;
intptr_t foff = 0;
Scheme_Object *mode = NULL, *a, *base = NULL;
void *(*mf)(size_t);
Scheme_Malloc_Proc mf;
for (i=0; i<argc; i++) {
a = argv[i];
a = unwrap_cpointer_property(argv[i]);
@ -1899,19 +1954,8 @@ static void* SCHEME2C(const char *who,
if (mode == NULL)
mf = (base != NULL && CTYPE_PRIMTYPE(base) == &ffi_type_gcpointer)
? scheme_malloc : scheme_malloc_atomic;
else if (SAME_OBJ(mode, nonatomic_sym)) mf = scheme_malloc;
else if (SAME_OBJ(mode, atomic_sym)) mf = scheme_malloc_atomic;
else if (SAME_OBJ(mode, stubborn_sym)) mf = scheme_malloc_stubborn;
else if (SAME_OBJ(mode, eternal_sym)) mf = scheme_malloc_eternal;
else if (SAME_OBJ(mode, uncollectable_sym)) mf = scheme_malloc_uncollectable;
else if (SAME_OBJ(mode, interior_sym)) mf = scheme_malloc_allow_interior;
else if (SAME_OBJ(mode, atomic_interior_sym)) mf = scheme_malloc_atomic_allow_interior;
else if (SAME_OBJ(mode, raw_sym)) mf = malloc;
else if (SAME_OBJ(mode, tagged_sym)) mf = scheme_malloc_tagged;
else {
scheme_signal_error(MYNAME": bad allocation mode: %V", mode);
return NULL; /* hush the compiler */
}
else
mf = mode_to_allocator(MYNAME, mode);
res = scheme_malloc_fail_ok(mf,size);
if (failok && (res == NULL)) scheme_signal_error("malloc: out of memory");
@ -2757,7 +2801,11 @@ static Scheme_Object *ffi_do_call(int argc, Scheme_Object *argv[], Scheme_Object
|| (CTYPE_PRIMLABEL(base) == FOREIGN_union)) {
/* need to have p be a pointer that is invisible to the GC */
p = malloc(CTYPE_PRIMTYPE(base)->size);
newp = scheme_malloc_atomic(CTYPE_PRIMTYPE(base)->size);
{
Scheme_Malloc_Proc mf;
mf = ctype_allocator(base);
newp = mf(CTYPE_PRIMTYPE(base)->size);
}
} else {
p = &oval;
newp = NULL;