diff --git a/.makefile b/.makefile index 916324ccf3..c292e3b6f3 100644 --- a/.makefile +++ b/.makefile @@ -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: diff --git a/Makefile b/Makefile index 52c1566e73..84499b1c31 100644 --- a/Makefile +++ b/Makefile @@ -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)" diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index fc38f94ff2..31192cfa72 100644 --- a/pkgs/base/info.rkt +++ b/pkgs/base/info.rkt @@ -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])) diff --git a/pkgs/racket-doc/scribblings/foreign/pointers.scrbl b/pkgs/racket-doc/scribblings/foreign/pointers.scrbl index fea0463af1..f0953f2998 100644 --- a/pkgs/racket-doc/scribblings/foreign/pointers.scrbl +++ b/pkgs/racket-doc/scribblings/foreign/pointers.scrbl @@ -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]{ diff --git a/pkgs/racket-doc/scribblings/foreign/types.scrbl b/pkgs/racket-doc/scribblings/foreign/types.scrbl index 918a1bba63..da71a5c0d7 100644 --- a/pkgs/racket-doc/scribblings/foreign/types.scrbl +++ b/pkgs/racket-doc/scribblings/foreign/types.scrbl @@ -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 diff --git a/pkgs/racket-test-core/tests/racket/foreign-test.c b/pkgs/racket-test-core/tests/racket/foreign-test.c index 9f71595bea..6c1faf2897 100644 --- a/pkgs/racket-test-core/tests/racket/foreign-test.c +++ b/pkgs/racket-test-core/tests/racket/foreign-test.c @@ -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; diff --git a/pkgs/racket-test-core/tests/racket/foreign-test.rktl b/pkgs/racket-test-core/tests/racket/foreign-test.rktl index 5842092b14..fcc33bc50f 100644 --- a/pkgs/racket-test-core/tests/racket/foreign-test.rktl +++ b/pkgs/racket-test-core/tests/racket/foreign-test.rktl @@ -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])) diff --git a/racket/src/ChezScheme/c/alloc.c b/racket/src/ChezScheme/c/alloc.c index 3af7604bc9..ed9b89c089 100644 --- a/racket/src/ChezScheme/c/alloc.c +++ b/racket/src/ChezScheme/c/alloc.c @@ -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; diff --git a/racket/src/ChezScheme/c/externs.h b/racket/src/ChezScheme/c/externs.h index 97cb4a65a3..c0bc380d0b 100644 --- a/racket/src/ChezScheme/c/externs.h +++ b/racket/src/ChezScheme/c/externs.h @@ -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)); diff --git a/racket/src/ChezScheme/c/fasl.c b/racket/src/ChezScheme/c/fasl.c index d0e4372412..9ef0a3e930 100644 --- a/racket/src/ChezScheme/c/fasl.c +++ b/racket/src/ChezScheme/c/fasl.c @@ -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)); diff --git a/racket/src/ChezScheme/c/flushcache.c b/racket/src/ChezScheme/c/flushcache.c index 6ddcfbef2b..7a520a4ffd 100644 --- a/racket/src/ChezScheme/c/flushcache.c +++ b/racket/src/ChezScheme/c/flushcache.c @@ -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; diff --git a/racket/src/ChezScheme/c/gc.c b/racket/src/ChezScheme/c/gc.c index b704dd878f..555b21954f 100644 --- a/racket/src/ChezScheme/c/gc.c +++ b/racket/src/ChezScheme/c/gc.c @@ -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"); } diff --git a/racket/src/ChezScheme/c/gcwrapper.c b/racket/src/ChezScheme/c/gcwrapper.c index fe71922135..bf82e587bf 100644 --- a/racket/src/ChezScheme/c/gcwrapper.c +++ b/racket/src/ChezScheme/c/gcwrapper.c @@ -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; diff --git a/racket/src/ChezScheme/c/pb.c b/racket/src/ChezScheme/c/pb.c index b522b80ffa..204a69d0dd 100644 --- a/racket/src/ChezScheme/c/pb.c +++ b/racket/src/ChezScheme/c/pb.c @@ -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; diff --git a/racket/src/ChezScheme/c/prim5.c b/racket/src/ChezScheme/c/prim5.c index 9ee0df13ce..bde80442ce 100644 --- a/racket/src/ChezScheme/c/prim5.c +++ b/racket/src/ChezScheme/c/prim5.c @@ -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); diff --git a/racket/src/ChezScheme/c/scheme.c b/racket/src/ChezScheme/c/scheme.c index 58d3cef7a4..d2c2d1c565 100644 --- a/racket/src/ChezScheme/c/scheme.c +++ b/racket/src/ChezScheme/c/scheme.c @@ -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(); } diff --git a/racket/src/ChezScheme/c/segment.h b/racket/src/ChezScheme/c/segment.h index b32b8f7bdc..ce2a5e085a 100644 --- a/racket/src/ChezScheme/c/segment.h +++ b/racket/src/ChezScheme/c/segment.h @@ -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)); +} diff --git a/racket/src/ChezScheme/c/types.h b/racket/src/ChezScheme/c/types.h index 4122b06476..e389df5c80 100644 --- a/racket/src/ChezScheme/c/types.h +++ b/racket/src/ChezScheme/c/types.h @@ -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`. */ diff --git a/racket/src/ChezScheme/csug/foreign.stex b/racket/src/ChezScheme/csug/foreign.stex index 6bf3d272a9..50c73d79cf 100644 --- a/racket/src/ChezScheme/csug/foreign.stex +++ b/racket/src/ChezScheme/csug/foreign.stex @@ -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}} diff --git a/racket/src/ChezScheme/makefiles/Mf-install.in b/racket/src/ChezScheme/makefiles/Mf-install.in index 3cc43429a9..56074a5eaf 100644 --- a/racket/src/ChezScheme/makefiles/Mf-install.in +++ b/racket/src/ChezScheme/makefiles/Mf-install.in @@ -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 diff --git a/racket/src/ChezScheme/mats/5_3.ms b/racket/src/ChezScheme/mats/5_3.ms index bd481fca1f..30bfbdf044 100644 --- a/racket/src/ChezScheme/mats/5_3.ms +++ b/racket/src/ChezScheme/mats/5_3.ms @@ -7264,4 +7264,4 @@ (eqv? 16 (fxpopcount #b1111111111111111)) (eqv? 16 (fxpopcount32 #b1111111111111111)) (eqv? 16 (fxpopcount16 #b1111111111111111)) -) + ) diff --git a/racket/src/ChezScheme/mats/foreign.ms b/racket/src/ChezScheme/mats/foreign.ms index a0d4f6f0f5..029f285006 100644 --- a/racket/src/ChezScheme/mats/foreign.ms +++ b/racket/src/ChezScheme/mats/foreign.ms @@ -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))) +) + diff --git a/racket/src/ChezScheme/mats/primvars.ms b/racket/src/ChezScheme/mats/primvars.ms index 432257a9d2..d8e55f8506 100644 --- a/racket/src/ChezScheme/mats/primvars.ms +++ b/racket/src/ChezScheme/mats/primvars.ms @@ -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] diff --git a/racket/src/ChezScheme/s/cmacros.ss b/racket/src/ChezScheme/s/cmacros.ss index 45c0409580..3bce6f12f3 100644 --- a/racket/src/ChezScheme/s/cmacros.ss +++ b/racket/src/ChezScheme/s/cmacros.ss @@ -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" diff --git a/racket/src/ChezScheme/s/cpprim.ss b/racket/src/ChezScheme/s/cpprim.ss index 64afa52e36..891454f1af 100644 --- a/racket/src/ChezScheme/s/cpprim.ss +++ b/racket/src/ChezScheme/s/cpprim.ss @@ -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! diff --git a/racket/src/ChezScheme/s/mkgc.ss b/racket/src/ChezScheme/s/mkgc.ss index 7a47e47234..51b660573f 100644 --- a/racket/src/ChezScheme/s/mkgc.ss +++ b/racket/src/ChezScheme/s/mkgc.ss @@ -84,8 +84,10 @@ ;; - (trace-now ) : direct recur; implies pure ;; - (trace-early-rtd ) : for record types, avoids recur on #!base-rtd; implies pure ;; - (trace-pure-code ) : like `trace-pure`, but special handling in parallel mode +;; - (trace-reference ) : like `trace`, but for a reference bytevector element ;; - (trace-ptrs ) : trace an array of pointerrs ;; - (trace-pure-ptrs ) : pure analog of `trace-ptrs` +;; - (trace-reference-ptrs ) : like `trace-ptrs`, but for a reference bytevector ;; - (copy ) : copy for copy, ignore otherwise ;; - (copy-bytes ) : copy an array of bytes ;; - (copy-flonum ) : 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 diff --git a/racket/src/ChezScheme/s/primdata.ss b/racket/src/ChezScheme/s/primdata.ss index 0460dcf383..0a49a56280 100644 --- a/racket/src/ChezScheme/s/primdata.ss +++ b/racket/src/ChezScheme/s/primdata.ss @@ -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]) diff --git a/racket/src/ChezScheme/s/prims.ss b/racket/src/ChezScheme/s/prims.ss index 18e93b8741..c276e1ddb0 100644 --- a/racket/src/ChezScheme/s/prims.ss +++ b/racket/src/ChezScheme/s/prims.ss @@ -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) diff --git a/racket/src/cs/Makefile b/racket/src/cs/Makefile index d17a8a1c7c..6b8f0e98ea 100644 --- a/racket/src/cs/Makefile +++ b/racket/src/cs/Makefile @@ -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 \ diff --git a/racket/src/cs/README.txt b/racket/src/cs/README.txt index 95d63e090f..f8e264e061 100644 --- a/racket/src/cs/README.txt +++ b/racket/src/cs/README.txt @@ -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 ----------------------------------------------------- diff --git a/racket/src/cs/compile-file.ss b/racket/src/cs/compile-file.ss index 83dc818ddc..3bcfd48856 100644 --- a/racket/src/cs/compile-file.ss +++ b/racket/src/cs/compile-file.ss @@ -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 diff --git a/racket/src/cs/rumble.sls b/racket/src/cs/rumble.sls index e7e5f5b84f..ed097ba98d 100644 --- a/racket/src/cs/rumble.sls +++ b/racket/src/cs/rumble.sls @@ -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") diff --git a/racket/src/cs/rumble/foreign.ss b/racket/src/cs/rumble/foreign.ss index 21df34a73b..1d004bb502 100644 --- a/racket/src/cs/rumble/foreign.ss +++ b/racket/src/cs/rumble/foreign.ss @@ -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) diff --git a/racket/src/cs/rumble/layout.ss b/racket/src/cs/rumble/layout.ss deleted file mode 100644 index 443b8a9c42..0000000000 --- a/racket/src/cs/rumble/layout.ss +++ /dev/null @@ -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)) diff --git a/racket/src/version/racket_version.h b/racket/src/version/racket_version.h index 4cf66d1046..b5b6936cc6 100644 --- a/racket/src/version/racket_version.h +++ b/racket/src/version/racket_version.h @@ -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