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

Chez Scheme: add support for nonatomic foreign arrays

Browse Source 
A reference bytevector holds a mixture of addresses within GCable
objects and foreign addresses, where "address" corresponds to the
payload of a bytevector or flvector object. The GC knows to apply a
suitable offset to the reference, so that object counts as reachable
from a reference bytevector, and the reference bytevector is updated
if the object is relocated during a collection.

With this change, the restriction in Racket CS against passing
non-atomic memory to a foreign function can be lifted. For example,
`(_list i _string)` can be useful as the type of a foreign-call
argument.

Making reference bytevectors a subtype of bytevectors is not an
obvious choice, given that writing to a reference bytevector with
byte-level operations can easily corrupt it. But this choice makes
various things simpler and easier.
This commit is contained in:
Matthew Flatt 2021-05-09 14:58:40 -06:00
parent e0063a9495
commit 87196e0144
35 changed files with 1011 additions and 540 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.makefile
View File

@ -344,7 +344,7 @@ RACKET_FOR_BOOTFILES = $(RACKET)
RACKET_FOR_BUILD = $(RACKET)
# This branch name changes each time the pb boot files are updated:
PB_BRANCH == circa-8.1.0.4-1
PB_BRANCH == circa-8.1.0.6-1
PB_REPO = https://github.com/racket/pb
# Set to empty for Git before v1.7.10:

14
Makefile
View File

@ -47,7 +47,7 @@ RACKETCS_SUFFIX =
RACKET =
RACKET_FOR_BOOTFILES = $(RACKET)
RACKET_FOR_BUILD = $(RACKET)
PB_BRANCH = circa-8.1.0.4-1
PB_BRANCH = circa-8.1.0.6-1
PB_REPO = https://github.com/racket/pb
SINGLE_BRANCH_FLAG = --single-branch
EXTRA_REPOS_BASE =
@ -310,19 +310,19 @@ maybe-fetch-pb-as-is:
echo done
fetch-pb-from:
mkdir -p racket/src/ChezScheme/boot
if [ ! -d racket/src/ChezScheme/boot/pb ] ; then git clone -q $(SINGLE_BRANCH_FLAG) -b circa-8.1.0.4-1 $(PB_REPO) racket/src/ChezScheme/boot/pb ; else cd racket/src/ChezScheme/boot/pb && git fetch -q origin circa-8.1.0.4-1:remotes/origin/circa-8.1.0.4-1 ; fi
cd racket/src/ChezScheme/boot/pb && git remote set-branches origin circa-8.1.0.4-1
cd racket/src/ChezScheme/boot/pb && git checkout -q circa-8.1.0.4-1
if [ ! -d racket/src/ChezScheme/boot/pb ] ; then git clone -q $(SINGLE_BRANCH_FLAG) -b circa-8.1.0.6-1 $(PB_REPO) racket/src/ChezScheme/boot/pb ; else cd racket/src/ChezScheme/boot/pb && git fetch -q origin circa-8.1.0.6-1:remotes/origin/circa-8.1.0.6-1 ; fi
cd racket/src/ChezScheme/boot/pb && git remote set-branches origin circa-8.1.0.6-1
cd racket/src/ChezScheme/boot/pb && git checkout -q circa-8.1.0.6-1
pb-fetch:
$(MAKE) fetch-pb EXTRA_REPOS_BASE="$(EXTRA_REPOS_BASE)" PB_REPO="$(PB_REPO)" SINGLE_BRANCH_FLAG="$(SINGLE_BRANCH_FLAG)"
pb-build:
cd racket/src/ChezScheme && racket rktboot/main.rkt --machine pb
pb-stage:
cd racket/src/ChezScheme/boot/pb && git branch circa-8.1.0.4-1
cd racket/src/ChezScheme/boot/pb && git checkout circa-8.1.0.4-1
cd racket/src/ChezScheme/boot/pb && git branch circa-8.1.0.6-1
cd racket/src/ChezScheme/boot/pb && git checkout circa-8.1.0.6-1
cd racket/src/ChezScheme/boot/pb && git add . && git commit --amend -m "new build"
pb-push:
cd racket/src/ChezScheme/boot/pb && git push -u origin circa-8.1.0.4-1
cd racket/src/ChezScheme/boot/pb && git push -u origin circa-8.1.0.6-1
win-cs-base:
IF "$(RACKET_FOR_BUILD)" == "" $(MAKE) win-bc-then-cs-base SETUP_BOOT_MODE=--boot WIN32_BUILD_LEVEL=bc PLAIN_RACKET=racket\racketbc DISABLE_STATIC_LIBS="$(DISABLE_STATIC_LIBS)" EXTRA_REPOS_BASE="$(EXTRA_REPOS_BASE)" JOB_OPTIONS="$(JOB_OPTIONS)" PLT_SETUP_OPTIONS="$(PLT_SETUP_OPTIONS)" RACKETBC_SUFFIX="$(RACKETBC_SUFFIX)" RACKETCS_SUFFIX="$(RACKETCS_SUFFIX)"
IF not "$(RACKET_FOR_BUILD)" == "" $(MAKE) win-just-cs-base SETUP_BOOT_MODE=--chain DISABLE_STATIC_LIBS="$(DISABLE_STATIC_LIBS)" EXTRA_REPOS_BASE="$(EXTRA_REPOS_BASE)" JOB_OPTIONS="$(JOB_OPTIONS)" PLT_SETUP_OPTIONS="$(PLT_SETUP_OPTIONS)" RACKETCS_SUFFIX="$(RACKETCS_SUFFIX)" RACKET_FOR_BUILD="$(RACKET_FOR_BUILD)"

2
pkgs/base/info.rkt
View File

