diff --git a/.makefile b/.makefile index c292e3b6f3..d4381fca00 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.6-1 +PB_BRANCH == circa-8.1.0.6-2 PB_REPO = https://github.com/racket/pb # Set to empty for Git before v1.7.10: diff --git a/Makefile b/Makefile index 84499b1c31..b35b371d1e 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.6-1 +PB_BRANCH = circa-8.1.0.6-2 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.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 + if [ ! -d racket/src/ChezScheme/boot/pb ] ; then git clone -q $(SINGLE_BRANCH_FLAG) -b circa-8.1.0.6-2 $(PB_REPO) racket/src/ChezScheme/boot/pb ; else cd racket/src/ChezScheme/boot/pb && git fetch -q origin circa-8.1.0.6-2:remotes/origin/circa-8.1.0.6-2 ; fi + cd racket/src/ChezScheme/boot/pb && git remote set-branches origin circa-8.1.0.6-2 + cd racket/src/ChezScheme/boot/pb && git checkout -q circa-8.1.0.6-2 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.6-1 - cd racket/src/ChezScheme/boot/pb && git checkout circa-8.1.0.6-1 + cd racket/src/ChezScheme/boot/pb && git branch circa-8.1.0.6-2 + cd racket/src/ChezScheme/boot/pb && git checkout circa-8.1.0.6-2 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.6-1 + cd racket/src/ChezScheme/boot/pb && git push -u origin circa-8.1.0.6-2 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/racket/src/ChezScheme/IMPLEMENTATION.md b/racket/src/ChezScheme/IMPLEMENTATION.md index 48b140986d..1ea21b916a 100644 --- a/racket/src/ChezScheme/IMPLEMENTATION.md +++ b/racket/src/ChezScheme/IMPLEMENTATION.md @@ -320,10 +320,10 @@ For example, if "cmacro.ss" says then that means an address with only the lowest bit set among the low three bits refers to a pair. To get the address where the pair content -is stored, round *up* to the nearest word. So, on a 64-bit machine, -add 7 to get to the `car` and add 15 to get to the `cdr`. Since -allocation on a 64-byte machine is 16-byte aligned, the hexadecimal -form of every pair pointer will end in "9". +is stored, round *up* to the nearest multiple 8 bytes. So, on a 64-bit +machine, add 7 to get to the `car` and add 15 to get to the `cdr`. +Since allocation on a 64-byte machine is 16-byte aligned, the +hexadecimal form of every pair pointer will end in "9". The `type-typed-object` type, @@ -337,14 +337,14 @@ of a Scheme record, that first word will be a record-type descriptor as a record. The based record type, `#!base-rtd` has itself as its record type. Since the type bits are all ones, on a 64-bit machine, every object tagged with an additional type workd will end in "F" in -hexadecimal, and adding 1 to the pointer produces the
= n) { @@ -477,7 +477,8 @@ void S_get_more_room() { ptr xp; uptr ap, type, size; xp = XP(tc); - if ((type = TYPEBITS(xp)) == 0) type = typemod; + type = TYPEBITS(xp); + if ((type_untyped != 0) && (type == 0)) type = type_untyped; ap = (uptr)UNTYPE(xp, type); size = (uptr)((iptr)AP(tc) - (iptr)ap); @@ -1070,7 +1071,7 @@ ptr S_relocation_table(n) iptr n; { ptr p; iptr d; d = size_reloc_table(n); - newspace_find_room(tc, typemod, d, p); + newspace_find_room(tc, type_untyped, d, p); RELOCSIZE(p) = n; return p; } diff --git a/racket/src/ChezScheme/c/gc.c b/racket/src/ChezScheme/c/gc.c index 555b21954f..49b98b4b9c 100644 --- a/racket/src/ChezScheme/c/gc.c +++ b/racket/src/ChezScheme/c/gc.c @@ -223,7 +223,7 @@ static void record_dirty_segment PROTO((IGEN from_g, IGEN to_g, seginfo *si)); static void setup_sweep_dirty PROTO((thread_gc *tgc)); static uptr sweep_dirty_segments PROTO((thread_gc *tgc, seginfo **dirty_segments)); static void resweep_dirty_weak_pairs PROTO((thread_gc *tgc)); -static void mark_typemod_data_object PROTO((thread_gc *tgc, ptr p, uptr len, seginfo *si)); +static void mark_untyped_data_object PROTO((thread_gc *tgc, ptr p, uptr len, seginfo *si)); static void add_pending_guardian PROTO((ptr gdn, ptr tconc)); static void add_trigger_guardians_to_recheck PROTO((ptr ls)); static void add_ephemeron_to_pending PROTO((thread_gc *tgc, ptr p)); @@ -805,7 +805,7 @@ static ptr copy_stack(thread_gc *tgc, ptr old, iptr *length, iptr clength) { #ifndef NO_NEWSPACE_MARKS if (si->use_marks) { if (!marked(si, old)) { - mark_typemod_data_object(tgc, old, n, si); + mark_untyped_data_object(tgc, old, n, si); #ifdef ENABLE_OBJECT_COUNTS S_G.countof[newg][countof_stack] += 1; @@ -831,7 +831,7 @@ static ptr copy_stack(thread_gc *tgc, ptr old, iptr *length, iptr clength) { if (n == 0) { return (ptr)0; } else { - find_gc_room(tgc, space_data, newg, typemod, n, new); + find_gc_room(tgc, space_data, newg, type_untyped, n, new); n = ptr_align(clength); /* warning: stack may have been left non-double-aligned by split_and_resize */ memcpy_aligned(TO_VOIDP(new), TO_VOIDP(old), n); @@ -1466,7 +1466,7 @@ ptr GCENTRY(ptr tc, ptr count_roots_ls) { /* In backreference mode, we rely on sweep of the guardian entry not registering any backreferences. Otherwise, bogus pair pointers would get created. */ - find_gc_room(tgc, space_pure, g, typemod, size_guardian_entry, p); + find_gc_room(tgc, space_pure, g, type_untyped, size_guardian_entry, p); INITGUARDIANOBJ(p) = GUARDIANOBJ(ls); INITGUARDIANREP(p) = rep; INITGUARDIANTCONC(p) = tconc; @@ -2060,7 +2060,7 @@ void enlarge_stack(thread_gc *tgc, ptr *stack, ptr *stack_start, ptr *stack_limi uptr new_sz = 2 * ((sz == 0) ? (uptr)sweep_stack_min_size : sz); ptr new_stack; if (new_sz - sz < grow_at_least) new_sz += grow_at_least; - find_gc_room(tgc, space_data, 0, typemod, ptr_align(new_sz), new_stack); + find_gc_room(tgc, space_data, 0, type_untyped, ptr_align(new_sz), new_stack); if (sz != 0) memcpy(TO_VOIDP(new_stack), TO_VOIDP(*stack_start), sz); tgc->bitmask_overhead[0] += ptr_align(new_sz); diff --git a/racket/src/ChezScheme/c/scheme.c b/racket/src/ChezScheme/c/scheme.c index d9af390a6c..7d19623912 100644 --- a/racket/src/ChezScheme/c/scheme.c +++ b/racket/src/ChezScheme/c/scheme.c @@ -273,6 +273,14 @@ static void idiot_checks() { fprintf(stderr, "sizeof(string_char) [%ld] != string_char_bytes [%d]\n", (long)sizeof(string_char), string_char_bytes); oops = 1; } + if (TYPE((ptr)0, type_untyped) != (ptr)0) { + fprintf(stderr, "tagging with type_untyped changes an address\n"); + oops = 1; + } + if (record_ptr_offset != record_type_disp) { + fprintf(stderr, "record_ptr_offset != record_type_disp\n"); + oops = 1; + } if (UNFIX(fixtest) != -1) { fprintf(stderr, "UNFIX operation failed\n"); oops = 1; diff --git a/racket/src/ChezScheme/c/types.h b/racket/src/ChezScheme/c/types.h index e389df5c80..e2c4804d5e 100644 --- a/racket/src/ChezScheme/c/types.h +++ b/racket/src/ChezScheme/c/types.h @@ -92,8 +92,8 @@ typedef int IFASLCODE; /* fasl type codes */ #define find_room(tc, s, g, t, n, x) find_gc_room_T(THREAD_GC(tc), s, g, t, n, ALREADY_PTR, x) #define find_gc_room(tgc, s, g, t, n, x) find_gc_room_T(tgc, s, g, t, n, ALREADY_PTR, x) -#define find_room_voidp(tc, s, g, n, x) find_gc_room_T(THREAD_GC(tc), s, g, typemod, n, TO_VOIDP, x) -#define find_gc_room_voidp(tgc, s, g, n, x) find_gc_room_T(tgc, s, g, typemod, n, TO_VOIDP, x) +#define find_room_voidp(tc, s, g, n, x) find_gc_room_T(THREAD_GC(tc), s, g, type_untyped, n, TO_VOIDP, x) +#define find_gc_room_voidp(tgc, s, g, n, x) find_gc_room_T(tgc, s, g, type_untyped, n, TO_VOIDP, x) /* new-space inline allocation --- no mutex required */ /* Like `find_room`, but always `space_new` and generation 0, @@ -111,7 +111,7 @@ typedef int IFASLCODE; /* fasl type codes */ } while(0) #define newspace_find_room(tc, t, n, x) newspace_find_room_T(tc, t, n, ALREADY_PTR, x) -#define newspace_find_room_voidp(tc, n, x) newspace_find_room_T(tc, typemod, n, TO_VOIDP, x) +#define newspace_find_room_voidp(tc, n, x) newspace_find_room_T(tc, type_untyped, n, TO_VOIDP, x) #ifndef NO_PRESERVE_FLONUM_EQ # define PRESERVE_FLONUM_EQ diff --git a/racket/src/ChezScheme/c/vfasl.c b/racket/src/ChezScheme/c/vfasl.c index c86bd94041..79434d56b1 100644 --- a/racket/src/ChezScheme/c/vfasl.c +++ b/racket/src/ChezScheme/c/vfasl.c @@ -135,9 +135,9 @@ ptr S_vfasl(ptr bv, void *stream, iptr offset, iptr input_len) uptr sz = vspace_offsets[s+1] - vspace_offsets[s]; if (sz > 0) { if ((s == vspace_reloc) && to_static && !S_G.retain_static_relocation) { - newspace_find_room(tc, typemod, sz, vspaces[s]); + newspace_find_room(tc, type_untyped, sz, vspaces[s]); } else { - find_room(tc, vspace_spaces[s], (to_static ? static_generation : 0), typemod, sz, vspaces[s]); + find_room(tc, vspace_spaces[s], (to_static ? static_generation : 0), type_untyped, sz, vspaces[s]); } if (bv) { memcpy(TO_VOIDP(vspaces[s]), bv_addr, sz); @@ -146,7 +146,7 @@ ptr S_vfasl(ptr bv, void *stream, iptr offset, iptr input_len) ptr dest; #ifdef CANNOT_READ_DIRECTLY_INTO_CODE if (s == vspace_code) - newspace_find_room(tc, typemod, sz, dest); + newspace_find_room(tc, type_untyped, sz, dest); else dest = vspaces[s]; #else @@ -170,7 +170,7 @@ ptr S_vfasl(ptr bv, void *stream, iptr offset, iptr input_len) if (bv) table = TO_PTR(bv_addr); else { - newspace_find_room(tc, typemod, ptr_align(VFASLHEADER_TABLE_SIZE(header)), table); + newspace_find_room(tc, type_untyped, ptr_align(VFASLHEADER_TABLE_SIZE(header)), table); if (S_fasl_stream_read(stream, TO_VOIDP(table), VFASLHEADER_TABLE_SIZE(header)) < 0) S_error("fasl-read", "input truncated"); } @@ -489,7 +489,7 @@ static void relink_code(ptr co, ptr sym_base, ptr *vspaces, uptr *vspace_offsets ptr tc = get_thread_context(); iptr sz = size_reloc_table(RELOCSIZE(t)); ptr new_t; - find_room(tc, space_data, static_generation, typemod, ptr_align(sz), new_t); + find_room(tc, space_data, static_generation, type_untyped, ptr_align(sz), new_t); memcpy(TO_VOIDP(new_t), TO_VOIDP(t), sz); t = new_t; CODERELOC(co) = t; diff --git a/racket/src/ChezScheme/rktboot/constant.rkt b/racket/src/ChezScheme/rktboot/constant.rkt index 9f6cf4f014..50087fc737 100644 --- a/racket/src/ChezScheme/rktboot/constant.rkt +++ b/racket/src/ChezScheme/rktboot/constant.rkt @@ -53,6 +53,10 @@ [(=) (= (constant-eval (cadr e) ht) (constant-eval (caddr e) ht))] + [(fx- -) + (apply - (map (lambda (e) (constant-eval e esc)) (cdr e)))] + [(fx+ +) + (apply + (map (lambda (e) (constant-eval e esc)) (cdr e)))] [(quote) (cadr e)] [else (esc)])] @@ -88,7 +92,5 @@ prelex-sticky-mask prelex-is-mask scheme-version - code-flag-lift-barrier) - -(provide record-ptr-offset) -(define record-ptr-offset 1) + code-flag-lift-barrier + record-ptr-offset) diff --git a/racket/src/ChezScheme/s/cmacros.ss b/racket/src/ChezScheme/s/cmacros.ss index 3bce6f12f3..f7cdeb2d05 100644 --- a/racket/src/ChezScheme/s/cmacros.ss +++ b/racket/src/ChezScheme/s/cmacros.ss @@ -809,6 +809,10 @@ (define-constant type-immediate #b110) (define-constant type-typed-object #b111) +;; Applying this type tag to an address shouldproduce a pointer +;; that's equal to the address: +(define-constant type-untyped (constant typemod)) + ;; --------------------------------------------------------------------- ;; Immediate values; note that these all end with `type-immediate`: @@ -1305,6 +1309,9 @@ [else x]))]))) ) +;; This is the same as `record-type-disp`, but helps bootstrap: +(define-constant record-ptr-offset (- (constant typemod) (constant type-record))) + (define-syntax define-primitive-structure-disps (lambda (x) (include "layout.ss") @@ -1515,7 +1522,7 @@ [ptr pinfo*] [octet data 0])) -(define-primitive-structure-disps reloc-table typemod +(define-primitive-structure-disps reloc-table type-untyped ([iptr size] [ptr code] [uptr data 0])) @@ -1542,7 +1549,7 @@ (define-constant maximum-parallel-collect-threads 16) ;;; make sure gc sweeps all ptrs -(define-primitive-structure-disps tc typemod +(define-primitive-structure-disps tc type-untyped ([xptr arg-regs (constant asm-arg-reg-max)] [xptr ac0] [xptr ac1] @@ -1682,7 +1689,7 @@ (+ b (constant ptr-bytes)) (cdr e*)))]))))))) -(define-primitive-structure-disps guardian-entry typemod +(define-primitive-structure-disps guardian-entry type-untyped ([ptr obj] [ptr rep] [ptr tconc] @@ -1697,15 +1704,15 @@ ;;; forwarding addresses are recorded with a single forward-marker ;;; bit pattern (a special Scheme object) followed by the forwarding ;;; address, a ptr to the forwarded object. -(define-primitive-structure-disps forward typemod +(define-primitive-structure-disps forward type-untyped ([ptr marker] [ptr address])) -(define-primitive-structure-disps cached-stack typemod +(define-primitive-structure-disps cached-stack type-untyped ([iptr size] [ptr link])) -(define-primitive-structure-disps rp-header typemod +(define-primitive-structure-disps rp-header type-untyped ([uptr toplink] [uptr mv-return-address] [ptr livemask] @@ -1719,7 +1726,7 @@ (define-constant return-address-livemask-disp (- (constant rp-header-livemask-disp) (constant size-rp-header))) -(define-primitive-structure-disps rp-compact-header typemod +(define-primitive-structure-disps rp-compact-header type-untyped ([uptr toplink] [iptr mask+size+mode])) ; low bit is 1 to distinguish from a `rp-header` ;; mask+size+mode: bit 0 is 1 [=> compact-header-mask] @@ -2237,7 +2244,7 @@ (define-constant vspaces-offsets-count (- (constant vspaces-count) 1)) -(define-primitive-structure-disps vfasl-header typemod +(define-primitive-structure-disps vfasl-header type-untyped ([uptr data-size] [uptr table-size] diff --git a/racket/src/ChezScheme/s/cpnanopass.ss b/racket/src/ChezScheme/s/cpnanopass.ss index cdf04166fe..ce99c1280a 100644 --- a/racket/src/ChezScheme/s/cpnanopass.ss +++ b/racket/src/ChezScheme/s/cpnanopass.ss @@ -5312,7 +5312,7 @@ (if ,(%inline eq? ,%sfp ,(%constant snil)) ,(%seq (set! ,%ac0 ,%xp) - (set! ,%xp ,(%constant-alloc typemod (constant default-stack-size))) + (set! ,%xp ,(%constant-alloc type-untyped (constant default-stack-size))) (set! ,%sfp ,%xp) (set! ,(%tc-ref scheme-stack) ,%sfp) (set! ,(%tc-ref scheme-stack-size) ,(%constant default-stack-size)) diff --git a/racket/src/ChezScheme/s/cpprim.ss b/racket/src/ChezScheme/s/cpprim.ss index 891454f1af..adfc4d1cc4 100644 --- a/racket/src/ChezScheme/s/cpprim.ss +++ b/racket/src/ChezScheme/s/cpprim.ss @@ -3443,7 +3443,7 @@ (define-inline 3 $install-guardian [(e-obj e-rep e-tconc ordered?) (bind #f (e-obj e-rep e-tconc ordered?) - (bind #t ([t (%constant-alloc typemod (constant size-guardian-entry))]) + (bind #t ([t (%constant-alloc type-untyped (constant size-guardian-entry))]) (%seq (set! ,(%mref ,t ,(constant guardian-entry-obj-disp)) ,e-obj) (set! ,(%mref ,t ,(constant guardian-entry-rep-disp)) ,e-rep) @@ -3456,7 +3456,7 @@ (define-inline 3 $install-ftype-guardian [(e-obj e-tconc) (bind #f (e-obj e-tconc) - (bind #t ([t (%constant-alloc typemod (constant size-guardian-entry))]) + (bind #t ([t (%constant-alloc type-untyped (constant size-guardian-entry))]) (%seq (set! ,(%mref ,t ,(constant guardian-entry-obj-disp)) ,e-obj) (set! ,(%mref ,t ,(constant guardian-entry-rep-disp)) (immediate ,(constant ftype-guardian-rep))) @@ -7872,7 +7872,7 @@ ,(%primcall #f sexpr $gensym->pretty-name ,e-sym))))]) (define-inline 3 $fxaddress [(e) (%inline logand - ,(let ([n (- (log2 (constant typemod)) (constant fixnum-offset))]) + ,(let ([n (- (constant primary-type-bits) (constant fixnum-offset))]) (if (> n 0) (%inline sra ,e (immediate ,n)) e)) (immediate ,(- (constant fixnum-factor))))]) (define-inline 3 $set-timer diff --git a/racket/src/ChezScheme/s/mkgc.ss b/racket/src/ChezScheme/s/mkgc.ss index 51b660573f..3e66dc1dce 100644 --- a/racket/src/ChezScheme/s/mkgc.ss +++ b/racket/src/ChezScheme/s/mkgc.ss @@ -1143,10 +1143,10 @@ [(-> t_si use_marks) (cond [(! (marked t_si t)) - (mark_typemod_data_object _tgc_ t n t_si)])] + (mark_untyped_data_object _tgc_ t n t_si)])] [else (let* ([oldt : ptr t]) - (find_gc_room _tgc_ space_data from_g typemod n t) + (find_gc_room _tgc_ space_data from_g type-untyped n t) (memcpy_aligned (TO_VOIDP t) (TO_VOIDP oldt) n))])] [else (RECORD_REMOTE t_si)]))) @@ -2176,7 +2176,7 @@ final "}"))] [type (let ([t (lookup 'basetype config)]) - (if (eq? t 'typemod) + (if (eq? t 'type-untyped) #f (as-c 'type (lookup 'basetype config))))] [untype (lambda () @@ -2526,13 +2526,13 @@ (parallel? ,parallel?)))) (print-code (generate "object_directly_refers_to_self" `((mode self-test)))) - (print-code (code "static void mark_typemod_data_object(thread_gc *tgc, ptr p, uptr p_sz, seginfo *si)" + (print-code (code "static void mark_untyped_data_object(thread_gc *tgc, ptr p, uptr p_sz, seginfo *si)" (code-block (ensure-segment-mark-mask "si" "") (mark-statement '(one-bit no-sweep) (cons (list 'used (make-eq-hashtable)) - '((basetype typemod))))))) + '((basetype type-untyped))))))) (when measure? (print-code (generate "measure" `((mode measure)))))))) diff --git a/racket/src/ChezScheme/s/vfasl.ss b/racket/src/ChezScheme/s/vfasl.ss index de3d0acb26..a827e9ee56 100644 --- a/racket/src/ChezScheme/s/vfasl.ss +++ b/racket/src/ChezScheme/s/vfasl.ss @@ -1030,7 +1030,7 @@ (let* ([new-p (find-room 'reloc vfi (constant vspace-reloc) (fx+ (constant header-size-reloc-table) (fx* m (constant ptr-bytes))) - (constant typemod))]) + (constant type-untyped))]) (set-uptr! new-p (constant reloc-table-size-disp) m vfi) (set-ptr!/no-record new-p (constant reloc-table-code-disp) code-p vfi) (let loop ([n 0] [a 0] [i 0])