diff --git a/collects/scheme/foreign.ss b/collects/scheme/foreign.ss index a1aff1dfdb..49574f088e 100644 --- a/collects/scheme/foreign.ss +++ b/collects/scheme/foreign.ss @@ -62,13 +62,13 @@ (provide* ctype-sizeof ctype-alignof compiler-sizeof (unsafe malloc) (unsafe free) (unsafe end-stubborn-change) - cpointer? ptr-equal? ptr-add (unsafe ptr-ref) (unsafe ptr-set!) + cpointer? ptr-equal? ptr-add (unsafe ptr-ref) (unsafe ptr-set!) (unsafe cast) ptr-offset ptr-add! offset-ptr? set-ptr-offset! ctype? make-ctype make-cstruct-type (unsafe make-sized-byte-string) ctype->layout _void _int8 _uint8 _int16 _uint16 _int32 _uint32 _int64 _uint64 _fixint _ufixint _fixnum _ufixnum _float _double _double* - _bool _pointer _scheme _fpointer function-ptr + _bool _pointer _gcpointer _scheme _fpointer function-ptr (unsafe memcpy) (unsafe memmove) (unsafe memset) (unsafe malloc-immobile-cell) (unsafe free-immobile-cell)) @@ -1257,6 +1257,49 @@ ;; Similar to the above, but can tolerate null pointers (#f). (define* _cpointer/null (cpointer-maker #t)) +(define (cast p from-type to-type) + (unless (ctype? from-type) + (raise-type-error 'cast "ctype" from-type)) + (unless (ctype? to-type) + (raise-type-error 'cast "ctype" to-type)) + (unless (= (ctype-sizeof to-type) + (ctype-sizeof from-type)) + (raise-mismatch-error (format "representation sizes of types differ: ~e to " + from-type) + to-type)) + (let ([p2 (malloc from-type)]) + (ptr-set! p2 from-type p) + (ptr-ref p2 to-type))) + +(define* (_or-null ctype) + (let ([coretype (ctype-coretype ctype)]) + (unless (memq coretype '(pointer gcpointer fpointer)) + (raise-type-error '_or-null "ctype buit on pointer, gcpointer, or fpointer" ctype)) + (make-ctype + (case coretype + [(pointer) _pointer] + [(gcpointer) _gcpointer] + [(fpointer) _fpointer]) + (lambda (v) (and v (cast _pointer v))) + (lambda (v) (and v (cast ctype v)))))) + +(define* (_gcable ctype) + (unless (memq (ctype-coretype ctype) '(pointer gcpointer)) + (raise-type-error '_or-null "pointer ctype" ctype)) + (let loop ([ctype ctype]) + (if (eq? ctype 'pointer) + _gcpointer + (make-ctype + (loop (ctype-basetype ctype)) + (ctype-scheme->c ctype) + (ctype-c->scheme ctype))))) + +(define (ctype-coretype c) + (let loop ([c (ctype-basetype c)]) + (if (symbol? c) + c + (loop c)))) + ;; A macro version of the above two functions, using the defined name for a tag ;; string, and defining a predicate too. The name should look like `_foo', the ;; predicate will be `foo?', and the tag will be "foo". In addition, `foo-tag' diff --git a/collects/scribblings/foreign/derived.scrbl b/collects/scribblings/foreign/derived.scrbl index 8ff776dd5a..dcc6ba33f7 100644 --- a/collects/scribblings/foreign/derived.scrbl +++ b/collects/scribblings/foreign/derived.scrbl @@ -9,12 +9,12 @@ The unsafe @scheme[cpointer-has-tag?] and @scheme[cpointer-push-tag!] operations manage tags to distinguish pointer types. @defproc*[([(_cpointer [tag any/c] - [ptr-type ctype? _pointer] + [ptr-type ctype? _xpointer] [scheme-to-c (any/c . -> . any/c) values] [c-to-scheme (any/c . -> . any/c) values]) ctype] [(_cpointer/null [tag any/c] - [ptr-type ctype? _pointer] + [ptr-type ctype? _xpointer] [scheme-to-c (any/c . -> . any/c) values] [c-to-scheme (any/c . -> . any/c) values]) ctype])]{ diff --git a/collects/scribblings/foreign/misc.scrbl b/collects/scribblings/foreign/misc.scrbl index 850e89b714..f8126ebf5a 100644 --- a/collects/scribblings/foreign/misc.scrbl +++ b/collects/scribblings/foreign/misc.scrbl @@ -54,6 +54,20 @@ Like @scheme[list->cblock], but for Scheme vectors.} @section{Unsafe Miscellaneous Operations} +@defproc[(cast [v any/c][from-type ctype?][to-type ctype?]) any/c]{ + +Converts @scheme[v] from a value matching @scheme[from-type] to a +value matching @scheme[to-type], where @scheme[(ctype-size from-type)] +matches @scheme[(ctype-size to-type)]. + +The conversion is equivalent to + +@schemeblock[ + (let ([p (malloc from-type)]) + (ptr-set! p from-type v) + (ptr-ref p to-type)) +]} + @defproc[(cblock->list [cblock any/c][type ctype?][length exact-nonnegative-integer?]) list?]{ diff --git a/collects/scribblings/foreign/pointers.scrbl b/collects/scribblings/foreign/pointers.scrbl index ba8f738bc8..7f89e01118 100644 --- a/collects/scribblings/foreign/pointers.scrbl +++ b/collects/scribblings/foreign/pointers.scrbl @@ -260,8 +260,8 @@ specification is required at minimum: ] If no mode is specified, then @scheme['nonatomic] allocation is used -when the type is any pointer-based type, and @scheme['atomic] -allocation is used otherwise.} +when the type is a @scheme[_gcpointer]- or @scheme[_scheme]-based +type, and @scheme['atomic] allocation is used otherwise.} @defproc[(free [cptr cpointer?]) void]{ diff --git a/collects/scribblings/foreign/types.scrbl b/collects/scribblings/foreign/types.scrbl index 418e1ecb5a..44dc8a04eb 100644 --- a/collects/scribblings/foreign/types.scrbl +++ b/collects/scribblings/foreign/types.scrbl @@ -271,7 +271,28 @@ Corresponds to Scheme ``C pointer'' objects. These pointers can have an arbitrary Scheme object attached as a type tag. The tag is ignored by built-in functionality; it is intended to be used by interfaces. See @secref["foreign:tagged-pointers"] for creating pointer types that -use these tags for safety.} +use these tags for safety. A @scheme[#f] value is converted to +@cpp{NULL} and vice-versa. + +The address referenced by a @scheme[_pointer] value must not refer to +memory managed by the garbage collector (unless the address +corresponds to a value that supports interior pointers and that is +otherwise referenced to preserve the value from garbage collection). +The reference is not traced or updated by the garbage collector.} + + +@defthing[_gcpointer ctype?]{ + +Like @scheme[_pointer], but for a value that can refer to memory +managed by the garbage collector. + +Although a @scheme[_gcpointer] can reference to memory that is not +managed by the garbage collector, beware of using an address that +might eventually become managed by the garbage collector. For example, +if a reference is created by @scheme[malloc] with @scheme['raw] and +released by @scheme[free], then the @scheme[free] may allow the memory +formerly occupied by the reference to be used later by the garbage +collector.} @defthing[_scheme ctype?]{ @@ -295,6 +316,24 @@ A type generated by @scheme[_cprocedure] builds on @scheme[_fpointer], and normally @scheme[_cprocedure] should be used instead of @scheme[_fpointer].} + +@defproc[(_or-null [ctype ctype?]) ctype?]{ + +Creates a type that is like @scheme[ctype], but @scheme[#f] is +converted to @cpp{NULL} and vice-versa. The given @scheme[ctype] must +have the same C representation as @scheme[_pointer], +@scheme[_gcpointer], or @scheme[_fpointer].} + + +@defproc[(_gcable [ctype ctype?]) ctype?]{ + +Creates a type that is like @scheme[ctype], but whose base +representation is like @scheme[_gcpointer] instead of +@scheme[_pointer]. The given @scheme[ctype] must have a base +representation like @scheme[_pointer] or @scheme[_gcpointer] (and in +the later case, the result is the @scheme[ctype]).} + + @; ------------------------------------------------------------ @section[#:tag "foreign:procedures"]{Function Types} diff --git a/collects/scribblings/inside/values.scrbl b/collects/scribblings/inside/values.scrbl index e23b5df914..08527b6f36 100644 --- a/collects/scribblings/inside/values.scrbl +++ b/collects/scribblings/inside/values.scrbl @@ -667,7 +667,21 @@ Creates a C-pointer object that encapsulates @var{ptr} and uses the original @var{ptr} from the Scheme object, and @cppi{SCHEME_CPTR_TYPE} extracts the type tag. The @cppi{SCHEME_CPTR_OFFSETVAL} macro returns @cpp{0} - for the result Scheme object.} + for the result Scheme object. + + The @var{ptr} can refer to either memory managed by the garbage + collector or by some other memory manager. Beware, however, of + retaining a @var{ptr} that refers to memory released by another + memory manager, since the enclosing memory range might later become + managed by the garbage collector (in which case @var{ptr} might + become an invalid pointer that can crash the garbage collector).} + +@function[(Scheme_Object* scheme_make_external_cptr + [void* ptr] + [const-Scheme_Object* typetag])]{ + +Like @cpp{scheme_make_cptr}, but @var{ptr} is never treated as +referencing memory managed by the garbage collector.} @function[(Scheme_Object* scheme_make_offset_cptr [void* ptr] @@ -677,7 +691,20 @@ Creates a C-pointer object that encapsulates @var{ptr} and uses Creates a C-pointer object that encapsulates both @var{ptr} and @var{offset}. The @cppi{SCHEME_CPTR_OFFSETVAL} macro returns @var{offset} for the result Scheme object (and the macro be used to change the offset, - since it also works on objects with no offset).} + since it also works on objects with no offset). + + The @var{ptr} can refer to either memory managed by the garbage + collector or by some other memory manager; see also + @cpp{scheme_make_cptr}.} + +@function[(Scheme_Object* scheme_make_offset_external_cptr + [void* ptr] + [long offset] + [const-Scheme_Object* typetag])]{ + + Like @cpp{scheme_make_offset_cptr}, but @var{ptr} is never treated as +referencing memory managed by the garbage collector.} + @function[(void scheme_set_type_printer [Scheme_Type type] diff --git a/src/foreign/foreign.c b/src/foreign/foreign.c index b5c486d98d..f3360898fc 100644 --- a/src/foreign/foreign.c +++ b/src/foreign/foreign.c @@ -766,14 +766,24 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) * Predicate: SCHEME_FFIANYPTRP() * Scheme->C: SCHEME_FFIANYPTR_VAL() * S->C offset: FFIANYPTR + * C->Scheme: scheme_make_foreign_external_cpointer() + */ + +#define FOREIGN_gcpointer (24) +/* Type Name: gcpointer + * LibFfi type: ffi_type_gcpointer + * C type: void* + * Predicate: SCHEME_FFIANYPTRP() + * Scheme->C: SCHEME_FFIANYPTR_VAL() + * S->C offset: FFIANYPTR * C->Scheme: scheme_make_foreign_cpointer() */ /* This is used for passing and Scheme_Object* value as is. Useful for * functions that know about Scheme_Object*s, like MzScheme's. */ -#define FOREIGN_scheme (24) +#define FOREIGN_scheme (25) /* Type Name: scheme - * LibFfi type: ffi_type_pointer + * LibFfi type: ffi_type_gcpointer * C type: Scheme_Object* * Predicate: 1 * Scheme->C: @@ -784,7 +794,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) /* Special type, not actually used for anything except to mark values * that are treated like pointers but not referenced. Used for * creating function types. */ -#define FOREIGN_fpointer (25) +#define FOREIGN_fpointer (26) /* Type Name: fpointer * LibFfi type: ffi_type_pointer * C type: void* @@ -817,12 +827,13 @@ typedef union _ForeignAny { char* x_path; char* x_symbol; void* x_pointer; + void* x_gcpointer; Scheme_Object* x_scheme; void* x_fpointer; } ForeignAny; /* This is a tag that is used to identify user-made struct types. */ -#define FOREIGN_struct (26) +#define FOREIGN_struct (27) /*****************************************************************************/ /* Type objects */ @@ -876,6 +887,8 @@ int ctype_FIXUP(void *p) { END_XFORM_SKIP; #endif +static ffi_type ffi_type_gcpointer; + #define CTYPE_BASETYPE(x) (((ctype_struct*)(x))->basetype) #define CTYPE_USERP(x) (CTYPE_BASETYPE(x) != NULL && SCHEME_CTYPEP(CTYPE_BASETYPE(x))) #define CTYPE_PRIMP(x) (!CTYPE_USERP(x)) @@ -951,6 +964,7 @@ static int ctype_sizeof(Scheme_Object *type) case FOREIGN_path: return sizeof(char*); case FOREIGN_symbol: return sizeof(char*); case FOREIGN_pointer: return sizeof(void*); + case FOREIGN_gcpointer: return sizeof(void*); case FOREIGN_scheme: return sizeof(Scheme_Object*); case FOREIGN_fpointer: return sizeof(void*); /* for structs */ @@ -1148,6 +1162,9 @@ END_XFORM_SKIP; #define scheme_make_foreign_cpointer(x) \ ((x==NULL)?scheme_false:scheme_make_cptr(x,NULL)) +#define scheme_make_foreign_external_cpointer(x) \ + ((x==NULL)?scheme_false:scheme_make_external_cptr(x,NULL)) + #define MYNAME "cpointer?" static Scheme_Object *foreign_cpointer_p(int argc, Scheme_Object *argv[]) { @@ -1206,7 +1223,7 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, else return _scheme_apply(CTYPE_USER_C2S(type), 1, (Scheme_Object**)(&res)); } else if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) { - return scheme_make_foreign_cpointer(*(void **)W_OFFSET(src, delta)); + return scheme_make_foreign_external_cpointer(*(void **)W_OFFSET(src, delta)); } else switch (CTYPE_PRIMLABEL(type)) { case FOREIGN_void: return scheme_void; case FOREIGN_int8: return scheme_make_integer(REF_CTYPE(Tsint8)); @@ -1230,7 +1247,8 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, case FOREIGN_bytes: return (REF_CTYPE(char*)==NULL)?scheme_false:scheme_make_byte_string_without_copying(REF_CTYPE(char*)); case FOREIGN_path: return (REF_CTYPE(char*)==NULL)?scheme_false:scheme_make_path_without_copying(REF_CTYPE(char*)); case FOREIGN_symbol: return scheme_intern_symbol(REF_CTYPE(char*)); - case FOREIGN_pointer: return scheme_make_foreign_cpointer(REF_CTYPE(void*)); + case FOREIGN_pointer: return scheme_make_foreign_external_cpointer(REF_CTYPE(void*)); + case FOREIGN_gcpointer: return scheme_make_foreign_cpointer(REF_CTYPE(void*)); case FOREIGN_scheme: return REF_CTYPE(Scheme_Object*); case FOREIGN_fpointer: return (REF_CTYPE(void*)); case FOREIGN_struct: @@ -1599,6 +1617,23 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, scheme_wrong_type("Scheme->C","pointer",0,1,&(val)); return NULL; /* hush the compiler */ } + case FOREIGN_gcpointer: +# ifdef SCHEME_BIG_ENDIAN + if (sizeof(void*)C","gcpointer",0,1,&(val)); + return NULL; /* hush the compiler */ + } case FOREIGN_scheme: # ifdef SCHEME_BIG_ENDIAN if (sizeof(Scheme_Object*)C","scheme",0,1,&(val)); return NULL; /* hush the compiler */ @@ -1845,7 +1874,7 @@ static Scheme_Object *foreign_malloc(int argc, Scheme_Object *argv[]) if ((num == 0) && (size == 0)) scheme_signal_error(MYNAME": no size given"); size = ((size==0) ? 1 : size) * ((num==0) ? 1 : num); if (mode == NULL) - mf = (base != NULL && CTYPE_PRIMTYPE(base) == &ffi_type_pointer) + 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; @@ -1862,7 +1891,10 @@ static Scheme_Object *foreign_malloc(int argc, Scheme_Object *argv[]) if (failok) res = scheme_malloc_fail_ok(mf,size); else res = mf(size); if (((from != NULL) || (foff != 0)) && (res != NULL)) memcpy(res, W_OFFSET(from, foff), size); - return scheme_make_foreign_cpointer(res); + if (SAME_OBJ(mode, raw_sym)) + return scheme_make_foreign_external_cpointer(res); + else + return scheme_make_foreign_cpointer(res); } #undef MYNAME @@ -1906,7 +1938,7 @@ static Scheme_Object *foreign_free(int argc, Scheme_Object *argv[]) #define MYNAME "malloc-immobile-cell" static Scheme_Object *foreign_malloc_immobile_cell(int argc, Scheme_Object *argv[]) { - return scheme_make_foreign_cpointer(scheme_malloc_immobile_box(argv[0])); + return scheme_make_foreign_external_cpointer(scheme_malloc_immobile_box(argv[0])); } #undef MYNAME @@ -1961,10 +1993,16 @@ static Scheme_Object *do_ptr_add(const char *who, int is_bang, ((Scheme_Offset_Cptr*)(argv[0]))->offset += noff; return scheme_void; } else { - return scheme_make_offset_cptr - (SCHEME_FFIANYPTR_VAL(argv[0]), - SCHEME_FFIANYPTR_OFFSET(argv[0]) + noff, - (SCHEME_CPTRP(argv[0])) ? SCHEME_CPTR_TYPE(argv[0]) : NULL); + if (SCHEME_CPTRP(argv[0]) && (SCHEME_CPTR_FLAGS(argv[0]) & 0x1)) + return scheme_make_offset_external_cptr + (SCHEME_FFIANYPTR_VAL(argv[0]), + SCHEME_FFIANYPTR_OFFSET(argv[0]) + noff, + (SCHEME_CPTRP(argv[0])) ? SCHEME_CPTR_TYPE(argv[0]) : NULL); + else + return scheme_make_offset_cptr + (SCHEME_FFIANYPTR_VAL(argv[0]), + SCHEME_FFIANYPTR_OFFSET(argv[0]) + noff, + (SCHEME_CPTRP(argv[0])) ? SCHEME_CPTR_TYPE(argv[0]) : NULL); } } @@ -2741,6 +2779,7 @@ void scheme_init_foreign(Scheme_Env *env) Scheme_Env *menv; ctype_struct *t; Scheme_Object *s; + memcpy(&ffi_type_gcpointer, &ffi_type_pointer, sizeof(ffi_type_pointer)); menv = scheme_primitive_module(scheme_intern_symbol("#%foreign"), env); scheme_add_global("ffi-lib?", scheme_make_prim_w_arity(foreign_ffi_lib_p, "ffi-lib?", 1, 1), menv); @@ -2981,11 +3020,18 @@ void scheme_init_foreign(Scheme_Env *env) t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_pointer); scheme_add_global("_pointer", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("gcpointer"); + t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); + t->so.type = ctype_tag; + t->basetype = (s); + t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_gcpointer)); + t->c_to_scheme = ((Scheme_Object*)FOREIGN_gcpointer); + scheme_add_global("_gcpointer", (Scheme_Object*)t, menv); s = scheme_intern_symbol("scheme"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); - t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); + t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_gcpointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_scheme); scheme_add_global("_scheme", (Scheme_Object*)t, menv); s = scheme_intern_symbol("fpointer"); diff --git a/src/foreign/foreign.ssc b/src/foreign/foreign.ssc index 8524a70911..c02d6999c0 100755 --- a/src/foreign/foreign.ssc +++ b/src/foreign/foreign.ssc @@ -704,6 +704,13 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) * ffi-obj and string values pass their pointer. When used as a return * value, either a cpointer object or #f is returned. */ @(defctype 'pointer + 'ctype "void*" + 'macro "FFIANYPTR" + 'offset "FFIANYPTR" + 'c->s "scheme_make_foreign_external_cpointer") + +@(defctype 'gcpointer + 'ftype "gcpointer" 'ctype "void*" 'macro "FFIANYPTR" 'offset "FFIANYPTR" @@ -721,7 +728,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) /* This is used for passing and Scheme_Object* value as is. Useful for * functions that know about Scheme_Object*s, like MzScheme's. */ @(defctype 'scheme - 'ftype "pointer" + 'ftype "gcpointer" 'ctype "Scheme_Object*" 'pred (lambda (x aux) "1") 's->c (lambda (x aux) x) @@ -759,6 +766,8 @@ typedef union _ForeignAny { [scheme_to_c "Scheme_Object*"] [c_to_scheme "Scheme_Object*"]] +static ffi_type ffi_type_gcpointer; + #define CTYPE_BASETYPE(x) (((ctype_struct*)(x))->basetype) #define CTYPE_USERP(x) (CTYPE_BASETYPE(x) != NULL && SCHEME_CTYPEP(CTYPE_BASETYPE(x))) #define CTYPE_PRIMP(x) (!CTYPE_USERP(x)) @@ -950,6 +959,9 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym) #define scheme_make_foreign_cpointer(x) \ ((x==NULL)?scheme_false:scheme_make_cptr(x,NULL)) +#define scheme_make_foreign_external_cpointer(x) \ + ((x==NULL)?scheme_false:scheme_make_external_cptr(x,NULL)) + @cdefine[cpointer? 1]{ return SCHEME_FFIANYPTRP(argv[0]) ? scheme_true : scheme_false; } @@ -999,7 +1011,7 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, else return _scheme_apply(CTYPE_USER_C2S(type), 1, (Scheme_Object**)(&res)); } else if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) { - return scheme_make_foreign_cpointer(*(void **)W_OFFSET(src, delta)); + return scheme_make_foreign_external_cpointer(*(void **)W_OFFSET(src, delta)); } else switch (CTYPE_PRIMLABEL(type)) { @(map-types @list{case FOREIGN_@|cname|: return @; @@ -1307,7 +1319,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, if ((num == 0) && (size == 0)) scheme_signal_error(MYNAME": no size given"); size = ((size==0) ? 1 : size) * ((num==0) ? 1 : num); if (mode == NULL) - mf = (base != NULL && CTYPE_PRIMTYPE(base) == &ffi_type_pointer) + 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; @@ -1324,7 +1336,10 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, if (failok) res = scheme_malloc_fail_ok(mf,size); else res = mf(size); if (((from != NULL) || (foff != 0)) && (res != NULL)) memcpy(res, W_OFFSET(from, foff), size); - return scheme_make_foreign_cpointer(res); + if (SAME_OBJ(mode, raw_sym)) + return scheme_make_foreign_external_cpointer(res); + else + return scheme_make_foreign_cpointer(res); } /* (end-stubborn-change ptr) */ @@ -1359,7 +1374,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, /* (malloc-immobile-cell v) */ @cdefine[malloc-immobile-cell 1]{ - return scheme_make_foreign_cpointer(scheme_malloc_immobile_box(argv[0])); + return scheme_make_foreign_external_cpointer(scheme_malloc_immobile_box(argv[0])); } /* (free-immobile-cell b) */ @@ -1410,10 +1425,16 @@ static Scheme_Object *do_ptr_add(const char *who, int is_bang, ((Scheme_Offset_Cptr*)(argv[0]))->offset += noff; return scheme_void; } else { - return scheme_make_offset_cptr - (SCHEME_FFIANYPTR_VAL(argv[0]), - SCHEME_FFIANYPTR_OFFSET(argv[0]) + noff, - (SCHEME_CPTRP(argv[0])) ? SCHEME_CPTR_TYPE(argv[0]) : NULL); + if (SCHEME_CPTRP(argv[0]) && (SCHEME_CPTR_FLAGS(argv[0]) & 0x1)) + return scheme_make_offset_external_cptr + (SCHEME_FFIANYPTR_VAL(argv[0]), + SCHEME_FFIANYPTR_OFFSET(argv[0]) + noff, + (SCHEME_CPTRP(argv[0])) ? SCHEME_CPTR_TYPE(argv[0]) : NULL); + else + return scheme_make_offset_cptr + (SCHEME_FFIANYPTR_VAL(argv[0]), + SCHEME_FFIANYPTR_OFFSET(argv[0]) + noff, + (SCHEME_CPTRP(argv[0])) ? SCHEME_CPTR_TYPE(argv[0]) : NULL); } } @@ -2112,6 +2133,7 @@ void scheme_init_foreign(Scheme_Env *env) Scheme_Env *menv; ctype_struct *t; Scheme_Object *s; + memcpy(&ffi_type_gcpointer, &ffi_type_pointer, sizeof(ffi_type_pointer)); menv = scheme_primitive_module(scheme_intern_symbol("#%foreign"), env); @(maplines (lambda (x) diff --git a/src/mzscheme/include/mzscheme.exp b/src/mzscheme/include/mzscheme.exp index 4745180d0c..e5033d29f5 100644 --- a/src/mzscheme/include/mzscheme.exp +++ b/src/mzscheme/include/mzscheme.exp @@ -300,6 +300,8 @@ scheme_get_unsigned_long_long_val scheme_real_to_double scheme_make_cptr scheme_make_offset_cptr +scheme_make_external_cptr +scheme_make_offset_external_cptr scheme_get_proc_name scheme_utf8_decode scheme_utf8_decode_as_prefix diff --git a/src/mzscheme/include/mzscheme3m.exp b/src/mzscheme/include/mzscheme3m.exp index 0f982d8640..0b81542ee1 100644 --- a/src/mzscheme/include/mzscheme3m.exp +++ b/src/mzscheme/include/mzscheme3m.exp @@ -311,6 +311,8 @@ scheme_get_unsigned_long_long_val scheme_real_to_double scheme_make_cptr scheme_make_offset_cptr +scheme_make_external_cptr +scheme_make_offset_external_cptr scheme_get_proc_name scheme_utf8_decode scheme_utf8_decode_as_prefix diff --git a/src/mzscheme/include/mzwin.def b/src/mzscheme/include/mzwin.def index 8d6213a4c1..69d58bb2ec 100644 --- a/src/mzscheme/include/mzwin.def +++ b/src/mzscheme/include/mzwin.def @@ -288,6 +288,8 @@ EXPORTS scheme_real_to_double scheme_make_cptr scheme_make_offset_cptr + scheme_make_external_cptr + scheme_make_offset_external_cptr scheme_get_proc_name scheme_utf8_decode scheme_utf8_decode_as_prefix diff --git a/src/mzscheme/include/mzwin3m.def b/src/mzscheme/include/mzwin3m.def index 3ac5c900c2..97c236b7dd 100644 --- a/src/mzscheme/include/mzwin3m.def +++ b/src/mzscheme/include/mzwin3m.def @@ -303,6 +303,8 @@ EXPORTS scheme_real_to_double scheme_make_cptr scheme_make_offset_cptr + scheme_make_external_cptr + scheme_make_offset_external_cptr scheme_get_proc_name scheme_utf8_decode scheme_utf8_decode_as_prefix diff --git a/src/mzscheme/include/scheme.h b/src/mzscheme/include/scheme.h index 8e406c1121..95d6f69873 100644 --- a/src/mzscheme/include/scheme.h +++ b/src/mzscheme/include/scheme.h @@ -564,7 +564,7 @@ typedef long (*Scheme_Secondary_Hash_Proc)(Scheme_Object *obj, void *cycle_data) typedef struct Scheme_Cptr { - Scheme_Object so; + Scheme_Inclhash_Object so; /* 0x1 => an external pointer (not GCable) */ void *val; Scheme_Object *type; } Scheme_Cptr; @@ -577,6 +577,7 @@ typedef struct Scheme_Offset_Cptr #define SCHEME_CPTR_VAL(obj) (((Scheme_Cptr *)(obj))->val) #define SCHEME_CPTR_TYPE(obj) (((Scheme_Cptr *)(obj))->type) #define SCHEME_CPTR_OFFSET(obj) (SAME_TYPE(_SCHEME_TYPE(obj), scheme_offset_cpointer_type) ? ((Scheme_Offset_Cptr *)obj)->offset : 0) +#define SCHEME_CPTR_FLAGS(obj) MZ_OPT_HASH_KEY(&((Scheme_Cptr *)(obj))->so) #define SCHEME_SET_IMMUTABLE(obj) ((MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(obj)) |= 0x1)) #define SCHEME_SET_CHAR_STRING_IMMUTABLE(obj) SCHEME_SET_IMMUTABLE(obj) diff --git a/src/mzscheme/src/mzmark.c b/src/mzscheme/src/mzmark.c index 274dad8988..3438c881e7 100644 --- a/src/mzscheme/src/mzmark.c +++ b/src/mzscheme/src/mzmark.c @@ -156,14 +156,18 @@ static int cpointer_obj_SIZE(void *p) { } static int cpointer_obj_MARK(void *p) { - gcMARK(SCHEME_CPTR_VAL(p)); + if (!(SCHEME_CPTR_FLAGS(p) & 0x1)) { + gcMARK(SCHEME_CPTR_VAL(p)); + } gcMARK(SCHEME_CPTR_TYPE(p)); return gcBYTES_TO_WORDS(sizeof(Scheme_Cptr)); } static int cpointer_obj_FIXUP(void *p) { - gcFIXUP(SCHEME_CPTR_VAL(p)); + if (!(SCHEME_CPTR_FLAGS(p) & 0x1)) { + gcFIXUP(SCHEME_CPTR_VAL(p)); + } gcFIXUP(SCHEME_CPTR_TYPE(p)); return gcBYTES_TO_WORDS(sizeof(Scheme_Cptr)); @@ -179,14 +183,18 @@ static int offset_cpointer_obj_SIZE(void *p) { } static int offset_cpointer_obj_MARK(void *p) { - gcMARK(SCHEME_CPTR_VAL(p)); + if (!(SCHEME_CPTR_FLAGS(p) & 0x1)) { + gcMARK(SCHEME_CPTR_VAL(p)); + } gcMARK(SCHEME_CPTR_TYPE(p)); return gcBYTES_TO_WORDS(sizeof(Scheme_Offset_Cptr)); } static int offset_cpointer_obj_FIXUP(void *p) { - gcFIXUP(SCHEME_CPTR_VAL(p)); + if (!(SCHEME_CPTR_FLAGS(p) & 0x1)) { + gcFIXUP(SCHEME_CPTR_VAL(p)); + } gcFIXUP(SCHEME_CPTR_TYPE(p)); return gcBYTES_TO_WORDS(sizeof(Scheme_Offset_Cptr)); diff --git a/src/mzscheme/src/mzmarksrc.c b/src/mzscheme/src/mzmarksrc.c index a67d027af9..e7461311cd 100644 --- a/src/mzscheme/src/mzmarksrc.c +++ b/src/mzscheme/src/mzmarksrc.c @@ -56,7 +56,9 @@ quotesyntax_obj { cpointer_obj { mark: - gcMARK(SCHEME_CPTR_VAL(p)); + if (!(SCHEME_CPTR_FLAGS(p) & 0x1)) { + gcMARK(SCHEME_CPTR_VAL(p)); + } gcMARK(SCHEME_CPTR_TYPE(p)); size: gcBYTES_TO_WORDS(sizeof(Scheme_Cptr)); @@ -64,7 +66,9 @@ cpointer_obj { offset_cpointer_obj { mark: - gcMARK(SCHEME_CPTR_VAL(p)); + if (!(SCHEME_CPTR_FLAGS(p) & 0x1)) { + gcMARK(SCHEME_CPTR_VAL(p)); + } gcMARK(SCHEME_CPTR_TYPE(p)); size: gcBYTES_TO_WORDS(sizeof(Scheme_Offset_Cptr)); diff --git a/src/mzscheme/src/salloc.c b/src/mzscheme/src/salloc.c index 77c675734e..7dfd2c14c8 100644 --- a/src/mzscheme/src/salloc.c +++ b/src/mzscheme/src/salloc.c @@ -342,6 +342,14 @@ Scheme_Object *scheme_make_cptr(void *cptr, Scheme_Object *typetag) return o; } +Scheme_Object *scheme_make_external_cptr(GC_CAN_IGNORE void *cptr, Scheme_Object *typetag) +{ + Scheme_Object *o; + o = scheme_make_cptr(NULL, typetag); + SCHEME_CPTR_VAL(o) = cptr; + return o; +} + Scheme_Object *scheme_make_offset_cptr(void *cptr, long offset, Scheme_Object *typetag) { Scheme_Object *o; @@ -355,6 +363,15 @@ Scheme_Object *scheme_make_offset_cptr(void *cptr, long offset, Scheme_Object *t return o; } +Scheme_Object *scheme_make_offset_external_cptr(GC_CAN_IGNORE void *cptr, long offset, Scheme_Object *typetag) +{ + Scheme_Object *o; + o = scheme_make_offset_cptr(NULL, offset, typetag); + SCHEME_CPTR_VAL(o) = cptr; + return o; +} + + /************************************************************************/ /* allocation */ /************************************************************************/ diff --git a/src/mzscheme/src/schemef.h b/src/mzscheme/src/schemef.h index 36cdcae970..7335bdc62d 100644 --- a/src/mzscheme/src/schemef.h +++ b/src/mzscheme/src/schemef.h @@ -576,6 +576,8 @@ XFORM_NONGCING MZ_EXTERN double scheme_real_to_double(Scheme_Object *r); MZ_EXTERN Scheme_Object *scheme_make_cptr(void *cptr, Scheme_Object *typetag); MZ_EXTERN Scheme_Object *scheme_make_offset_cptr(void *cptr, long offset, Scheme_Object *typetag); +MZ_EXTERN Scheme_Object *scheme_make_external_cptr(void *cptr, Scheme_Object *typetag); +MZ_EXTERN Scheme_Object *scheme_make_offset_external_cptr(void *cptr, long offset, Scheme_Object *typetag); MZ_EXTERN const char *scheme_get_proc_name(Scheme_Object *p, int *len, int for_error); diff --git a/src/mzscheme/src/schemex.h b/src/mzscheme/src/schemex.h index 9d564c9491..018fe8a593 100644 --- a/src/mzscheme/src/schemex.h +++ b/src/mzscheme/src/schemex.h @@ -475,6 +475,8 @@ int (*scheme_get_unsigned_long_long_val)(Scheme_Object *o, umzlonglong *v); double (*scheme_real_to_double)(Scheme_Object *r); Scheme_Object *(*scheme_make_cptr)(void *cptr, Scheme_Object *typetag); Scheme_Object *(*scheme_make_offset_cptr)(void *cptr, long offset, Scheme_Object *typetag); +Scheme_Object *(*scheme_make_external_cptr)(void *cptr, Scheme_Object *typetag); +Scheme_Object *(*scheme_make_offset_external_cptr)(void *cptr, long offset, Scheme_Object *typetag); const char *(*scheme_get_proc_name)(Scheme_Object *p, int *len, int for_error); /*========================================================================*/ /* strings */ diff --git a/src/mzscheme/src/schemex.inc b/src/mzscheme/src/schemex.inc index fb3178ebe7..bd758f5808 100644 --- a/src/mzscheme/src/schemex.inc +++ b/src/mzscheme/src/schemex.inc @@ -337,6 +337,8 @@ scheme_extension_table->scheme_real_to_double = scheme_real_to_double; scheme_extension_table->scheme_make_cptr = scheme_make_cptr; scheme_extension_table->scheme_make_offset_cptr = scheme_make_offset_cptr; + scheme_extension_table->scheme_make_external_cptr = scheme_make_external_cptr; + scheme_extension_table->scheme_make_offset_external_cptr = scheme_make_offset_external_cptr; scheme_extension_table->scheme_get_proc_name = scheme_get_proc_name; scheme_extension_table->scheme_utf8_decode = scheme_utf8_decode; scheme_extension_table->scheme_utf8_decode_as_prefix = scheme_utf8_decode_as_prefix; diff --git a/src/mzscheme/src/schemexm.h b/src/mzscheme/src/schemexm.h index c39addb2d0..35f01c2599 100644 --- a/src/mzscheme/src/schemexm.h +++ b/src/mzscheme/src/schemexm.h @@ -337,6 +337,8 @@ #define scheme_real_to_double (scheme_extension_table->scheme_real_to_double) #define scheme_make_cptr (scheme_extension_table->scheme_make_cptr) #define scheme_make_offset_cptr (scheme_extension_table->scheme_make_offset_cptr) +#define scheme_make_external_cptr (scheme_extension_table->scheme_make_external_cptr) +#define scheme_make_offset_external_cptr (scheme_extension_table->scheme_make_offset_external_cptr) #define scheme_get_proc_name (scheme_extension_table->scheme_get_proc_name) #define scheme_utf8_decode (scheme_extension_table->scheme_utf8_decode) #define scheme_utf8_decode_as_prefix (scheme_extension_table->scheme_utf8_decode_as_prefix) diff --git a/src/mzscheme/src/schvers.h b/src/mzscheme/src/schvers.h index 5ce9e8d09a..184d8bca5b 100644 --- a/src/mzscheme/src/schvers.h +++ b/src/mzscheme/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "4.2.2.5" +#define MZSCHEME_VERSION "4.2.2.6" #define MZSCHEME_VERSION_X 4 #define MZSCHEME_VERSION_Y 2 #define MZSCHEME_VERSION_Z 2 -#define MZSCHEME_VERSION_W 5 +#define MZSCHEME_VERSION_W 6 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)