@ -14,7 +14,7 @@
;; In the Racket source repo, this version should change only when
;; "racket_version.h" changes:
(define version "8.1.0.5")
(define version "8.1.0.6")
(define deps `("racket-lib"
["racket" #:version ,version]))

35
pkgs/racket-doc/scribblings/foreign/pointers.scrbl
View File

@ -61,13 +61,9 @@ memory that is (assumed to be) managed by the garbage collector,
@racket[#f] otherwise.
For a pointer based on @racket[_gcpointer] as a result type,
@racket[cpointer-gcable?] will return @racket[#t]. In the @BC[]
implementation of Racket, @racket[cpointer-gcable?] will return
@racket[#f] for a pointer based on @racket[_pointer] as a result type.
The @CS[] implementation is mostly the same, except that if a pointer is
extracted using the @racket[_pointer] type from memory allocated as
@racket['nonatomic], @racket[cpointer-gcable?] will report @racket[#t]
for the extracted pointer.}
@racket[cpointer-gcable?] will return @racket[#t]. For a pointer based
on @racket[_pointer] as a result type, @racket[cpointer-gcable?] will
return @racket[#f].}
@; ----------------------------------------------------------------------
@ -268,22 +264,22 @@ specification is required at minimum:
@item{@indexed-racket['nonatomic] --- Allocates memory that can
be reclaimed by the garbage collector, is treated by the
garbage collector as holding only pointers, and is initially
filled with zeros.
filled with zeros. The memory is allowed to contain a mixture of
references to objects managed by the garbage collector and
addresses that are outside the garbage collector's space.
For the @BC[] Racket implementation, this allocation mode corresponds
to @cpp{scheme_malloc} in the C API.
For the @CS[] Racket implementation, this mode is of limited use,
because a pointer allocated this way cannot be passed to
foreign functions that expect a pointer to pointers. The result
can only be used with functions like @racket[ptr-set!] and
@racket[ptr-ref].}
to @cpp{scheme_malloc} in the C API.}
@item{@indexed-racket['atomic-interior] --- Like
@racket['atomic], but the allocated object will not be moved by
the garbage collector as long as the allocated object is
retained.
A better name for this allocation mode would be
@racket['atomic-immobile], but it's @racket['atomic-interior]
for historical reasons.
For the @BC[] Racket implementation, a reference can point
to the interior of the object, instead of its starting address.
This allocation mode corresponds to
@ -294,6 +290,10 @@ specification is required at minimum:
by the garbage collector as long as the allocated object is
retained.
A better name for this allocation mode would be
@racket['nonatomic-immobile], but it's @racket['interior] for
historical reasons.
For the @BC[] Racket implementation, a reference can point
to the interior of the object, instead of its starting address.
This allocation mode corresponds to
@ -339,7 +339,10 @@ when the type is a @racket[_gcpointer]- or @racket[_scheme]-based
type, and @racket['atomic] allocation is used otherwise.
@history[#:changed "6.4.0.10" @elem{Added the @racket['tagged] allocation mode.}
#:changed "8.0.0.13" @elem{Changed CS to support the @racket['interior] allocation mode.}]}
#:changed "8.0.0.13" @elem{Changed CS to support the @racket['interior] allocation mode.}
#:changed "8.1.0.6" @elem{Changed CS to remove constraints on the use of memory allocated
with the @racket['nonatomic] and @racket['interior] allocation
modes.}]}
@defproc[(free [cptr cpointer?]) void]{

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

@ -1125,11 +1125,6 @@ allocated using @racket[(malloc type-expr)] if
@racket[maybe-malloc-mode] is not specified or if it is @racket[#f],
@racket[(malloc type-expr '@#,racket[maybe-malloc-mode])] otherwise.
Note that in the @CS[] implementation of Racket, a @racket[(_ptr i
__ctype)] argument will trigger an error if @racket[__ctype] indicates
values that are managed by the garbage collector, since pointers to
non-atomic memory cannot be passed to foreign functions.
@history[#:changed "7.7.0.6" @elem{The modes @racket[i], @racket[o],
and @racket[io] match as symbols
instead of free identifiers.}
@ -1200,12 +1195,6 @@ return two values, the vector and the boolean.
-> (values vec res))
]
Note that in the @CS[] implementation of Racket, a @racket[(_list i
__ctype)] argument will trigger an error if @racket[__ctype] indicates
values that are managed by the garbage collector, since pointers to
non-atomic memory cannot be passed to foreign functions. See also
@racketmodname[ffi/unsafe/string-list].
@history[#:changed "7.7.0.2" @elem{Added @racket[maybe-mode].}]
#:changed "7.7.0.6" @elem{The modes @racket[i], @racket[o],
and @racket[io] match as symbols

16
pkgs/racket-test-core/tests/racket/foreign-test.c
View File

@ -76,6 +76,22 @@ X int hoho(int x, int(*(*f)(int))(int)) { return (f(x+1))(x-1); }
X int grab7th(void *p) { return ((char *)p)[7]; }
X char *second_string(char **x) { return x[1]; }
X void reverse_strings(char **x) {
while (*x) {
int i, len;
char *s;
for (len = 0; (*x)[len] != 0; len++);
s = malloc(len + 1);
for (i = 0; i < len; i++)
s[i] = (*x)[len - i - 1];
s[len] = 0;
*x = s;
x++;
}
}
X int vec4(int x[]) { return x[0]+x[1]+x[2]+x[3]; }
typedef struct _char_int { unsigned char a; int b; } char_int;

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

@ -361,12 +361,16 @@
(with-keeper b)
(set-box! b #f)))
;; ---
;; test error reported when trying to pass non-atomic on CS
(when (eq? 'chez-scheme (system-type 'vm))
(err/rt-test ((ffi 'grab7th (_fun (_list i _string) -> _int ))
(list "hello"))
exn:fail?
"non-atomic"))
;; test passing an array of strings
(test "world"
(ffi 'second_string (_fun (_list i _string) -> _string))
(list "hello" "world" "!"))
;; check that an io array of strings can have GC_allocated strings get replaced
;; by foreign addresses
(test '("olleh" "dlrow" "?!" #f)
(ffi 'reverse_strings (_fun (lst : (_list io _string 4)) -> _void -> lst))
(list "hello" "world" "!?" #f #f))
;; ---
;; test exposing internal mzscheme functionality
(when (eq? 'racket (system-type 'vm))
@ -1152,7 +1156,6 @@
(check-equal? (array-ref (MISCPTR-as d) i) s)
(check-equal? (array-ref (MISCPTR-ab d) i) b)))
;; --- simple failing tests
(define-serializable-cstruct _F4 ([a _int]) #:malloc-mode 'abc)
(define-serializable-cstruct _F40 ([a _fpointer]))

8
racket/src/ChezScheme/c/alloc.c
View File

@ -727,10 +727,10 @@ ptr S_flvector(n) iptr n; {
}
ptr S_bytevector(n) iptr n; {
return S_bytevector2(get_thread_context(), n, 0);
return S_bytevector2(get_thread_context(), n, space_new);
}
ptr S_bytevector2(tc, n, immobile) ptr tc; iptr n; IBOOL immobile; {
ptr S_bytevector2(tc, n, spc) ptr tc; iptr n; ISPC spc; {
ptr p; iptr d;
if (n == 0) return S_G.null_bytevector;
@ -739,8 +739,8 @@ ptr S_bytevector2(tc, n, immobile) ptr tc; iptr n; IBOOL immobile; {
S_error("", "invalid bytevector size request");
d = size_bytevector(n);
if (immobile)
find_room(tc, space_immobile_data, 0, type_typed_object, d, p);
if (spc != space_new)
find_room(tc, spc, 0, type_typed_object, d, p);
else
newspace_find_room(tc, type_typed_object, d, p);
BYTEVECTOR_TYPE(p) = (n << bytevector_length_offset) | type_bytevector;

2
racket/src/ChezScheme/c/externs.h
View File

@ -89,7 +89,7 @@ extern ptr S_vector PROTO((iptr n));
extern ptr S_fxvector PROTO((iptr n));
extern ptr S_flvector PROTO((iptr n));
extern ptr S_bytevector PROTO((iptr n));
extern ptr S_bytevector2 PROTO((ptr tc, iptr n, IBOOL immobile));
extern ptr S_bytevector2 PROTO((ptr tc, iptr n, ISPC spc));
extern ptr S_null_immutable_vector PROTO((void));
extern ptr S_null_immutable_fxvector PROTO((void));
extern ptr S_null_immutable_bytevector PROTO((void));

5
racket/src/ChezScheme/c/fasl.c
View File

@ -1569,7 +1569,10 @@ static void pb_set_abs(void *address, uptr item) {
int dest_reg = ((U32 *)address)[1] & DEST_REG_MASK;
#endif
((U32 *)address)[0] = (pb_mov16_pb_zero_bits_pb_shift0 | dest_reg | ((item & 0xFFFF) << ADDRESS_BITS_SHIFT));
/* pb_link is the same as pb_mov16_pb_zero_bits_pb_shift0, but with
a promise of the subsequent instructions to load a full word */
((U32 *)address)[0] = (pb_link | dest_reg | ((item & 0xFFFF) << ADDRESS_BITS_SHIFT));
((U32 *)address)[1] = (pb_mov16_pb_keep_bits_pb_shift1 | dest_reg | (((item >> 16) & 0xFFFF) << ADDRESS_BITS_SHIFT));
#if ptr_bytes == 8
((U32 *)address)[2] = (pb_mov16_pb_keep_bits_pb_shift2 | dest_reg | (((item >> 32) & 0xFFFF) << ADDRESS_BITS_SHIFT));

2
racket/src/ChezScheme/c/flushcache.c
View File

@ -30,7 +30,7 @@ static uptr max_gap;
static ptr make_mod_range PROTO((ptr tc, uptr start, uptr end));
static ptr make_mod_range(ptr tc, uptr start, uptr end) {
ptr bv = S_bytevector2(tc, sizeof(mod_range), 0);
ptr bv = S_bytevector2(tc, sizeof(mod_range), space_new);
mod_range_start(bv) = start;
mod_range_end(bv) = end;
return bv;

61
racket/src/ChezScheme/c/gc.c
View File

@ -697,6 +697,24 @@ static void do_relocate_pure_in_owner(thread_gc *tgc, ptr *ppp) {
} \
} while (0)
#define relocate_reference(ppp, from_g) do { \
ptr* rPPP = ppp; ptr rPP = *rPPP; \
if (!FOREIGN_REFERENCEP(rPP)) { \
*rPPP = S_reference_to_object(rPP); \
relocate_impure(rPPP, from_g); \
*rPPP = S_object_to_reference(*rPPP); \
} \
} while (0)
#define relocate_reference_dirty(ppp, YOUNGEST) do { \
ptr* rPPP = ppp; \
if (!FOREIGN_REFERENCEP(*rPPP)) { \
*rPPP = S_reference_to_object(*rPPP); \
relocate_dirty(rPPP, YOUNGEST); \
*rPPP = S_object_to_reference(*rPPP); \
} \
} while (0)
#ifdef ENABLE_OBJECT_COUNTS
# define is_counting_root(si, p) (si->counting_mask && (si->counting_mask[segment_bitmap_byte(p)] & segment_bitmap_bit(p)))
#endif
@ -706,6 +724,14 @@ static void do_relocate_pure_in_owner(thread_gc *tgc, ptr *ppp) {
relocate_pure(&_P); \
} while (0)
# define relocate_reference_indirect(p) do { \
ptr _P = p; \
if (!FOREIGN_REFERENCEP(_P)) { \
_P = S_reference_to_object(_P); \
relocate_pure(&_P); \
} \
} while (0)
FORCEINLINE void check_triggers(thread_gc *tgc, seginfo *si) {
/* Registering ephemerons and guardians to recheck at the
granularity of a segment means that the worst-case complexity of
@ -1914,7 +1940,7 @@ static iptr sweep_generation_pass(thread_gc *tgc) {
ppn = pp + 1;
p = *ppn;
relocate_impure_help(ppn, p, from_g);
FLUSH_REMOTE(tgc, TYPE(TO_PTR(pp), type_pair));
FLUSH_REMOTE(tgc, TYPE(TO_PTR(pp), type_pair)); /* can always treat as a pair to sweep words */
pp = ppn + 1;
});
SET_BACKREFERENCE(Sfalse);
@ -1996,6 +2022,12 @@ static iptr sweep_generation_pass(thread_gc *tgc) {
sweep(tgc, p, from_g);
pp = TO_VOIDP((uptr)TO_PTR(pp) + size_object(p));
});
sweep_space(space_reference_array, from_g, {
p = TYPE(TO_PTR(pp), type_typed_object);
pp = TO_VOIDP((uptr)TO_PTR(pp) + sweep_typed_object(tgc, p, from_g));
});
}
/* May add to the sweep stack: */
@ -2448,6 +2480,33 @@ static uptr sweep_dirty_segments(thread_gc *tgc, seginfo **dirty_segments) {
youngest = check_dirty_ephemeron(tgc, p, youngest);
pp += size_ephemeron / sizeof(ptr);
}
} else if (s == space_reference_array) {
/* the same as space_impure and others above, but for object references */
if (dirty_si->marked_mask) {
while (pp < ppend) {
/* handle two pointers at a time */
if (marked(dirty_si, TO_PTR(pp))) {
FLUSH_REMOTE_BLOCK
relocate_reference_dirty(pp, youngest);
ppn = pp + 1;
relocate_reference_dirty(ppn, youngest);
FLUSH_REMOTE(tgc, TYPE(TO_PTR(pp), type_pair)); /* can treat as a pair for resweep */
pp = ppn + 1;
} else {
pp += 2;
}
}
} else {
while (pp < ppend && *pp != forward_marker) {
/* handle two pointers at a time */
FLUSH_REMOTE_BLOCK
relocate_reference_dirty(pp, youngest);
ppn = pp + 1;
relocate_reference_dirty(ppn, youngest);
FLUSH_REMOTE(tgc, TYPE(TO_PTR(pp), type_pair));
pp = ppn + 1;
}
}
} else {
S_error_abort("sweep_dirty(gc): unexpected space");
}

14
racket/src/ChezScheme/c/gcwrapper.c
View File

@ -548,8 +548,12 @@ void S_addr_tell(ptr p) {
segment_tell(addr_get_segment(p));
}
static void check_pointer(ptr *pp, IBOOL address_is_meaningful, ptr base, uptr seg, ISPC s, IBOOL aftergc) {
static void check_pointer(ptr *pp, IBOOL address_is_meaningful, IBOOL is_reference, ptr base, uptr seg, ISPC s, IBOOL aftergc) {
ptr p = *pp;
if (is_reference)
p = S_reference_to_object(p);
if (!FIXMEDIATE(p)) {
seginfo *psi = MaybeSegInfo(ptr_get_segment(p));
if (psi != NULL) {
@ -769,7 +773,7 @@ void S_check_heap(aftergc, mcg) IBOOL aftergc; IGEN mcg; {
} else if (s == space_impure || s == space_symbol || s == space_pure || s == space_weakpair || s == space_ephemeron
|| s == space_immobile_impure || s == space_count_pure || s == space_count_impure || s == space_closure
|| s == space_pure_typed_object || s == space_continuation || s == space_port || s == space_code
|| s == space_impure_record || s == space_impure_typed_object) {
|| s == space_impure_record || s == space_impure_typed_object || s == space_reference_array) {
ptr start;
/* check for dangling references */
@ -884,7 +888,7 @@ void S_check_heap(aftergc, mcg) IBOOL aftergc; IGEN mcg; {
if (!si->marked_mask || (si->marked_mask[segment_bitmap_byte(TO_PTR(pp1))] & segment_bitmap_bit(TO_PTR(pp1)))) {
int a;
for (a = 0; (a < ptr_alignment) && (pp1 < pp2); a++) {
#define in_ephemeron_pair_part(pp1, seg) ((((uptr)TO_PTR(pp1) - (uptr)build_ptr(seg, 0)) % size_ephemeron) < size_pair)
#define in_ephemeron_pair_part(pp1, seg) ((((uptr)TO_PTR(pp1) - (uptr)build_ptr(seg, 0)) % size_ephemeron) < size_pair)
if ((s == space_ephemeron) && !in_ephemeron_pair_part(pp1, seg)) {
/* skip non-pair part of ephemeron */
} else {
@ -893,7 +897,7 @@ void S_check_heap(aftergc, mcg) IBOOL aftergc; IGEN mcg; {
pp1 = pp2; /* break out of outer loop */
break;
} else {
check_pointer(pp1, 1, (ptr)0, seg, s, aftergc);
check_pointer(pp1, 1, (s == space_reference_array), (ptr)0, seg, s, aftergc);
}
}
pp1 += 1;
@ -905,7 +909,7 @@ void S_check_heap(aftergc, mcg) IBOOL aftergc; IGEN mcg; {
/* further verify that dirty bits are set appropriately; only handles some spaces
to make sure that the dirty byte is not unnecessarily approximate, but we have also
checked dirty bytes alerady via `check_pointer` */
checked dirty bytes already via `check_pointer` */
if (s == space_impure || s == space_symbol || s == space_weakpair || s == space_ephemeron
|| s == space_immobile_impure || s == space_closure) {
found_eos = 0;

17
racket/src/ChezScheme/c/pb.c
View File

@ -91,6 +91,23 @@ void S_pb_interp(ptr tc, void *bytecode) {
next_ip = ip + 1;
switch(INSTR_op(instr)) {
case pb_link:
/* same as pb_mov16_pb_zero_bits_pb_shift0, but with a promise
of collowing pb_mov16_pb_keep_bits_pb_shift1... with the same
destination */
regs[INSTR_di_dest(instr)] = ((uptr)INSTR_di_imm_unsigned(instr)
| ((uptr)INSTR_di_imm_unsigned(ip[1]) << 16)
#if ptr_bits == 64
| ((uptr)INSTR_di_imm_unsigned(ip[2]) << 32)
| ((uptr)INSTR_di_imm_unsigned(ip[3]) << 48)
#endif
);
#if ptr_bits == 64
next_ip = ip + 4;
#else
next_ip = ip + 2;
#endif
break;
case pb_mov16_pb_zero_bits_pb_shift0:
regs[INSTR_di_dest(instr)] = (uptr)INSTR_di_imm_unsigned(instr);
break;

42
racket/src/ChezScheme/c/prim5.c
View File

@ -37,6 +37,11 @@ static ptr s_ephemeron_pairp PROTO((ptr p));
static ptr s_box_immobile PROTO((ptr p));
static ptr s_make_immobile_vector PROTO((uptr len, ptr fill));
static ptr s_make_immobile_bytevector PROTO((uptr len));
static ptr s_make_reference_bytevector PROTO((uptr len));
static ptr s_make_immobile_reference_bytevector PROTO((uptr len));
static ptr s_reference_bytevectorp PROTO((ptr p));
static ptr s_reference_star_address_object PROTO((ptr p));
static ptr s_bytevector_reference_star_ref PROTO((ptr p, uptr offset));
static ptr s_oblist PROTO((void));
static ptr s_bigoddp PROTO((ptr n));
static ptr s_float PROTO((ptr x));
@ -210,7 +215,7 @@ static ptr s_box_immobile(p) ptr p; {
}
static ptr s_make_immobile_bytevector(uptr len) {
ptr b = S_bytevector2(get_thread_context(), len, 1);
ptr b = S_bytevector2(get_thread_context(), len, space_immobile_data);
S_immobilize_object(b);
return b;
}
@ -235,6 +240,36 @@ static ptr s_make_immobile_vector(uptr len, ptr fill) {
return v;
}
static ptr s_make_reference_bytevector(uptr len) {
ptr b = S_bytevector2(get_thread_context(), len, space_reference_array);
memset(&BVIT(b, 0), 0, len);
return b;
}
static ptr s_make_immobile_reference_bytevector(uptr len) {
ptr b = s_make_reference_bytevector(len);
S_immobilize_object(b);
return b;
}
static ptr s_reference_bytevectorp(p) ptr p; {
seginfo *si;
return (si = MaybeSegInfo(ptr_get_segment(p))) != NULL && si->space == space_reference_array ? Strue : Sfalse;
}
static ptr s_reference_star_address_object(ptr p) {
if (p == (ptr)0)
return Sfalse;
else if (MaybeSegInfo(addr_get_segment(p)))
return (ptr)((uptr)p - reference_disp);
else
return Sunsigned((uptr)p);
}
static ptr s_bytevector_reference_star_ref(ptr p, uptr offset) {
return s_reference_star_address_object(*(ptr *)&BVIT(p, offset));
}
static ptr s_oblist() {
ptr ls = Snil;
iptr idx = S_G.oblist_length;
@ -1660,6 +1695,11 @@ void S_prim5_init() {
Sforeign_symbol("(cs)box_immobile", (void *)s_box_immobile);
Sforeign_symbol("(cs)make_immobile_vector", (void *)s_make_immobile_vector);
Sforeign_symbol("(cs)make_immobile_bytevector", (void *)s_make_immobile_bytevector);
Sforeign_symbol("(cs)s_make_reference_bytevector", (void *)s_make_reference_bytevector);
Sforeign_symbol("(cs)s_make_immobile_reference_bytevector", (void *)s_make_immobile_reference_bytevector);
Sforeign_symbol("(cs)s_reference_bytevectorp", (void *)s_reference_bytevectorp);
Sforeign_symbol("(cs)s_reference_star_address_object", (void *)s_reference_star_address_object);
Sforeign_symbol("(cs)s_bytevector_reference_star_ref", (void *)s_bytevector_reference_star_ref);
Sforeign_symbol("(cs)continuation_depth", (void *)S_continuation_depth);
Sforeign_symbol("(cs)single_continuation", (void *)S_single_continuation);
Sforeign_symbol("(cs)c_exit", (void *)c_exit);

12
racket/src/ChezScheme/c/scheme.c
View File

@ -331,7 +331,17 @@ static void idiot_checks() {
/* parallel GC relies on not confusing a forward marker with code flags */
fprintf(stderr, "code flags overlap with forwadr_marker\n");
oops = 1;
}
}
if ((reference_disp != bytevector_data_disp)
|| (reference_disp != flvector_data_disp)) {
fprintf(stderr, "reference displacement does not match bytevector or flvector displacement\n");
oops = 1;
}
if (reference_disp >= (2 * ptr_bytes)) {
fprintf(stderr, "reference displacement is larger than two words\n");
oops = 1;
}
if (oops) S_abnormal_exit();
}

33
racket/src/ChezScheme/c/segment.h
View File

@ -97,3 +97,36 @@ FORCEINLINE uptr eq_hash(ptr key) {
iptr x3 = x2 ^ ((x2 >> 8) & (iptr)0xFF);
return (uptr)x3;
}
FORCEINLINE ptr S_object_to_reference(ptr p) {
if (p == Sfalse)
return (ptr)0;
else
return ((ptr)((uptr)(p) + reference_disp));
}
FORCEINLINE ptr S_reference_to_object(ptr p) {
if (p == (ptr)0)
return Sfalse;
else
return ((ptr)((uptr)(p) - reference_disp));
}
/* We take advantage of the fact `reference_disp` is less than two
words and that every allocation region has a one-word padding, so
there's no possibility that the referece address for an object will
be off of its GC-managed page (even for a pair or an bytevector
with an empty payload). */
#define FOREIGN_REFERENCEP(p) (MaybeSegInfo(addr_get_segment(p)) == NULL)
/* checks whether address is on GC-managed page before adjusting it;
it's not ok to check after adjusting if `reference_disp` is more
than one word */
FORCEINLINE ptr S_maybe_reference_to_object(ptr p) {
if (p == (ptr)0)
return Sfalse;
else if (MaybeSegInfo(addr_get_segment(p)) == NULL)
return (ptr)0;
else
return ((ptr)((uptr)(p) - reference_disp));
}

3
racket/src/ChezScheme/c/types.h
View File

@ -554,6 +554,9 @@ typedef struct thread_gc {
#define INCRGEN(g) (g = g == S_G.max_nonstatic_generation ? static_generation : g+1)
#define FIXMEDIATE(x) (Sfixnump(x) || Simmediatep(x))
#define Sbytevector_reference_length(p) (Sbytevector_length(p) >> log2_ptr_bytes)
#define INITBVREFIT(p, i) (*(ptr *)(&BVIT(p, (i) << log2_ptr_bytes)))
/* For `memcpy_aligned, that the first two arguments are word-aligned
and it would be ok to round up the length to a word size. But
probably the compiler does a fine job with plain old `mempcy`. */

177
racket/src/ChezScheme/csug/foreign.stex
View File

@ -2318,6 +2318,183 @@ value is the symbol \scheme{invalid}.
\endschemedisplay
\section{Foreign Arrays of Managed Objects\label{SECTREFERENCEARRAY}}
When a bytevector value is passed in a foreign call an an argument
type \scheme{u8*}, the foreign procedure receives a pointer to the
start of the bytevector's content. The function
\scheme{object->reference-address} returns that same address, but it
is valid only if the bytevector does not move. If the storage manager
later moves the bytevector in memory, then the address becomes
invalid. The bytevector can be locked with \scheme{lock-object} to
prevent the storage manage from relocating it, so that the content
address will remain valid, but then it must be explicitly unlocked
later with \scheme{unlock-object}.
Having to explicitly lock and unlock objects can make interoperating
with foreign procedures difficult when the foreign procedure expects
an array of references. It may seem that a vector could serve that
purpose, but although a Scheme vector is an array of references at
some level, a vector's reference to a bytevector does not point to the
start of the bytevector's content.
A \emph{reference bytevector} is a bytevector that can be used as an
array of pointers that is passed to a foreign procedure. Use
\scheme{bytevector-reference-set!} to install reference to another
bytevector or to an flvector, and that reference can be both (1)
recognized as a reference and updated as needed by the storage
manager, and (2) recognized as a pointer to the bytevector's content
by a foreign procedure. When a reference bytevector refers to
\scheme{#f}, its representation within the bytevector is the address
\scheme{0}. A reference bytevector can refer to other kinds of Scheme
objects, too, although the meaning of an address for other kinds of
objects is unspecified. In addition, a reference bytevector can
contain foreign addresses, which are addresses of memory outside of
the storage manager's ranges, but beware that an address range
released by a foreign allocator might later become a range that
belongs to the Scheme storage manager. During the time that a garbage
collection is possible (i.e., when interrupts have not been disabled),
every aligned word in a reference bytevector must hold a valid object
reference or a foreign address.
%----------------------------------------------------------------------------
\entryheader
\formdef{make-reference-bytevector}{\categoryprocedure}{(make-reference-bytevector \var{n})}
\returns a reference bytevector of length \var{n}
\listlibraries
\endentryheader
\noindent
Like \scheme{make-bytevector}, but the result is a reference
bytevector that is initialized with all \scheme{#f}, except that
trailing bytes after the last multiple of a pointer size.
%----------------------------------------------------------------------------
\entryheader
\formdef{make-immobile-reference-bytevector}{\categoryprocedure}{(make-immobile-reference-bytevector \var{n})}
\returns a reference bytevector of length \var{n}
\listlibraries
\endentryheader
\noindent
Like \scheme{make-reference-bytevector}, but creates a reference
bytevector that will not be relocated in memory by the storage
management system until it is reclaimed.
%----------------------------------------------------------------------------
\entryheader
\formdef{reference-bytevector?}{\categoryprocedure}{(reference-bytevector? \var{obj})}
\returns \scheme{#t} if \var{obj} is an reference bytevector, \scheme{#f} otherwise
\listlibraries
\endentryheader
Note that every reference bytevector is also a bytevector that is
recognized by \scheme{bytevector?}, and \scheme{equal?} considers two
bytevectors independent of whether either is a reference bytevector.
%----------------------------------------------------------------------------
\entryheader
\formdef{bytevector-reference-set!}{\categoryprocedure}{(bytevector-reference-set! \var{bytevector} \var{n} \var{obj})}
\returns unspecified
\listlibraries
\endentryheader
\noindent
\var{bytevector} must be a reference bytevector, and \var{n} must
be a nonnegative fixnum strictly less than the length of
\var{bytevector}.
Installs a reference to \var{obj} at byte offset \var{n} within
\var{bytevector}. In the case that \var{obj} is a bytevector or
flvector, the reference is represented as the starting address of the
bytevector or flvector's content.
%----------------------------------------------------------------------------
\entryheader
\formdef{bytevector-reference-ref}{\categoryprocedure}{(bytevector-reference-ref \var{bytevector} \var{n})}
\returns a Scheme object
\listlibraries
\endentryheader
\noindent
\var{bytevector} must be a reference bytevector, and \var{n} must
be a nonnegative fixnum strictly less than the length of
\var{bytevector}.
Returns the object that is refefenced \var{bytevector} at byte offset
\var{n}.
%----------------------------------------------------------------------------
\entryheader
\formdef{bytevector-reference*-ref}{\categoryprocedure}{(bytevector-reference*-ref \var{bytevector} \var{n})}
\returns an allocated Scheme object or an exact integer
\listlibraries
\endentryheader
\noindent
Like \scheme{bytevector-reference-ref}, but if \var{bytevector} at
byte offset \var{n} holds a non-\scheme{0} foreign address,
\scheme{bytevector-reference*-ref} returns an integer. The
representation of a reference to a Scheme object can overlap with the
representation of a foreign address; see
\scheme{reference*-address->object}.
%----------------------------------------------------------------------------
\entryheader
\formdef{object->reference-address}{\categoryprocedure}{(object->reference-address \var{obj})}
\returns a nonnegative exact integer
\listlibraries
\endentryheader
\noindent
The result is \scheme{0} if \scheme{obj} is \scheme{#f}, and it is the
address of \var{objs}'s content in the case that \var{obj} is a
bytevector of flvector---at least, at the point where
\scheme{object->reference-address} was called. Unless \var{obj} is
a locked or immobile bytevector or flvector, its address can change at
any time that a garbage collection is possible (i.e., when interrupts
are enabled). For other kinds of \var{objs}, the representation at the
returned address is not specified, except that it is a nonnegative
exact integer that is distinct from any other object's representation.
%----------------------------------------------------------------------------
\entryheader
\formdef{reference-address->object}{\categoryprocedure}{(reference-address->object \var{addr})}
\returns a Scheme object
\listlibraries
\endentryheader
\noindent
\var{addr} must be a nonnegative exact integer that is a valid reference
to a Scheme object, and the result is the referenced Scheme object.
%----------------------------------------------------------------------------
\entryheader
\formdef{reference*-address->object}{\categoryprocedure}{(reference*-address->object \var{addr})}
\returns a Scheme object, possibly \var{addr} itself
\listlibraries
\endentryheader
\noindent
\var{addr} must be a nonnegative exact integer that is a valid
reference to a Scheme object, or it must be an foreign address that is
outside the range that belongs to the storage manager.
When \var{addr} is \scheme{0}, the result is \scheme{#f}. Otherwise,
if \var{addr} is a foreign address, then \var{addr} itself is
returned.
The representation of a reference to a bytevector or flvector is
guaranteed to be distinct from any foreign address, but other values
may have a representation that overlaps with foreign addresses, and
\var{addr} is returned (i.e., the foreign-address interpretation takes
precedence) in that case. Thus, \scheme{reference*-address->object}
and \scheme{bytevector-reference*-ref} are mainly useful for an address
that is known to be either a bytevector reference, an flvector
reference, or a foreign address.
%----------------------------------------------------------------------------
\section{Providing Access to Foreign Procedures\label{SECTFOREIGNACCESS}}

2
racket/src/ChezScheme/makefiles/Mf-install.in
View File

@ -62,7 +62,7 @@ InstallLZ4Target=
# no changes should be needed below this point #
###############################################################################
Version=csv9.5.5.4
Version=csv9.5.5.5
Include=boot/$m
PetiteBoot=boot/$m/petite.boot
SchemeBoot=boot/$m/scheme.boot

2
racket/src/ChezScheme/mats/5_3.ms
View File

@ -7264,4 +7264,4 @@
(eqv? 16 (fxpopcount #b1111111111111111))
(eqv? 16 (fxpopcount32 #b1111111111111111))
(eqv? 16 (fxpopcount16 #b1111111111111111))
)
)

102
racket/src/ChezScheme/mats/foreign.ms
View File

@ -3300,3 +3300,105 @@
37))])
])
(mat reference-bytevector
(error? (make-reference-bytevector -1))
(error? (bytevector-reference-ref #vu8(1 2 3) 0))
(error? (bytevector-reference-ref (make-reference-bytevector 8) -8))
(error? (bytevector-reference-ref (make-reference-bytevector 8) 'oops))
(error? (bytevector-reference*-ref (make-reference-bytevector 8) -8))
(error? (bytevector-reference*-ref (make-reference-bytevector 8) 'oops))
(error? (reference-address->object #f))
(error? (reference*-address->object #f))
(not (reference-bytevector? #vu8(1 2 3)))
(not (reference-bytevector? 7))
(begin
(define $reftest-bv (make-reference-bytevector (* 2 (foreign-sizeof 'ptr))))
(reference-bytevector? $reftest-bv))
(eqv? (* 2 (foreign-sizeof 'ptr)) (bytevector-length $reftest-bv))
(eq? #f (bytevector-reference-ref $reftest-bv 0))
(begin
(define $reftest-bv2 (bytevector 1 2 3 4 5 6))
(bytevector-reference-set! $reftest-bv 0 $reftest-bv2)
(collect)
(eq? $reftest-bv2 (bytevector-reference-ref $reftest-bv 0)))
(with-interrupts-disabled
(eq? (if (= (foreign-sizeof 'ptr) 8)
(bytevector-u64-native-ref $reftest-bv 0)
(bytevector-u32-native-ref $reftest-bv 0))
(object->reference-address $reftest-bv2)))
(with-interrupts-disabled
(and (eq? $reftest-bv2
(reference-address->object (object->reference-address $reftest-bv2)))
(eq? $reftest-bv2
(reference*-address->object (object->reference-address $reftest-bv2)))))
(begin
(define $reftest-bv3 (bytevector 5 6 7 8))
(bytevector-reference-set! $reftest-bv (foreign-sizeof 'ptr) $reftest-bv3)
(collect)
(eq? $reftest-bv2 (bytevector-reference-ref $reftest-bv 0)))
(eq? $reftest-bv3 (bytevector-reference-ref $reftest-bv (foreign-sizeof 'ptr)))
(eq? $reftest-bv3 (bytevector-reference*-ref $reftest-bv (foreign-sizeof 'ptr)))
(let ()
(lock-object $reftest-bv3)
(let ([p (if (= (foreign-sizeof 'ptr) 8)
(bytevector-u64-native-ref $reftest-bv 8)
(bytevector-u32-native-ref $reftest-bv 4))])
(foreign-set! 'unsigned-8 p 1 77)
(equal? $reftest-bv3 #vu8(5 77 7 8))))
(begin
(unlock-object $reftest-bv3)
(define $reftest-mem4 (foreign-alloc 20))
(if (= (foreign-sizeof 'ptr) 8)
(bytevector-u64-native-set! $reftest-bv 8 $reftest-mem4)
(bytevector-u32-native-set! $reftest-bv 4 $reftest-mem4))
(eqv? $reftest-mem4 (bytevector-reference*-ref $reftest-bv (foreign-sizeof 'ptr))))
(begin
(foreign-free $reftest-mem4)
(define $reftest-flv (flvector 3.0 6.0 7.0))
(bytevector-reference-set! $reftest-bv 0 $reftest-flv)
(collect)
(eq? $reftest-flv (bytevector-reference-ref $reftest-bv 0)))
(with-interrupts-disabled
(eq? (if (= (foreign-sizeof 'ptr) 8)
(bytevector-u64-native-ref $reftest-bv 0)
(bytevector-u32-native-ref $reftest-bv 0))
(object->reference-address $reftest-flv)))
(with-interrupts-disabled
(eq? $reftest-flv
(reference-address->object (object->reference-address $reftest-flv))))
(let ()
(lock-object $reftest-flv)
(let ([p (if (= (foreign-sizeof 'ptr) 8)
(bytevector-u64-native-ref $reftest-bv 0)
(bytevector-u32-native-ref $reftest-bv 0))])
(foreign-set! 'double p 8 77.0)
(equal? $reftest-flv #vfl(3.0 77.0 7.0))))
(let ([b (box 45)])
(bytevector-reference-set! $reftest-bv 0 b)
(collect)
(eq? b (bytevector-reference-ref $reftest-bv 0)))
(reference-bytevector? (make-immobile-reference-bytevector 16))
(let* ([i (make-immobile-reference-bytevector 16)]
[p (#%$object-address i 0)]
[cp (object->reference-address i)])
(collect)
(and (eqv? p (#%$object-address i 0))
(eqv? cp (object->reference-address i))))
(let ([i (make-immobile-reference-bytevector 16)])
(bytevector-reference-set! i 0 '#(hello))
(collect)
(equal? '#(hello) (bytevector-reference-ref i 0)))
(begin
(bytevector-reference-set! $reftest-bv 0 #f)
(eq? #f (bytevector-reference-ref $reftest-bv 0)))
)

1
racket/src/ChezScheme/mats/primvars.ms
View File

@ -388,6 +388,7 @@
[(boolean) #f '()]
[(box) &a '((a)) #f]
[(bytevector) '#vu8(0) "a" #f]
[(sub-bytevector) no-good]
[(cflonum) 0.0+1.0i 0 'a #f]
[(char) #\a 0 #f]
[(codec) (latin-1-codec) 0 #f]

39
racket/src/ChezScheme/s/cmacros.ss
View File

@ -357,7 +357,7 @@
;; ---------------------------------------------------------------------
;; Version and machine types:
(define-constant scheme-version #x09050504)
(define-constant scheme-version #x09050505)
(define-syntax define-machine-types
(lambda (x)
@ -740,23 +740,25 @@
(impure "impure" #\i 1) ; most mutable objects allocated here (all ptrs)
(symbol "symbol" #\x 2) ;
(port "port" #\q 3) ;
(weakpair "weakpr" #\w 4) ;
(ephemeron "emph" #\e 5) ;
(pure "pure" #\p 6) ; swept immutable objects allocated here (all ptrs)
(continuation "cont" #\k 7) ;
(code "code" #\c 8) ;
(pure-typed-object "p-tobj" #\r 9) ;
(impure-record "ip-rec" #\s 10) ;
(impure-typed-object "ip-tobj" #\t 11) ; as needed (instead of impure) for backtraces
(closure "closure" #\l 12) ; as needed (instead of pure/impure) for backtraces
(immobile-impure "im-impure" #\I 13) ; like impure, but for immobile objects
(count-pure "cnt-pure" #\y 14) ; like pure, but delayed for counting from roots
(count-impure "cnt-impure" #\z 15)); like impure-typed-object, but delayed for counting from roots
(pure "pure" #\p 4) ; swept immutable objects allocated here (all ptrs)
(continuation "cont" #\k 5) ;
(code "code" #\c 6) ;
(pure-typed-object "p-tobj" #\r 7) ;
(impure-record "ip-rec" #\s 8) ;
(impure-typed-object "ip-tobj" #\t 9) ; as needed (instead of impure) for backtraces
(closure "closure" #\l 10) ; as needed (instead of pure/impure) for backtraces
(immobile-impure "im-impure" #\I 11) ; like impure, but for immobile objects
(count-pure "cnt-pure" #\y 12) ; like pure, but delayed for counting from roots
(count-impure "cnt-impure" #\z 13) ; like impure-typed-object, but delayed for counting from roots
;; spaces that can hold pairs for sweeping:
(weakpair "weakpr" #\w 14) ; must be ordered as first special space for pairs
(ephemeron "emph" #\e 15) ;
(reference-array "ref-array" #\a 16)) ; reference bytevectors
(unswept
(data "data" #\d 16) ; unswept objects allocated here
(immobile-data "im-data" #\D 17))) ; like data, but non-moving
(data "data" #\d 17) ; unswept objects allocated here
(immobile-data "im-data" #\D 18))) ; like data, but non-moving
(unreal
(empty "empty" #\e 18))) ; available segments
(empty "empty" #\e 19))) ; available segments
;;; enumeration of types for which gc tracks object counts
;;; also update gc.c
@ -1448,6 +1450,8 @@
([iptr type]
[octet data 0]))])
(define-constant reference-disp (constant bytevector-data-disp))
(define-primitive-structure-disps stencil-vector type-typed-object
([iptr type]
[ptr data 0]))
@ -3297,7 +3301,8 @@
[pb-adr]
[pb-inc pb-argument-types]
[pb-lock]
[pb-cas])
[pb-cas]
[pb-link]) ; used by linker
;; Only foreign procedures that match specific prototypes are
;; supported, where each prototype must be handled in "pb.c"

67
racket/src/ChezScheme/s/cpprim.ss
View File

@ -628,7 +628,7 @@
[(arm32 arm64) #t]
[else #f])
#f))
(define add-store-fence
(define add-store-fence
;; A store--store fence should be good enough for safety on a platform that
;; orders load dependencies (which is anything except Alpha)
(lambda (e)
@ -679,11 +679,11 @@
`(if ,(%type-check mask-fixnum type-fixnum ,e)
,(build-assign a %zero 0 e)
,(add-store-fence
(build-remember-seq
(build-remember-seq
(build-assign a %zero 0 e)
(%inline remember ,a))))
;; Generate one copy of store instruction
(build-remember-seq
(build-remember-seq
(build-assign a %zero 0 e)
`(if ,(%type-check mask-fixnum type-fixnum ,e)
,(%constant svoid)
@ -872,7 +872,7 @@
,(case width
[(32) (intrinsic-info-asmlib dofretuns32 #f)]
[(64) (intrinsic-info-asmlib dofretuns64 #f)]
[else ($oops who "can't handle width ~s" width)])
[else ($oops who "can't handle width ~s" width)])
,%asmlibcall))
,%ac0)
,(build-fix %ac0))))))
@ -2909,7 +2909,7 @@
(void)]
[else
(let ()
(define (build-seginfo maybe? e)
(define (build-seginfo maybe? object? e)
(let ([ptr (make-assigned-tmp 'ptr)]
[seginfo (make-assigned-tmp 'seginfo)])
(define (build-level-3 seginfo k)
@ -2943,7 +2943,9 @@
,(k s2))
(k s2))))]
[else (k s3)]))
`(let ([,ptr ,(%inline srl ,(%inline + ,e (immediate ,(fx- (constant typemod) 1)))
`(let ([,ptr ,(%inline srl ,(if object?
(%inline + ,e (immediate ,(fx- (constant typemod) 1)))
e)
(immediate ,(constant segment-offset-bits)))])
(let ([,seginfo (literal ,(make-info-literal #f 'entry (lookup-c-entry segment-info) 0))])
,(build-level-3 seginfo
@ -2959,7 +2961,7 @@
,(%constant sfalse)
(if ,(%type-check mask-immediate type-immediate ,e)
,(%constant sfalse)
,(let ([s-e (build-seginfo #T e)]
,(let ([s-e (build-seginfo #t #t e)]
[si (make-assigned-tmp 'si)])
`(let ([,si ,s-e])
(if ,(%inline eq? ,si (immediate 0))
@ -2974,7 +2976,7 @@
,(%constant sfalse)
(if ,(%type-check mask-immediate type-immediate ,e)
,(%constant sfalse)
,(let ([s-e (build-seginfo #t e)]
,(let ([s-e (build-seginfo #t #t e)]
[si (make-assigned-tmp 'si)])
`(let ([,si ,s-e])
(if ,(%inline eq? ,si (immediate 0))
@ -2982,7 +2984,7 @@
,si))))))])
(define-inline 2 $seginfo
[(e)
(bind #t (e) (build-seginfo #f e))])
(bind #t (e) (build-seginfo #f #t e))])
(define-inline 2 $seginfo-generation
[(e)
(bind #f (e) (build-object-ref #f 'unsigned-8 e %zero (constant seginfo-generation-disp)))])
@ -2997,7 +2999,7 @@
[list-bits (make-assigned-tmp 'list-bits)]
[offset (make-assigned-tmp 'offset)]
[byte (make-assigned-tmp 'byte)])
`(let ([,si ,(build-seginfo #f e)])
`(let ([,si ,(build-seginfo #f #t e)])
(let ([,list-bits ,(%mref ,si ,(constant seginfo-list-bits-disp))])
(if ,(%inline eq? ,list-bits (immediate 0))
(immediate 0)
@ -3012,7 +3014,7 @@
(bind #t (e)
`(if ,(%type-check mask-fixnum type-fixnum ,e)
,(%constant sfalse)
,(let ([s-e (build-seginfo #t e)]
,(let ([s-e (build-seginfo #t #t e)]
[si (make-assigned-tmp 'si)])
`(let ([,si ,s-e])
(if ,(%inline eq? ,si (immediate 0))
@ -3021,7 +3023,9 @@
(define-inline 2 weak-pair?
[(e) (bind #t (e) (build-space-test e (constant space-weakpair)))])
(define-inline 2 ephemeron-pair?
[(e) (bind #t (e) (build-space-test e (constant space-ephemeron)))]))])
[(e) (bind #t (e) (build-space-test e (constant space-ephemeron)))])
(define-inline 2 reference-bytevector?
[(e) (bind #t (e) (build-space-test e (constant space-reference-array)))]))])
(define-inline 2 unbox
[(e)
@ -5161,6 +5165,16 @@
(%inline -
,(ptr->integer e-addr (type->width ptr-type))
,(build-unfix e-roffset)))])
(define-inline 3 object->reference-address
[(e-ptr) (bind #t (e-ptr)
`(if ,(%inline eq? ,e-ptr (immediate ,(constant sfalse)))
(immediate 0)
,(unsigned->ptr (%inline + ,e-ptr ,(%constant reference-disp)) (type->width ptr-type))))])
(define-inline 3 reference-address->object
[(e-ptr) (bind #t (e-ptr)
`(if ,(%inline eq? ,e-ptr (immediate 0))
(immediate ,(constant sfalse))
,(%inline - ,(ptr->integer e-ptr (type->width ptr-type)) ,(%constant reference-disp))))])
(define-inline 2 $object-ref
[(type base offset)
(nanopass-case (L7 Expr) type
@ -6366,6 +6380,35 @@
[else (build-dirty-store e-v e-i (constant stencil-vector-data-disp) e-new)]))
(define-inline 3 stencil-vector-set!
[(e-v e-i e-new) (go e-v e-i e-new)]))
(let ()
(define (build-dirty-store-reference base index offset e)
(let ([a (if (eq? index %zero)
(%lea ,base offset)
(%lea ,base ,index offset))])
(bind #t ([e e])
;; eval a second so the address is not live across any calls
(bind #t ([a a])
`(if ,(%inline eq? ,e (immediate ,(constant sfalse)))
(set! ,(%mref ,a ,0) (immediate 0))
,(add-store-fence
(%seq
(set! ,(%mref ,a ,0) ,(%inline + ,e ,(%constant reference-disp)))
,(%inline remember ,a))))))))
(define (go e-v e-i e-new)
(nanopass-case (L7 Expr) e-i
[(quote ,d)
(guard (target-fixnum? d))
(build-dirty-store-reference e-v %zero (+ d (constant bytevector-data-disp)) e-new)]
[else (build-dirty-store-reference e-v (build-unfix e-i) (constant bytevector-data-disp) e-new)]))
(define-inline 3 bytevector-reference-set!
[(e-v e-i e-new) (go e-v e-i e-new)])
(define-inline 3 bytevector-reference-ref
[(bv i) (let ([t (make-tmp 't 'uptr)])
`(let ([,t (inline ,(make-info-load ptr-type #f) ,%load
,bv ,(build-unfix i) (immediate ,(constant bytevector-data-disp)))])
(if ,(%inline eq? ,t (immediate 0))
(immediate ,(constant sfalse))
,(%inline - ,t ,(%constant reference-disp)))))]))
(let ()
(define (go e-v e-i e-new)
`(set!

122
racket/src/ChezScheme/s/mkgc.ss
View File

@ -84,8 +84,10 @@
;; - (trace-now <field>) : direct recur; implies pure
;; - (trace-early-rtd <field>) : for record types, avoids recur on #!base-rtd; implies pure
;; - (trace-pure-code <field>) : like `trace-pure`, but special handling in parallel mode
;; - (trace-reference <field>) : like `trace`, but for a reference bytevector element
;; - (trace-ptrs <field> <count>) : trace an array of pointerrs
;; - (trace-pure-ptrs <field> <count>) : pure analog of `trace-ptrs`
;; - (trace-reference-ptrs <field> <count>) : like `trace-ptrs`, but for a reference bytevector
;; - (copy <field>) : copy for copy, ignore otherwise
;; - (copy-bytes <field> <count>) : copy an array of bytes
;; - (copy-flonum <field>) : copy flonum and forward
@ -162,6 +164,11 @@
[pair
(case-space
[(< space-weakpair)
(space space-impure)
(try-double-pair trace pair-car
trace pair-cdr
countof-pair)]
[space-ephemeron
(space space-ephemeron)
(size size-ephemeron)
@ -187,12 +194,17 @@
(try-double-pair copy pair-car
trace pair-cdr
countof-weakpair)]
[else
(space space-impure)
(try-double-pair trace pair-car
trace pair-cdr
countof-pair)])]
[else ; => space-reference-array as used for dirty resweep by owner thread
(case-mode
[(sweep)
(space space-reference-array)
(size size-pair)
(mark)
(trace-reference pair-car)
(trace-reference pair-cdr)
(count countof-pair)]
[else
(S_error_abort "misplaced pair")])])]
[closure
(define code : ptr (CLOSCODE _))
(trace-code-early code) ; not traced in parallel mode
@ -434,12 +446,25 @@
(count countof-flvector)]
[bytevector
(space space-data)
(define sz : uptr (size_bytevector (Sbytevector_length _)))
(size (just sz))
(mark)
(copy-bytes bytevector-type sz)
(count countof-bytevector)]
(case-space
[space-reference-array
(space space-reference-array)
(define sz : uptr (size_bytevector (Sbytevector_length _)))
(size (just sz))
(mark)
(copy-type bytevector-type)
(define len : uptr (Sbytevector_reference_length _))
(trace-reference-ptrs bytevector-data len)
(pad (when (== (& len 1) 0)
(set! (INITBVREFIT _copy_ len) (FIX 0))))
(count countof-bytevector)]
[else
(space space-data)
(define sz : uptr (size_bytevector (Sbytevector_length _)))
(size (just sz))
(mark)
(copy-bytes bytevector-type sz)
(count countof-bytevector)])]
[tlc
(space
@ -1478,10 +1503,18 @@
"else"
(code-block (statements body config)))]
[`([,spc . ,body] . ,rest)
(unless (or (symbol? spc)
(and (pair? spc)
(memq (car spc) '(< <= == >= >))
(pair? (cdr spc))
(symbol? (cadr spc))
(null? (cddr spc))))
(error 'case-space "bad space spec: ~s" spc))
(code
(format "~aif (p_at_spc == ~a)"
(format "~aif (p_at_spc ~a ~a)"
(if else? "else " "")
(as-c spc))
(if (pair? spc) (car spc) "==")
(as-c (if (pair? spc) (cadr spc) spc)))
(code-block (statements body config))
(loop rest #t))])))
(statements (cdr l) config))]
@ -1547,6 +1580,9 @@
(and (not (lookup 'as-dirty? config #f))
(trace-statement field config #f 'pure))])
(statements (cdr l) config))]
[`(trace-reference ,field)
(code (trace-statement field config #f 'reference)
(statements (cdr l) config))]
[`(copy ,field)
(code (copy-statement field config)
(statements (cdr l) config))]
@ -1606,26 +1642,24 @@
(statements (cons `(trace-ptrs ,offset ,len pure)
(cdr l))
config)]
[`(trace-ptrs ,offset ,len ,purity)
[`(trace-reference-ptrs ,offset ,len)
(statements (cons `(trace-ptrs ,offset ,len reference)
(cdr l))
config)]
[`(trace-ptrs ,offset ,len ,purity/kind)
(case (lookup 'mode config)
[(copy)
(statements (cons `(copy-bytes ,offset (* ptr_bytes ,len))
(cdr l))
config)]
[(sweep measure sweep-in-old check)
[(sweep measure sweep-in-old check self-test)
(code
(loop-over-pointers
(field-expression offset config "p" #t)
len
(trace-statement `(array-ref p_p idx) config #f purity)
config)
(statements (cdr l) config))]
[(self-test)
(code
(loop-over-pointers (field-expression offset config "p" #t)
len
(code "if (p_p[idx] == p) return 1;")
config)
(trace-statement `(array-ref p_p idx) config #f purity/kind)
config
purity/kind)
(statements (cdr l) config))]
[else (statements (cdr l) config)])]
[`(count ,counter)
@ -2005,54 +2039,62 @@
[`()
(error 'case-mode "no matching case for ~s in ~s" mode all-clauses)])))
(define (loop-over-pointers ptr-e len body config)
(define (loop-over-pointers ptr-e len body config purity/kind)
(code-block
(format "uptr idx, p_len = ~a;" (expression len config))
(format "ptr *p_p = &~a;" ptr-e)
(format "ptr *p_p = ~a&~a;" (if (eq? purity/kind 'reference) "(ptr*)" "")
ptr-e)
"for (idx = 0; idx < p_len; idx++)"
(code-block body)))
(define (trace-statement field config early? purity)
(define (trace-statement field config early? purity/kind)
(define mode (lookup 'mode config))
(define (reference->object e)
(if (eq? purity/kind 'reference)
(format "S_maybe_reference_to_object(~a)" e)
e))
(cond
[(or (eq? mode 'sweep)
(eq? mode 'sweep-in-old)
(and early? (or (eq? mode 'copy)
(eq? mode 'mark))))
(relocate-statement purity (field-expression field config "p" #t) config)]
(relocate-statement purity/kind (field-expression field config "p" #t) config)]
[(eq? mode 'copy)
(copy-statement field config)]
[(eq? mode 'measure)
(measure-statement (field-expression field config "p" #f))]
(measure-statement (reference->object (field-expression field config "p" #f)))]
[(eq? mode 'self-test)
(format "if (p == ~a) return 1;" (field-expression field config "p" #f))]
(format "if (p == ~a) return 1;" (reference->object (field-expression field config "p" #f)))]
[(eq? mode 'check)
(format "check_pointer(&(~a), ~a, ~a, seg, s_in, aftergc);"
(format "check_pointer(&(~a), ~a, ~a, ~a, seg, s_in, aftergc);"
(field-expression field config "p" #f)
(match field
[`(just ,_) "0"]
[else "1"])
(if (eq? purity/kind 'reference) "1" "0")
(expression '_ config))]
[else #f]))
(define (relocate-statement purity e config)
(define (relocate-statement purity/kind e config)
(define mode (lookup 'mode config))
(case mode
[(sweep-in-old)
(if (eq? purity 'pure)
(format "relocate_pure(&~a);" e)
(format "relocate_indirect(~a);" e))]
(case purity/kind
[(pure) (format "relocate_pure(&~a);" e)]
[(reference) (format "relocate_reference_indirect(~a);" e)]
[else (format "relocate_indirect(~a);" e)])]
[else
(if (lookup 'as-dirty? config #f)
(begin
(when (eq? purity 'pure) (error 'relocate-statement "pure as dirty?"))
(format "relocate_dirty(&~a, youngest);" e))
(case purity/kind
[(pure) (error 'relocate-statement "pure as dirty?")]
[(reference) (format "relocate_reference_dirty(&~a, youngest);" e)]
[else (format "relocate_dirty(&~a, youngest);" e)])
(let ([in-owner (case mode
[(copy mark) (if (lookup 'parallel? config #f)
"_in_owner"
"")]
[else ""])])
(format "relocate_~a~a(&~a~a);" purity in-owner e (if (eq? purity 'impure) ", from_g" ""))))]))
(format "relocate_~a~a(&~a~a);" purity/kind in-owner e (if (eq? purity/kind 'pure) "" ", from_g"))))]))
(define (measure-statement e)
(code

9
racket/src/ChezScheme/s/primdata.ss
View File

@ -1176,6 +1176,9 @@
(bytevector->s8-list [sig [(bytevector) -> (list)]] [flags alloc])
(bytevector-truncate! [sig [(bytevector length) -> (bytevector)]] [flags true])
(bytevector->immutable-bytevector [sig [(bytevector) -> (bytevector)]] [flags alloc])
(bytevector-reference-ref [sig [(sub-bytevector sub-index) -> (ptr)]] [flags mifoldable discard])
(bytevector-reference*-ref [sig [(sub-bytevector sub-index) -> (ptr)]] [flags mifoldable discard])
(bytevector-reference-set! [sig [(sub-bytevector sub-index sub-ptr) -> (void)]] [flags true])
(bytevector-s24-ref [sig [(bytevector sub-index symbol) -> (s24)]] [flags true mifoldable discard])
(bytevector-s24-set! [sig [(bytevector sub-index s24 symbol) -> (void)]] [flags true])
(bytevector-s40-ref [sig [(bytevector sub-index symbol) -> (s40)]] [flags true mifoldable discard])
@ -1510,6 +1513,8 @@
(make-pseudo-random-generator [sig [() -> (pseudo-random-generator)]] [flags true])
(make-record-type [sig [(sub-ptr sub-list) (maybe-rtd sub-ptr sub-list) -> (rtd)]] [flags pure alloc cp02])
(make-record-type-descriptor* [sig [(symbol maybe-rtd maybe-symbol ptr ptr ufixnum exact-integer) -> (rtd)]] [flags pure alloc cp02])
(make-reference-bytevector [sig [(length) -> (bytevector)]] [flags alloc])
(make-immobile-reference-bytevector [sig [(length) -> (bytevector)]] [flags alloc])
(make-source-condition [sig [(ptr) -> (condition)]] [flags pure unrestricted mifoldable discard])
(make-source-file-descriptor [sig [(ptr binary-input-port) (ptr binary-input-port ptr) -> (sfd)]] [flags true])
(make-source-object [sig [(sfd uint uint) (sfd uint uint nzuint nzuint) -> (source-object)]] [flags pure true mifoldable discard])
@ -1544,6 +1549,7 @@
(number->string [sig [(number) (number sub-ufixnum) (number sub-ufixnum sub-ufixnum) -> (string)]] [flags alloc]) ; radix not restricted to 2, 4, 8, 16
(object-backreferences [sig [() -> (list)]] [flags alloc])
(object-counts [sig [() -> (list)]] [flags alloc])
(object->reference-address [sig [(ptr) -> (uint)]] [flags])
(oblist [sig [() -> (list)]] [flags alloc])
(open-fd-input-port [sig [(sub-ufixnum) (sub-ufixnum sub-symbol) (sub-ufixnum sub-symbol maybe-transcoder) -> (input-port)]] [flags true])
(open-fd-input/output-port [sig [(sub-ufixnum) (sub-ufixnum sub-symbol) (sub-ufixnum sub-symbol maybe-transcoder) -> (input/output-port)]] [flags true])
@ -1630,6 +1636,9 @@
(record-type-field-indices [sig [(rtd) -> (vector)]] [flags])
(record-type-named-fields? [sig [(rtd) -> (boolean)]] [flags])
(record-writer [sig [(rtd) -> (maybe-procedure)] [(rtd maybe-procedure) -> (void)]] [flags])
(reference-address->object [sig [(sub-uint) -> (ptr)]] [flags])
(reference*-address->object [sig [(sub-uint) -> (ptr)]] [flags])
(reference-bytevector? [sig [(ptr) -> (boolean)]] [flags pure mifoldable discard])
(register-signal-handler [sig [(sint procedure) -> (void)]] [flags])
(remove-foreign-entry [sig [(string) -> (void)]] [flags true])
(remove-hash-table! [sig [(old-hash-table ptr) -> (void)]] [flags true])

65
racket/src/ChezScheme/s/prims.ss
View File

@ -76,6 +76,57 @@
[else
(lambda (p) (ephemeron-pair? p))]))
(define reference-bytevector?
(constant-case architecture
[(pb)
(foreign-procedure "(cs)s_reference_bytevectorp" (scheme-object) scheme-object)]
[else
(lambda (p) (reference-bytevector? p))]))
(define-who bytevector-reference-ref
(lambda (bv i)
(unless (reference-bytevector? bv) ($oops who "~s is not a reference bytevector" bv))
(unless (and (fixnum? i)
(not ($fxu< (fx- (bytevector-length bv) (fx- (constant ptr-bytes) 1)) i)))
($oops who "invalid index ~s for ~s" i bv))
(bytevector-reference-ref bv i)))
(define-who bytevector-reference*-ref
(let ([ref (foreign-procedure "(cs)s_bytevector_reference_star_ref" (ptr uptr) ptr)])
(lambda (bv i)
(unless (reference-bytevector? bv) ($oops who "~s is not a reference bytevector" bv))
(unless (and (fixnum? i)
(not ($fxu< (fx- (bytevector-length bv) (fx- (constant ptr-bytes) 1)) i)))
($oops who "invalid index ~s for ~s" i bv))
(ref bv i))))
(define-who bytevector-reference-set!
(lambda (bv i val)
(unless (reference-bytevector? bv) ($oops who "~s is not a reference bytevector" bv))
(unless (and (fixnum? i)
(not ($fxu< (fx- (bytevector-length bv) (fx- (constant ptr-bytes) 1)) i)))
($oops who "invalid index ~s for ~s" i bv))
(bytevector-reference-set! bv i val)))
(define-who object->reference-address
(lambda (v)
(object->reference-address v)))
(define-who reference-address->object
(lambda (a)
(unless (and (or (fixnum? a) (bignum? a))
(< -1 a (bitwise-arithmetic-shift 1 (constant ptr-bits))))
($oops who "invalid address ~s" a))
(reference-address->object a)))
(define-who reference*-address->object
(let ([ref->obj (foreign-procedure "(cs)s_reference_star_address_object" (uptr) ptr)])
(lambda (a)
(unless (and (or (fixnum? a) (bignum? a))
(< -1 a (bitwise-arithmetic-shift 1 (constant ptr-bits))))
($oops who "invalid address ~s" a))
(ref->obj a))))
(define $split-continuation
(foreign-procedure "(cs)single_continuation"
(scheme-object iptr)
@ -342,6 +393,20 @@
($oops who "~s is not a valid vector length" n))
($make-immobile-vector n 0)])))
(define-who make-reference-bytevector
(let ([$make-reference-bytevector (foreign-procedure "(cs)s_make_reference_bytevector" (uptr) ptr)])
(lambda (n)
(unless (and (fixnum? n) (not ($fxu< (constant maximum-bytevector-length) n)))
($oops who "~s is not a valid bytevector length" n))
($make-reference-bytevector n))))
(define-who make-immobile-reference-bytevector
(let ([$make-immobile-reference-bytevector (foreign-procedure "(cs)s_make_immobile_reference_bytevector" (uptr) ptr)])
(lambda (n)
(unless (and (fixnum? n) (not ($fxu< (constant maximum-bytevector-length) n)))
($oops who "~s is not a valid bytevector length" n))
($make-immobile-reference-bytevector n))))
(define $make-eqhash-vector
(case-lambda
[(n)

1
racket/src/cs/Makefile
View File

@ -259,7 +259,6 @@ future2-demo: $(BUILDDIR)rumble.$(CSO)
$(SCHEME) $(BUILDDIR)chezpart.$(CSO) $(BUILDDIR)rumble.$(CSO) demo/future2.ss
RUMBLE_SRCS = rumble/virtual-register.ss \
rumble/layout.ss \
rumble/check.ss \
rumble/syntax-rule.ss \
rumble/constant.ss \

10
racket/src/cs/README.txt
View File

@ -361,7 +361,7 @@ several different ways:
* When `_bytes` is used as an argument type, beware that a byte
string is not implicitly terminated with a NUL byte. When `_bytes`
is used as a result type, the C result is copied into a fresh byte
string.
string. See also `_bytes/nul-terminated`.
* A `_gcpointer` can only refer to the start of an allocated object,
and never the interior of an 'atomic-interior allocation. Like
@ -377,12 +377,10 @@ several different ways:
a `_pointer`, setting the cell will not cooperate correctly with
the garbage collector.
* Memory allocated with 'nonatomic works only in limited ways. It
cannot be usefully passed to foreign functions, since the layout is
not actually an array of pointers.
* Callbacks are always in atomic mode (i.e., the `#:atomic?` option
in `_fun` and `_cprocedure` is ignored).
in `_fun` and `_cprocedure` is ignored). A callback must be
declared with `#:callback-exns?` to raise an exception that escapes
to an enclosing foreign callout.
Threads, Threads, Atomicity, Atomicity, and Atomicity
-----------------------------------------------------

2
racket/src/cs/compile-file.ss
View File

@ -2,7 +2,7 @@
;; Check to make we're using a build of Chez Scheme
;; that has all the features we need.
(define-values (need-maj need-min need-sub need-dev)
(values 9 5 5 4))
(values 9 5 5 5))
(unless (guard (x [else #f]) (eval 'scheme-fork-version-number))
(error 'compile-file

1
racket/src/cs/rumble.sls
View File

@ -770,7 +770,6 @@
(define none2 '#{none kwcju864gpycc2h151s9atbmo-2}) ; never put this in an emphemeron
(include "rumble/virtual-register.ss")
(include "rumble/layout.ss")
(include "rumble/begin0.ss")
(include "rumble/syntax-rule.ss")
(include "rumble/value.ss")

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

@ -1,13 +1,14 @@
;; Externally, a cpointer can be #f or a byte string, in
;; addition to a cpointer record
(define (cpointer? v)
(or (authentic-cpointer? v)
(not v)
(bytes? v)
(has-cpointer-property? v)))
;; A cpointer's `memory` is either a raw foreign address (i.e., a
;; number), a vector, or a byte string. A bytevector is used
;; for GCable atomic memory, and a vector is used for GCable
;; A cpointer record's `memory` is either a raw foreign address (i.e., a
;; number), bytevector, or flvector. A reference bytevector is used for
;; non-atomic memory.
(define-record-type (cpointer make-cpointer authentic-cpointer?)
(fields memory (mutable tags)))
@ -105,7 +106,7 @@
(raise-argument-error who "cpointer?" p))))
;; Convert a `memory` --- typically a raw foreign address, but possibly
;; a byte string or vector --- to a cpointer, using #f for a NULL
;; a bytevector or flvector --- to a cpointer, using #f for a NULL
;; address:
(define (memory->cpointer x)
(cond
@ -119,7 +120,7 @@
;; Works on unwrapped cpointers:
(define (cpointer-nonatomic? p)
(and (authentic-cpointer? p)
(#%vector? (cpointer-memory p))))
(reference-bytevector? (cpointer-memory p))))
;; Works on unwrapped cpointers:
(define (cpointer->name proc-p)
@ -128,29 +129,33 @@
;; ----------------------------------------
(define (object->addr v) ; call with GC disabled
(#%$object-address v 0))
(define (address->object n) ; call with GC disabled
(#%$address->object n 0))
(define (bytevector->addr bv) ; call with GC disabled or locked object
(#%$object-address bv bytevector-content-offset))
(define (vector->addr bv) ; call with GC disabled or locked object
(#%$object-address bv vector-content-offset))
(define (flvector->addr bv) ; call with GC disabled or locked object
(#%$object-address bv flvector-content-offset))
;; Convert a raw foreign address to a Scheme value on the
;; assumption that the address is the payload of a byte
;; string:
(define (addr->gcpointer-memory v) ; call with GC disabled
(#%$address->object v bytevector-content-offset))
(define (addr->gcpointer-memory v) ; call with GC disabled
(reference-address->object v))
(define (addr->vector v) ; call with GC disabled or when result is locked
(#%$address->object v vector-content-offset))
;; Converts a primitive cpointer (normally the result of
;; `unwrap-cpointer`) to a memory plus offset
(define (cpointer-address+offset p)
(cond
[(not p) (values 0 0)]
[(or (bytevector? p) (flvector? p)) (values p 0)]
[(cpointer+offset? p)
(values (cpointer-memory p) (cpointer+offset-offset p))]
[(authentic-cpointer? p)
(values (cpointer-memory p) 0)]
[(ffi-callback? p)
(values (foreign-callable-entry-point (callback-code p)) 0)]
[else
(raise-arguments-error 'internal-error "bad case extracting a cpointer address"
"value" p)]))
;; Convert a `memory` (as in a cpointer) to a raw foreign address.
(define (memory-address memory) ; call with GC disabled
(cond
[(integer? memory) memory]
[else (object->reference-address memory)]))
;; Converts a primitive cpointer (normally the result of
;; `unwrap-cpointer`) to a raw foreign address. The
@ -158,19 +163,8 @@
;; which might be the address of a byte string that
;; could otherwise change due to a GC.
(define (cpointer-address p) ; call with GC disabled
(cond
[(not p) 0]
[(bytes? p) (memory-address p)]
[(cpointer+offset? p)
(let ([memory (cpointer-memory p)])
(+ (memory-address memory) (cpointer+offset-offset p)))]
[(authentic-cpointer? p)
(memory-address (cpointer-memory p))]
[(ffi-callback? p)
(foreign-callable-entry-point (callback-code p))]
[else
(raise-arguments-error 'internal-error "bad case extracting a cpointer address"
"value" p)]))
(let-values ([(memory offset) (cpointer-address+offset p)])
(+ (memory-address memory) offset)))
(define (cpointer-needs-lock? p)
(cond
@ -185,34 +179,6 @@
p
(cpointer-address p)))
;; Convert a `memory` (as in a cpointer) to a raw foreign address.
(define (memory-address memory) ; call with GC disabled
(cond
[(integer? memory) memory]
[(bytes? memory) (bytevector->addr memory)]
[(#%vector? memory) (vector->addr memory)] ; used for immobile cells
[(flvector? memory) (flvector->addr memory)]
[else (object->addr memory)]))
;; ----------------------------------------
(define (cpointer-strip p)
(cond
[(not p) 0]
[(bytes? p) p]
[(and (authentic-cpointer? p)
(or (not (cpointer+offset? p))
(zero? (cpointer+offset-offset p))))
(cpointer-memory p)]
[else none]))
(define (stripped-cpointer? v)
(or (eqv? v 0)
(bytes? v)
(#%vector? v)
(flvector? v)
(exact-nonnegative-integer? v)))
;; ----------------------------------------
(define/who (ptr-equal? p1 p2)
@ -291,6 +257,12 @@
;; ----------------------------------------
;; In ctype-host-rep, we use 'uptr and 'void* (which are aliases for foreign-ref)
;; to reflect intent with respect to foreign versus Scheme addresses when reading:
;; - 'uptr => inferred as Scheme or foreign, read as memory instead of address
;; - 'void* => ctype-out-rep ('pointer versus 'gcpointer) implies Scheme or foreign,
;;; and ctype-out-rep is assumed to be correct in that regard
(define-record-type (ctype create-ctype ctype?)
(fields host-rep ; host-Scheme representation description, 'struct, 'union, or 'array
our-rep ; Racket representation description
@ -396,10 +368,6 @@
(define-ctype _uint32 'unsigned-32 'uint32 (integer-checker who unsigned 32 exact-integer?))
(define-ctype _uint64 'unsigned-64 'uint64 (integer-checker who unsigned 64 exact-integer?))
(define-ctype _scheme 'scheme-object 'scheme)
(define-ctype _string/ucs-4 (if (system-big-endian?) 'utf-32be 'utf-32le) 'string/ucs-4
(checker who (lambda (x) (or (not x) (string? x)))))
(define-ctype _string/utf-16 (if (system-big-endian?) 'utf-16be 'utf-16le) 'string/utf-16
(checker who (lambda (x) (or (not x) (string? x)))))
(define-ctype _void 'void 'void (checker who void))
(define (bad-ctype-value who type-name v)
@ -409,7 +377,7 @@
"value" v))
;; Unlike traditional Racket, copies when converting from C:
(define-ctype _bytes 'void* 'bytes
(define-ctype _bytes 'uptr 'bytes
(checker who (lambda (x) (or (not x) (bytes? x))))
(lambda (x)
(cond
@ -433,56 +401,57 @@
bstr)
(loop (fx+ i 1))))])))
(define (subbytes-at-2-byte-nul x offset)
(let ([len (fxand (bytes-length x) (fxnot 1))])
(let loop ([i offset])
(cond
[(fx= i len) (if (fx= offset 0) x (subbytes x offset len))]
[(and (fx= 0 (bytes-ref x i))
(fx= 0 (bytes-ref x (fx+ i 1))))
(subbytes x offset i)]
[else (loop (fx+ i 2))]))))
(define (uptr->bytevector/two-nuls x)
(cond
[(not x) #f]
[else
(let loop ([i 0])
(if (fx= 0 (if (bytevector? x)
(bytevector-u16-native-ref x i)
(foreign-ref 'unsigned-16 x i)))
(let ([bstr (make-bytes i)])
(memcpy* bstr 0 x 0 i #f)
bstr)
(loop (+ i 2))))]))
(define (uptr->bytes/2-byte-nul x)
(let loop ([i 0])
(if (and (fx= 0 (foreign-ref 'unsigned-8 x i))
(fx= 0 (foreign-ref 'unsigned-8 x (fx+ i 1))))
(let ([bstr (make-bytes i)])
(memcpy* bstr 0 x 0 i #f)
bstr)
(loop (fx+ i 2)))))
(define (subbytes-at-4-byte-nul x offset)
(let ([len (fxand (bytes-length x) (fxnot 3))])
(let loop ([i offset])
(cond
[(fx= i len) (if (fx= offset 0) x (subbytes x offset len))]
[(and (fx= 0 (bytes-ref x i))
(fx= 0 (bytes-ref x (fx+ i 1)))
(fx= 0 (bytes-ref x (fx+ i 2)))
(fx= 0 (bytes-ref x (fx+ i 3))))
(subbytes x offset i)]
[else (loop (fx+ i 4))]))))
(define (uptr->bytes/4-byte-nul x)
(let loop ([i 0])
(if (and (fx= 0 (foreign-ref 'unsigned-8 x i))
(fx= 0 (foreign-ref 'unsigned-8 x (fx+ i 1)))
(fx= 0 (foreign-ref 'unsigned-8 x (fx+ i 2)))
(fx= 0 (foreign-ref 'unsigned-8 x (fx+ i 3))))
(let ([bstr (make-bytes i)])
(memcpy* bstr 0 x 0 i #f)
bstr)
(loop (fx+ i 4)))))
(define-ctype _short_bytes 'void* 'bytes
(define-ctype _short_bytes 'uptr 'bytes
(lambda (form-whom x) x)
(lambda (x) (let loop ([i 0])
(if (fx= 0 (foreign-ref 'unsigned-16 x i))
(let ([bstr (make-bytes i)])
(memcpy* bstr 0 x 0 i #f)
bstr)
(loop (+ i 2))))))
(lambda (x) (uptr->bytevector/two-nuls x)))
(define-ctype _string/utf-16 'uptr 'string/utf-16
(lambda (for-whom x)
(cond
[(not x) #f]
[(string? x) (string->utf16 (string-append x "\x0;") (if (system-big-endian?) 'big 'little))]
[else (bad-ctype-value who for-whom x)]))
(lambda (x) (and x
(not (eq? x 0))
(utf16->string (uptr->bytevector/two-nuls x)
(if (system-big-endian?) 'big 'little)))))
(define (uptr->bytevector/four-nuls x)
(cond
[(not x) #f]
[else
(let loop ([i 0])
(if (eqv? 0 (if (bytevector? x)
(bytevector-u32-native-ref x i)
(foreign-ref 'unsigned-32 x i)))
(let ([bstr (make-bytes i)])
(memcpy* bstr 0 x 0 i #f)
bstr)
(loop (+ i 4))))]))
(define-ctype _string/ucs-4 'uptr 'string/ucs-4
(lambda (for-whom x)
(cond
[(not x) #f]
[(string? x) (string->utf32 (string-append x "\x0;") (if (system-big-endian?) 'big 'little))]
[else (bad-ctype-value who for-whom x)]))
(lambda (x) (and x
(not (eq? x 0))
(utf32->string (uptr->bytevector/four-nuls x)
(if (system-big-endian?) 'big 'little)))))
(define-ctype _double* 'double 'double
(lambda (for-whom x) (if (real? x)
@ -754,7 +723,6 @@
(and (authentic-cpointer? p)
(let ([memory (cpointer-memory p)])
(or (bytes? memory)
(#%vector? memory)
(flvector? memory)))))))
;; ----------------------------------------
@ -872,87 +840,48 @@
[else
(let ([p (unwrap-cpointer 'foreign-ref* orig-p)]
[host-rep (ctype-host-rep type)])
(cond
[(cpointer-nonatomic? p)
(let* ([offset (+ offset (ptr-offset* p))]
[extract-pointer
(lambda ()
(let* ([i (fxsrl offset log-ptr-size-in-bytes)]
[v (#%vector-ref (cpointer-memory p) i)])
(cond
[(eq? 'scheme-object host-rep) v]
[(stripped-cpointer? v) v]
[else
(raise-arguments-error 'ptr-ref
"cannot convert value to a cpointer"
"extracted value" v
"source" orig-p)])))])
(cond
[(and (word-aligned? offset)
(or (eq? 'void* host-rep)
(eq? 'scheme-object host-rep)))
(extract-pointer)]
[(and (word-aligned? offset)
(or (eq? 'utf-16le host-rep)
(eq? 'utf-16be host-rep))
(let ([v (extract-pointer)]
[endian (if (eq? 'utf-16le host-rep)
'little
'big)])
(cond
[(bytevector? v)
(utf16->string (subbytes-at-2-byte-nul v offset) endian #t)]
[(integer? v)
(utf16->string (uptr->bytes/2-byte-nul (+ v offset)) endian #t)]
[else #f])))
=> (lambda (v) v)]
[(and (word-aligned? offset)
(or (eq? 'utf-32le host-rep)
(eq? 'utf-32be host-rep))
(let ([v (extract-pointer)]
[endian (if (eq? 'utf-32le host-rep)
'little
'big)])
(cond
[(bytevector? v)
(utf32->string (subbytes-at-4-byte-nul v offset) endian #t)]
[(integer? v)
(utf32->string (uptr->bytes/4-byte-nul (+ v offset)) endian #t)]
[else #f])))
=> (lambda (v) v)]
[else
(raise-arguments-error 'ptr-ref "unsupported access into non-atomic memory"
"offset" offset
"representation" host-rep
"source" orig-p)]))]
[(or (eq? 'utf-16le host-rep)
(eq? 'utf-16be host-rep)
(eq? 'utf-32le host-rep)
(eq? 'utf-32be host-rep))
(let ([v (with-interrupts-disabled*
(foreign-ref 'uptr (cpointer-address p) offset))])
(case host-rep
[(utf-16le) (utf16->string (uptr->bytes/2-byte-nul v) 'little #t)]
[(utf-16be) (utf16->string (uptr->bytes/2-byte-nul v) 'big #t)]
[(utf-32le) (utf32->string (uptr->bytes/4-byte-nul v) 'little #t)]
[(utf-32be) (utf32->string (uptr->bytes/4-byte-nul v) 'big #t)]))]
[else
;; Disable interrupts to avoid a GC:
(with-interrupts-disabled*
;; Special treatment is needed for 'scheme-object, since the
;; host Scheme rejects the use of 'scheme-object with
;; `foreign-ref`
(let ([v (foreign-ref (if (eq? host-rep 'scheme-object)
'uptr
host-rep)
(cpointer-address p)
offset)])
(case host-rep
[(scheme-object) (address->object v)]
(let-values ([(memory mem-offset) (cpointer-address+offset p)])
(cond
[(and (eq? 'scheme-object host-rep)
(reference-bytevector? memory))
(bytevector-reference-ref memory (+ offset mem-offset))]
[(and (eq? 'uptr host-rep)
(reference-bytevector? memory))
;; used for string conversions; allow Scheme or foreign pointer
(bytevector-reference*-ref memory (+ offset mem-offset))]
[(and (eq? 'void* host-rep)
(reference-bytevector? memory))
;; used for _pointer and _gcpointer
(case (ctype-our-rep type)
[(gcpointer)
(bytevector-reference-ref memory (+ offset mem-offset))]
[else
(case (ctype-our-rep type)
[(gcpointer) (addr->gcpointer-memory v)]
[else v])])))]))])]))
;; Although `bytevector-reference*-ref` would be sensible
;; here, since a non-GCable pointer that overlaps with the
;; GC pages is likely to go wrong with a GC, we return a
;; non-GC-pointer representation and don't automatically
;; fix up a GCable-pointer reference (if for no other reason
;; then consistency with BC)
(if (fx= 8 (foreign-sizeof 'ptr))
(bytevector-u64-native-ref memory (+ mem-offset offset))
(bytevector-u32-native-ref memory (+ mem-offset offset)))])]
[else
;; Disable interrupts to avoid a GC:
(with-interrupts-disabled*
;; Special treatment is needed for 'scheme-object, since the
;; host Scheme rejects the use of 'scheme-object with
;; `foreign-ref`
(let ([v (foreign-ref (if (eq? host-rep 'scheme-object)
'uptr
host-rep)
(+ (memory-address memory) mem-offset)
offset)])
(case host-rep
[(scheme-object) (reference-address->object v)]
[else
(case (ctype-our-rep type)
[(gcpointer) (addr->gcpointer-memory v)]
[else v])])))])))])]))
(define/who ptr-set!
(case-lambda
@ -1049,12 +978,6 @@
(define-fast-ptr-ops ptr-ref/double ptr-set!/double _double flonum? bytevector-ieee-double-native-ref bytevector-ieee-double-native-set! double 3)
(define-fast-ptr-ops ptr-ref/float ptr-set!/float _float flonum? bytevector-ieee-single-native-ref bytevector-ieee-single-native-set! float 2)
(define ptr-size-in-bytes (foreign-sizeof 'void*))
(define log-ptr-size-in-bytes (- (integer-length ptr-size-in-bytes) 1))
(define (word-aligned? offset)
(zero? (fxand offset (fx- ptr-size-in-bytes 1))))
(define (foreign-set!* who type orig-p offset orig-v)
(let ([p (unwrap-cpointer 'foreign-set!* orig-p)])
(cond
@ -1067,162 +990,111 @@
[else
(let ([host-rep (ctype-host-rep type)]
[v (s->c who type orig-v)])
(cond
[(cpointer-nonatomic? p)
(let ([offset (+ offset (ptr-offset* p))])
(cond
[(and (word-aligned? offset)
(or (eq? 'void* host-rep)
(eq? 'scheme-object host-rep)))
(let ([i (fxsrl offset log-ptr-size-in-bytes)])
(if (eq? host-rep 'scheme-object)
(#%vector-set! (cpointer-memory p) i v)
(let ([v (cpointer-strip v)])
(if (eq? v none)
(raise-arguments-error 'ptr-set!
"cannot install value into non-atomic memory"
"value" orig-v
"destination" orig-p)
(#%vector-set! (cpointer-memory p) i v)))))]
[(and (word-aligned? offset)
(or (eq? 'utf-16le host-rep)
(eq? 'utf-16be host-rep)))
(let ([i (fxsrl offset log-ptr-size-in-bytes)]
[endian (if (eq? 'utf-16le host-rep) 'little 'big)])
(#%vector-set! (cpointer-memory p) i (bytes-append (string->utf16 v endian) #vu8(0 0))))]
[(and (word-aligned? offset)
(or (eq? 'utf-32le host-rep)
(eq? 'utf-32be host-rep)))
(let ([i (fxsrl offset log-ptr-size-in-bytes)]
[endian (if (eq? 'utf-32le host-rep) 'little 'big)])
(#%vector-set! (cpointer-memory p) i (bytes-append (string->utf32 v endian) #vu8(0 0 0 0))))]
[else
(raise-arguments-error 'ptr-set! "unsupported assignment into non-atomic memory"
"offset" offset
"representation" host-rep
"value" orig-v
"destination" orig-p)]))]
[(and (cpointer-nonatomic? v)
(not (cpointer/cell? v)))
(raise-arguments-error 'ptr-set!
"cannot install non-atomic pointer into atomic memory"
"non-atomic pointer" orig-v
"atomic destination" orig-p)]
[(or (eq? 'utf-16le host-rep)
(eq? 'utf-16be host-rep)
(eq? 'utf-32le host-rep)
(eq? 'utf-32be host-rep))
(raise-arguments-error 'ptr-set!
"cannot install GC-allocated bytes for string conversion into atomic memory"
"string" orig-v
"atomic destination" orig-p)]
[else
;; Disable interrupts to avoid a GC:
(with-interrupts-disabled*
;; Special treatment is needed for 'scheme-object, since
;; the host Scheme rejects the use of 'scheme-object with
;; `foreign-set!`
(foreign-set! (if (eq? host-rep 'scheme-object)
'uptr
host-rep)
(cpointer-address p)
offset
(case host-rep
[(scheme-object) (object->addr v)]
[(void*) (cpointer-address v)]
[else v])))]))])))
(let-values ([(memory mem-offset) (cpointer-address+offset p)])
(cond
[(and (eq? 'scheme-object host-rep)
(reference-bytevector? memory))
(bytevector-reference-set! memory (+ mem-offset offset) v)]
[(and (or (eq? 'void* host-rep)
(eq? 'uptr host-rep))
(reference-bytevector? memory))
(let ([v (cond
[(not v) #f]
[(bytes? v) v]
[(flvector? v) v]
[(authentic-cpointer? v)
(let-values ([(memory offset) (cpointer-address+offset v)])
(cond
[(integer? memory) (+ memory offset)]
[(zero? offset) memory]
[else (raise-arguments-error 'ptr-set!
"cannot install value into non-atomic memory"
"value" orig-v
"destination" orig-p)]))])])
(cond
[(integer? v)
(if (fx= 8 (foreign-sizeof 'ptr))
(bytevector-u64-native-set! memory (+ mem-offset offset) v)
(bytevector-u32-native-set! memory (+ mem-offset offset) v))]
[else
(bytevector-reference-set! memory (+ mem-offset offset) v)]))]
[else
;; Disable interrupts to avoid a GC:
(with-interrupts-disabled*
;; Special treatment is needed for 'scheme-object, since
;; the host Scheme rejects the use of 'scheme-object with
;; `foreign-set!`
(foreign-set! (if (eq? host-rep 'scheme-object)
'uptr
host-rep)
(+ (memory-address memory) mem-offset)
offset
(case host-rep
[(scheme-object) (object->reference-address v)]
[(void* uptr) (cpointer-address v)]
[else v])))])))])))
(define (memcpy* to to-offset from from-offset len move?)
(let ([to (unwrap-cpointer* 'memcpy to)]
[from (unwrap-cpointer* 'memcpy from)])
(cond
[(or (cpointer-nonatomic? to)
(cpointer-nonatomic? from))
(cond
[(and (cpointer-nonatomic? to)
(cpointer-nonatomic? from))
(let ([to-offset (+ to-offset (ptr-offset* to))]
[from-offset (+ from-offset (ptr-offset* from))])
(cond
[(and (word-aligned? to-offset)
(word-aligned? from-offset)
(word-aligned? len))
(let ([to-i (fxsrl to-offset log-ptr-size-in-bytes)]
[from-i (fxsrl from-offset log-ptr-size-in-bytes)]
[n (fxsrl len log-ptr-size-in-bytes)])
(vector-copy! (cpointer-memory to) to-i
(cpointer-memory from) from-i
(+ from-i n)))]
[else
(raise-arguments-error (if move? 'memmove 'memcpy) "unaligned non-atomic memory transfer"
"destination" to
"source" from
"destination offset" to-offset
"source offset" from-offset
"count" len)]))]
[else
(raise-arguments-error (if move? 'memmove 'memcpy) "cannot copy non-atomic to/from atomic"
"destination" to
"source" from)])]
[else
(with-interrupts-disabled*
(let ([to (+ (cpointer*-address to) to-offset)]
[from (+ (cpointer*-address from) from-offset)])
(with-interrupts-disabled*
(let ([to (+ (cpointer*-address to) to-offset)]
[from (+ (cpointer*-address from) from-offset)])
(cond
[(and move?
;; overlap?
(or (<= to from (+ to len -1))
(<= from to (+ from len -1)))
;; shifting up?
(< from to))
;; Copy from high to low to move in overlapping region
(let loop ([len len])
(unless (fx= len 0)
(cond
[(and (> (fixnum-width) 64)
(fx>= len 8))
(let ([len (fx- len 8)])
(foreign-set! 'integer-64 to len
(foreign-ref 'integer-64 from len))
(loop len))]
[(and (> (fixnum-width) 32)
(fx>= len 4))
(let ([len (fx- len 4)])
(foreign-set! 'integer-32 to len
(foreign-ref 'integer-32 from len))
(loop len))]
[(fx>= len 2)
(let ([len (fx- len 2)])
(foreign-set! 'integer-16 to len
(foreign-ref 'integer-16 from len))
(loop len))]
[else
(let ([len (fx- len 1)])
(foreign-set! 'integer-8 to len
(foreign-ref 'integer-8 from len))
(loop len))])))]
[else
(let loop ([pos 0])
(when (fx< pos len)
(cond
[(and (> (fixnum-width) 64)
(fx<= (fx+ pos 8) len))
(foreign-set! 'integer-64 to pos
(foreign-ref 'integer-64 from pos))
(loop (fx+ pos 8))]
[(and (> (fixnum-width) 32)
(fx<= (fx+ pos 4) len))
(foreign-set! 'integer-32 to pos
(foreign-ref 'integer-32 from pos))
(loop (fx+ pos 4))]
[(fx<= (fx+ pos 2) len)
(foreign-set! 'integer-16 to pos
(foreign-ref 'integer-16 from pos))
(loop (fx+ pos 2))]
[else
(foreign-set! 'integer-8 to pos
(foreign-ref 'integer-8 from pos))
(loop (fx+ pos 1))])))])))])))
[(and move?
;; overlap?
(or (<= to from (+ to len -1))
(<= from to (+ from len -1)))
;; shifting up?
(< from to))
;; Copy from high to low to move in overlapping region
(let loop ([len len])
(unless (fx= len 0)
(cond
[(and (> (fixnum-width) 64)
(fx>= len 8))
(let ([len (fx- len 8)])
(foreign-set! 'integer-64 to len
(foreign-ref 'integer-64 from len))
(loop len))]
[(and (> (fixnum-width) 32)
(fx>= len 4))
(let ([len (fx- len 4)])
(foreign-set! 'integer-32 to len
(foreign-ref 'integer-32 from len))
(loop len))]
[(fx>= len 2)
(let ([len (fx- len 2)])
(foreign-set! 'integer-16 to len
(foreign-ref 'integer-16 from len))
(loop len))]
[else
(let ([len (fx- len 1)])
(foreign-set! 'integer-8 to len
(foreign-ref 'integer-8 from len))
(loop len))])))]
[else
(let loop ([pos 0])
(when (fx< pos len)
(cond
[(and (> (fixnum-width) 64)
(fx<= (fx+ pos 8) len))
(foreign-set! 'integer-64 to pos
(foreign-ref 'integer-64 from pos))
(loop (fx+ pos 8))]
[(and (> (fixnum-width) 32)
(fx<= (fx+ pos 4) len))
(foreign-set! 'integer-32 to pos
(foreign-ref 'integer-32 from pos))
(loop (fx+ pos 4))]
[(fx<= (fx+ pos 2) len)
(foreign-set! 'integer-16 to pos
(foreign-ref 'integer-16 from pos))
(loop (fx+ pos 2))]
[else
(foreign-set! 'integer-8 to pos
(foreign-ref 'integer-8 from pos))
(loop (fx+ pos 1))])))])))))
(define memcpy/memmove
(case-lambda
@ -1302,17 +1174,12 @@
(define (memset* to to-offset byte len)
(let ([to (unwrap-cpointer* 'memset to)])
(cond
[(cpointer-nonatomic? to)
(raise-arguments-error 'memset "cannot set non-atomic"
"destination" to)]
[else
(with-interrupts-disabled*
(let ([to (+ (cpointer*-address to) to-offset)])
(let loop ([to to] [len len])
(unless (fx= len 0)
(foreign-set! 'unsigned-8 to 0 byte)
(loop (+ to 1) (fx- len 1))))))])))
(with-interrupts-disabled*
(let ([to (+ (cpointer*-address to) to-offset)])
(let loop ([to to] [len len])
(unless (fx= len 0)
(foreign-set! 'unsigned-8 to 0 byte)
(loop (+ to 1) (fx- len 1))))))))
(define/who memset
(case-lambda
@ -1435,16 +1302,15 @@
[(eq? mode 'atomic)
(make-cpointer (make-bytevector size) #f)]
[(eq? mode 'nonatomic)
(make-cpointer (#%make-vector (quotient size ptr-size-in-bytes) 0) #f)]
(make-cpointer (make-reference-bytevector size) #f)]
[(eq? mode 'atomic-interior)
;; This is not quite the same as Racket BC, because interior
;; pointers are not allowed as GCable pointers. So, "interior"
;; just means "doesn't move".
(let* ([bstr (make-immobile-bytevector size)])
(make-cpointer bstr #f))]
(make-cpointer (make-immobile-bytevector size) #f)]
[(eq? mode 'interior)
;; Ditto
(make-cpointer (#%make-immobile-vector (quotient size ptr-size-in-bytes) 0) #f)]
(make-cpointer (make-immobile-reference-bytevector size) #f)]
[else
(raise-unsupported-error 'malloc
(format "'~a mode is not supported" mode))]))
@ -1469,24 +1335,24 @@
(define immobile-cells (make-eq-hashtable))
(define (malloc-immobile-cell v)
(let ([vec (make-immobile-vector 1)])
(#%vector-set! vec 0 v)
(let ([vec (make-immobile-reference-bytevector (foreign-sizeof 'ptr))])
(bytevector-reference-set! vec 0 v)
(with-global-lock
(eq-hashtable-set! immobile-cells vec #t))
(make-cpointer/cell vec #f)))
(make-cpointer vec #f)))
(define (free-immobile-cell b)
(with-global-lock
(eq-hashtable-delete! immobile-cells (cpointer-memory b))))
(define (immobile-cell-ref b)
(#%vector-ref (cpointer-memory b) 0))
(bytevector-reference-ref (cpointer-memory b) 0))
(define (immobile-cell->address b)
(vector->addr (cpointer-memory b)))
(object->reference-address (cpointer-memory b)))
(define (address->immobile-cell a)
(make-cpointer/cell (addr->vector a) #f))
(make-cpointer (reference-address->object a) #f))
(define (malloc-mode? v)
(#%memq v '(raw atomic nonatomic tagged
@ -1496,11 +1362,11 @@
(define (end-stubborn-change p)
(raise-unsupported-error 'end-stubborn-change))
(define (extflvector->cpointer extfl-vector)
(raise-unsupported-error 'extflvector->cpointer))
(define/who (extflvector->cpointer extfl-vector)
(raise-unsupported-error who))
(define (vector->cpointer vec)
(make-cpointer vec #f))
(define/who (vector->cpointer vec)
(raise-unsupported-error who))
(define (flvector->cpointer flvec)
(make-cpointer flvec #f))
@ -1717,11 +1583,11 @@
[unwrap (lambda (arg in-type)
(let ([c (s->c name in-type arg)])
(if (cpointer? c)
(unwrap-cpointer-for-foreign-call c arg proc-p)
(unwrap-cpointer 'ffi-call c)
c)))]
[unpack (lambda (arg in-type)
(case (array-rep-to-pointer-rep (ctype-host-rep in-type))
[(void*) (cpointer-address arg)]
[(void* uptr) (cpointer-address arg)]
[else arg]))])
(do-procedure-reduce-arity-mask
(cond
@ -1787,7 +1653,7 @@
(let ([arg (s->c name in-type orig-arg)])
(if (and (cpointer? arg)
(not (eq? 'scheme-object (ctype-host-rep in-type))))
(unwrap-cpointer-for-foreign-call arg orig-arg proc-p)
(unwrap-cpointer 'ffi-call arg)
arg)))
orig-args in-types)]
[r (let ([ret-ptr (and ret-id
@ -1809,7 +1675,7 @@
(let ([host-rep (array-rep-to-pointer-rep
(ctype-host-rep in-type))])
(case host-rep
[(void*) (cpointer-address arg)]
[(void* uptr) (cpointer-address arg)]
[(struct union)
(maker (cpointer-address arg))]
[else arg])))
@ -1886,7 +1752,7 @@
[addr (ftype-pointer-address (car args))])
(memcpy* addr 0 v 0 size #f))
(case (ctype-host-rep out-type)
[(void*) (cpointer-address v)]
[(void* uptr) (cpointer-address v)]
[else v]))))))])))
(define (types->reps types next!-id)
@ -1901,16 +1767,6 @@
(loop (cdr types) (cons id reps) (append id-decls decls)))
(loop (cdr types) (cons (ctype-host-rep type) reps) decls)))])))
(define (unwrap-cpointer-for-foreign-call arg orig-arg proc-p)
(let ([p (unwrap-cpointer 'ffi-call arg)])
(when (and (cpointer-nonatomic? p)
(not (cpointer/cell? p)))
(raise-arguments-error 'foreign-call "cannot pass non-atomic pointer to a function"
"pointer" arg
"function" (or (cpointer->name proc-p)
'unknown)))
p))
;; Rely on the fact that a virtual register defaults to 0 to detect a
;; thread that we didn't start. For a thread that we did start, a
(define PLACE-UNKNOWN-THREAD 0)

5
racket/src/cs/rumble/layout.ss
View File

@ -1,5 +0,0 @@
;; HACK: hardwired numbers that depend on the tagging regime
;; and other representation details
(define bytevector-content-offset 9)
(define flvector-content-offset 9)
(define vector-content-offset (if (> (fixnum-width) 32) 9 5))

2
racket/src/version/racket_version.h
View File

@ -16,7 +16,7 @@
#define MZSCHEME_VERSION_X 8
#define MZSCHEME_VERSION_Y 1
#define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 5
#define MZSCHEME_VERSION_W 6
/* A level of indirection makes `#` work as needed: */
#define AS_a_STR_HELPER(x) #x