From 6184de2389f2b13224234e54254aae1e43dc67d1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 17 Jun 2019 14:51:12 -0600 Subject: [PATCH] ffi: fix use of struct malloc mode for function results Relevant to #2702 --- .../scribblings/foreign/types.scrbl | 27 +++- .../tests/racket/foreign-test.rktl | 11 ++ racket/collects/ffi/unsafe.rkt | 4 +- racket/src/cs/rumble/foreign.ss | 33 +++-- racket/src/foreign/foreign.c | 128 ++++++++++++------ racket/src/foreign/foreign.rktc | 98 ++++++++++---- 6 files changed, 216 insertions(+), 85 deletions(-) diff --git a/pkgs/racket-doc/scribblings/foreign/types.scrbl b/pkgs/racket-doc/scribblings/foreign/types.scrbl index bbcab35872..ea95015b7b 100644 --- a/pkgs/racket-doc/scribblings/foreign/types.scrbl +++ b/pkgs/racket-doc/scribblings/foreign/types.scrbl @@ -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) diff --git a/pkgs/racket-test-core/tests/racket/foreign-test.rktl b/pkgs/racket-test-core/tests/racket/foreign-test.rktl index 71fe4a0371..3bb88b0bc1 100644 --- a/pkgs/racket-test-core/tests/racket/foreign-test.rktl +++ b/pkgs/racket-test-core/tests/racket/foreign-test.rktl @@ -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 diff --git a/racket/collects/ffi/unsafe.rkt b/racket/collects/ffi/unsafe.rkt index df0b066637..0dab11803d 100644 --- a/racket/collects/ffi/unsafe.rkt +++ b/racket/collects/ffi/unsafe.rkt @@ -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 diff --git a/racket/src/cs/rumble/foreign.ss b/racket/src/cs/rumble/foreign.ss index ebe57fd76a..4c9883210f 100644 --- a/racket/src/cs/rumble/foreign.ss +++ b/racket/src/cs/rumble/foreign.ss @@ -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)]) diff --git a/racket/src/foreign/foreign.c b/racket/src/foreign/foreign.c index 0905744d4c..05da18831a 100644 --- a/racket/src/foreign/foreign.c +++ b/racket/src/foreign/foreign.c @@ -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]; ialignment = 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; isize); - 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", diff --git a/racket/src/foreign/foreign.rktc b/racket/src/foreign/foreign.rktc index b5033d7d41..2407576122 100755 --- a/racket/src/foreign/foreign.rktc +++ b/racket/src/foreign/foreign.rktc @@ -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]; ialignment = 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; isize); - 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;