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

eliminated some direct assumptions that a vector's type/length field

Browse Source 
is a fixnum and added meta-asserts to verify that it is in a couple of
others, to facilitate future changes to vector typing.  vectors are
now treated essentially like fxvectors, strings, and bytevectors.
  cmacros.ss, cpnanopass.ss, prims.ss, mkheader.ss,
  alloc.c, gc.c, scheme.c

original commit: 564542d32bbae6b33cef808613238d5a4a2a8ee2
This commit is contained in:
Kent Dybvig 2017-03-12 23:54:38 -04:00
parent e84263d85e
commit 9a16156574
8 changed files with 155 additions and 146 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
LOG
View File

@ -340,13 +340,21 @@
the trace procedures or syntactic forms, procedure-arity-mask the trace procedures or syntactic forms, procedure-arity-mask
may report counts that are not actually allowed by the source may report counts that are not actually allowed by the source
procedure. procedure.
cmacros.ss, compile.ss, cpnanopass.ss, mkheader.ss, primdata.ss, cmacros.ss, compile.ss, cpnanopass.ss, mkheader.ss, primdata.ss,
prims.ss, strip.ss, prims.ss, strip.ss,
fasl.c, gc.c, globals.h, prim.c, prim5.c, scheme.c, schsig.c, fasl.c, gc.c, globals.h, prim.c, prim5.c, scheme.c, schsig.c,
misc.ms, root-experr*, misc.ms, root-experr*,
objects.stex objects.stex
- for non-win32 systems, now setting al register to a count of the - for non-win32 systems, now setting al register to a count of the
floating-point register arguments as required for varargs functions floating-point register arguments as required for varargs functions
by the System V ABI. by the System V ABI.
x86_64.ss, x86_64.ss,
foreign.ms foreign.ms
- added a missing quote mark in new printf mat Windows case
foreign.ms
- eliminated some direct assumptions that a vector's type/length field
is a fixnum and added meta-asserts to verify that it is in a couple of
others, to facilitate future changes to vector typing. vectors are
now treated essentially like fxvectors, strings, and bytevectors.
cmacros.ss, cpnanopass.ss, prims.ss, mkheader.ss,
alloc.c, gc.c, scheme.c

9
c/alloc.c
View File

@ -47,8 +47,7 @@ void S_alloc_init() {
S_protect(&S_G.null_vector); S_protect(&S_G.null_vector);
find_room(space_new, 0, type_typed_object, size_vector(0), S_G.null_vector); find_room(space_new, 0, type_typed_object, size_vector(0), S_G.null_vector);
/* vector type/length field is a fixnum */ VECTTYPE(S_G.null_vector) = (0 << vector_length_offset) | type_vector;
VECTTYPE(S_G.null_vector) = FIX(0);
S_protect(&S_G.null_fxvector); S_protect(&S_G.null_fxvector);
find_room(space_new, 0, type_typed_object, size_fxvector(0), S_G.null_fxvector); find_room(space_new, 0, type_typed_object, size_fxvector(0), S_G.null_fxvector);
@ -498,8 +497,7 @@ ptr S_vector_in(s, g, n) ISPC s; IGEN g; iptr n; {
d = size_vector(n); d = size_vector(n);
/* S_vector_in always called with mutex */ /* S_vector_in always called with mutex */
find_room(s, g, type_typed_object, d, p); find_room(s, g, type_typed_object, d, p);
/* vector type/length field is a fixnum */ VECTTYPE(p) = (n << vector_length_offset) | type_vector;
VECTTYPE(p) = FIX(n);
return p; return p;
} }
@ -516,8 +514,7 @@ ptr S_vector(n) iptr n; {
d = size_vector(n); d = size_vector(n);
thread_find_room(tc, type_typed_object, d, p); thread_find_room(tc, type_typed_object, d, p);
/* vector type/length field is a fixnum */ VECTTYPE(p) = (n << vector_length_offset) | type_vector;
VECTTYPE(p) = FIX(n);
return p; return p;
} }

10
c/gc.c
View File

@ -258,8 +258,7 @@ static ptr copy(pp, pps) ptr pp; ISPC pps; {
if (m != n) if (m != n)
*((ptr *)((uptr)UNTYPE(p,type_typed_object) + m)) = FIX(0); *((ptr *)((uptr)UNTYPE(p,type_typed_object) + m)) = FIX(0);
} }
} else if (TYPEP(tf, mask_fixnum, type_fixnum)) { } else if (TYPEP(tf, mask_vector, type_vector)) {
/* vector type/length field is a fixnum */
iptr len, n; iptr len, n;
len = Svector_length(pp); len = Svector_length(pp);
n = size_vector(len); n = size_vector(len);
@ -267,6 +266,7 @@ static ptr copy(pp, pps) ptr pp; ISPC pps; {
S_G.countof[tg][countof_vector] += 1; S_G.countof[tg][countof_vector] += 1;
S_G.bytesof[tg][countof_vector] += n; S_G.bytesof[tg][countof_vector] += n;
#endif /* ENABLE_OBJECT_COUNTS */ #endif /* ENABLE_OBJECT_COUNTS */
/* assumes vector lengths look like fixnums; if not, vectors will need their own space */
find_room(space_impure, tg, type_typed_object, n, p); find_room(space_impure, tg, type_typed_object, n, p);
copy_ptrs(type_typed_object, p, pp, n); copy_ptrs(type_typed_object, p, pp, n);
/* pad if necessary */ /* pad if necessary */
@ -546,8 +546,8 @@ static void sweep(ptr tc, ptr p, IBOOL sweep_pure) {
} else if (t == type_flonum) { } else if (t == type_flonum) {
/* nothing to sweep */; /* nothing to sweep */;
/* typed objects */ /* typed objects */
} else if (tf = TYPEFIELD(p), TYPEP(tf, mask_fixnum, type_fixnum)) { } else if (tf = TYPEFIELD(p), TYPEP(tf, mask_vector, type_vector)) {
sweep_ptrs(&INITVECTIT(p, 0), UNFIX(tf)); sweep_ptrs(&INITVECTIT(p, 0), Svector_length(p));
} else if (TYPEP(tf, mask_string, type_string) || TYPEP(tf, mask_bytevector, type_bytevector) || TYPEP(tf, mask_fxvector, type_fxvector)) { } else if (TYPEP(tf, mask_string, type_string) || TYPEP(tf, mask_bytevector, type_bytevector) || TYPEP(tf, mask_fxvector, type_fxvector)) {
/* nothing to sweep */; /* nothing to sweep */;
} else if (TYPEP(tf, mask_record, type_record)) { } else if (TYPEP(tf, mask_record, type_record)) {
@ -1303,7 +1303,7 @@ static iptr size_object(p) ptr p; {
} else if (t == type_flonum) { } else if (t == type_flonum) {
return size_flonum; return size_flonum;
/* typed objects */ /* typed objects */
} else if (tf = TYPEFIELD(p), TYPEP(tf, mask_fixnum, type_fixnum)) { } else if (tf = TYPEFIELD(p), TYPEP(tf, mask_vector, type_vector)) {
return size_vector(Svector_length(p)); return size_vector(Svector_length(p));
} else if (TYPEP(tf, mask_string, type_string)) { } else if (TYPEP(tf, mask_string, type_string)) {
return size_string(Sstring_length(p)); return size_string(Sstring_length(p));

5
c/scheme.c
View File

@ -293,6 +293,11 @@ static void idiot_checks() {
fprintf(stderr, "dirty_bytes[0] is not iptr-aligned wrt to seginfo struct\n"); fprintf(stderr, "dirty_bytes[0] is not iptr-aligned wrt to seginfo struct\n");
oops = 1; oops = 1;
} }
if (!Sfixnump(type_vector | ~mask_vector)) {
/* gc counts on vector type/length looking like a fixnum, so it can put vectors in space_impure */
fprintf(stderr, "vector type/length field does not look like a fixnum\n");
oops = 1;
}
if (oops) S_abnormal_exit(); if (oops) S_abnormal_exit();
} }

13
s/cmacros.ss
View File

@ -700,7 +700,7 @@
(define-constant ptr sbwp #b01001110) (define-constant ptr sbwp #b01001110)
;;; vector type/length field is a fixnum ;;; vector type/length field is a fixnum
;;; (define-constant type-vector (constant type-fixnum)) (define-constant type-vector (constant type-fixnum))
; #b000 occupied by vectors on 32- and 64-bit machines ; #b000 occupied by vectors on 32- and 64-bit machines
(define-constant type-string #b001) (define-constant type-string #b001)
; #b010 unused ; #b010 unused
@ -750,6 +750,12 @@
(define-constant bigit-bits 32) (define-constant bigit-bits 32)
(define-constant bigit-bytes (/ (constant bigit-bits) 8)) (define-constant bigit-bytes (/ (constant bigit-bits) 8))
; vector length field is a fixnum
(define-constant vector-length-offset (constant fixnum-offset))
(define-constant iptr maximum-vector-length
(min (- (expt 2 (fx- (constant ptr-bits) (constant vector-length-offset))) 1)
(constant most-positive-fixnum)))
; fxvector length field is stored with type ; fxvector length field is stored with type
(define-constant fxvector-length-offset 3) (define-constant fxvector-length-offset 3)
(define-constant iptr maximum-fxvector-length (define-constant iptr maximum-fxvector-length
@ -829,7 +835,7 @@
(define-constant mask-bwp (constant byte-constant-mask)) (define-constant mask-bwp (constant byte-constant-mask))
;;; vector type/length field is a fixnum ;;; vector type/length field is a fixnum
;;; (define-constant mask-vector (constant mask-fixnum)) (define-constant mask-vector (constant mask-fixnum))
(define-constant mask-string #b111) (define-constant mask-string #b111)
(define-constant mask-fxvector #b111) (define-constant mask-fxvector #b111)
(define-constant mask-bytevector #b111) (define-constant mask-bytevector #b111)
@ -878,6 +884,7 @@
(define-constant mask-positive-fixnum #x80000003) (define-constant mask-positive-fixnum #x80000003)
(define-constant fixnum-factor (expt 2 (constant fixnum-offset))) (define-constant fixnum-factor (expt 2 (constant fixnum-offset)))
(define-constant vector-length-factor (expt 2 (constant vector-length-offset)))
(define-constant string-length-factor (expt 2 (constant string-length-offset))) (define-constant string-length-factor (expt 2 (constant string-length-offset)))
(define-constant bignum-length-factor (expt 2 (constant bignum-length-offset))) (define-constant bignum-length-factor (expt 2 (constant bignum-length-offset)))
(define-constant fxvector-length-factor (expt 2 (constant fxvector-length-offset))) (define-constant fxvector-length-factor (expt 2 (constant fxvector-length-offset)))
@ -1140,7 +1147,7 @@
[ptr denominator])) [ptr denominator]))
(define-primitive-structure-disps vector type-typed-object (define-primitive-structure-disps vector type-typed-object
([ptr type] ;; type is the fixnum length in ptrs ([iptr type]
[ptr data 0])) [ptr data 0]))
(define-primitive-structure-disps fxvector type-typed-object (define-primitive-structure-disps fxvector type-typed-object

234
s/cpnanopass.ss
View File

@ -3545,6 +3545,52 @@
(if (fx< delta 0) (if (fx< delta 0)
(%inline sll ,e (immediate ,(fx- delta))) (%inline sll ,e (immediate ,(fx- delta)))
(%inline srl ,e (immediate ,delta))))))) (%inline srl ,e (immediate ,delta)))))))
(define extract-length
(lambda (t/l tag-bits length-offset)
(let ([e (translate t/l length-offset (constant fixnum-offset))])
(let ([k (fxarithmetic-shift-right tag-bits (fx- length-offset (constant fixnum-offset)))])
(if (fx= k 0)
e
(%inline logand ,e (immediate ,(fxlognot k))))))))
(define build-type/length
(lambda (e type current-shift target-shift)
(let ([e (translate e current-shift target-shift)])
(if (eqv? type 0)
e
(%inline logor ,e (immediate ,type))))))
(define-syntax build-ref-check
(syntax-rules ()
[(_ type-disp maximum-length length-offset type mask)
(lambda (e-v e-i maybe-e-new)
; NB: caller must bind e-v, e-i, and maybe-e-new
(safe-assert (no-need-to-bind? #t e-v))
(safe-assert (no-need-to-bind? #t e-i))
(safe-assert (or (not maybe-e-new) (no-need-to-bind? #t maybe-e-new)))
(build-and
(%type-check mask-typed-object type-typed-object ,e-v)
(bind #t ([t (%mref ,e-v ,(constant type-disp))])
(cond
[(expr->index e-i 1 (constant maximum-length)) =>
(lambda (index)
(let ([e (%inline u<
(immediate ,(logor (ash index (constant length-offset)) (constant type)))
,t)])
(if (and (eqv? (constant type) (constant type-fixnum))
(eqv? (constant mask) (constant mask-fixnum)))
(build-and e (build-fixnums? (if maybe-e-new (list t maybe-e-new) (list t))))
(build-and
(%type-check mask type ,t)
(if maybe-e-new (build-and e (build-fixnums? (list maybe-e-new))) e)))))]
[else
(let ([e (%inline u< ,e-i ,(extract-length t (constant type) (constant length-offset)))])
(if (and (eqv? (constant type) (constant type-fixnum))
(eqv? (constant mask) (constant mask-fixnum)))
(build-and e (build-fixnums? (if maybe-e-new (list e-i t maybe-e-new) (list e-i t))))
(build-and
(%type-check mask type ,t)
(build-and
(build-fixnums? (if maybe-e-new (list e-i maybe-e-new) (list e-i)))
e))))]))))]))
(define inline-args-limit 10) (define inline-args-limit 10)
(define reduce-equality (define reduce-equality
(lambda (src sexpr moi e1 e2 e*) (lambda (src sexpr moi e1 e2 e*)
@ -4612,7 +4658,7 @@
(typed-object-pred string? mask-string type-string) (typed-object-pred string? mask-string type-string)
(typed-object-pred $system-code? mask-system-code type-system-code) (typed-object-pred $system-code? mask-system-code type-system-code)
(typed-object-pred $tlc? mask-tlc type-tlc) (typed-object-pred $tlc? mask-tlc type-tlc)
(typed-object-pred vector? mask-fixnum type-fixnum) (typed-object-pred vector? mask-vector type-vector)
(typed-object-pred thread? mask-thread type-thread)) (typed-object-pred thread? mask-thread type-thread))
(define-inline 3 $bigpositive? (define-inline 3 $bigpositive?
[(e) (%type-check mask-signed-bignum type-positive-bignum [(e) (%type-check mask-signed-bignum type-positive-bignum
@ -4729,7 +4775,9 @@
(let loop ([e* e*] [i 0]) (let loop ([e* e*] [i 0])
(if (null? e*) (if (null? e*)
`(seq `(seq
(set! ,(%mref ,t ,(constant vector-type-disp)) (immediate ,(fix n))) (set! ,(%mref ,t ,(constant vector-type-disp))
(immediate ,(+ (fx* n (constant vector-length-factor))
(constant type-vector))))
,t) ,t)
`(seq `(seq
(set! ,(%mref ,t ,(fx+ i (constant vector-data-disp))) ,(car e*)) (set! ,(%mref ,t ,(fx+ i (constant vector-data-disp))) ,(car e*))
@ -4745,7 +4793,7 @@
`(seq `(seq
(set! ,(%mref ,t ,(constant fxvector-type-disp)) (set! ,(%mref ,t ,(constant fxvector-type-disp))
(immediate ,(+ (fx* n (constant fxvector-length-factor)) (immediate ,(+ (fx* n (constant fxvector-length-factor))
(constant type-fxvector)))) (constant type-fxvector))))
,t) ,t)
`(seq `(seq
(set! ,(%mref ,t ,(fx+ i (constant fxvector-data-disp))) ,(car e*)) (set! ,(%mref ,t ,(fx+ i (constant fxvector-data-disp))) ,(car e*))
@ -4838,7 +4886,6 @@
(define-inline 3 prim (define-inline 3 prim
[(e) (%mref ,e ,(constant disp))])])) [(e) (%mref ,e ,(constant disp))])]))
(inline-accessor unbox box-ref-disp) (inline-accessor unbox box-ref-disp)
(inline-accessor vector-length vector-type-disp) ; assumes type/length field holds a fixnum
(inline-accessor $symbol-name symbol-name-disp) (inline-accessor $symbol-name symbol-name-disp)
(inline-accessor $symbol-property-list symbol-plist-disp) (inline-accessor $symbol-property-list symbol-plist-disp)
(inline-accessor $system-property-list symbol-splist-disp) (inline-accessor $system-property-list symbol-splist-disp)
@ -4871,25 +4918,13 @@
`(if ,(%typed-object-check mask-box type-box ,e) `(if ,(%typed-object-check mask-box type-box ,e)
,(%mref ,e ,(constant box-ref-disp)) ,(%mref ,e ,(constant box-ref-disp))
,(build-libcall #t src sexpr unbox e)))]) ,(build-libcall #t src sexpr unbox e)))])
(define-inline 2 vector-length
[(e) (let ([Lerr (make-local-label 'Lerr)])
(bind #t (e)
`(if ,(%type-check mask-typed-object type-typed-object ,e)
,(bind #t ([t/l (%mref ,e ,(constant vector-type-disp))])
`(if ,(%type-check mask-fixnum type-fixnum ,t/l)
,t/l
(goto ,Lerr)))
(label ,Lerr ,(build-libcall #t #f sexpr vector-length e)))))])
(let () (let ()
(define-syntax def-len (define-syntax def-len
(syntax-rules () (syntax-rules ()
[(_ prim mask type type-disp length-offset) [(_ prim mask type type-disp length-offset)
(define-inline 3 prim (define-inline 3 prim
[(e) (%inline logand [(e) (extract-length (%mref ,e ,(constant type-disp)) (constant type) (constant length-offset))])]))
,(translate (%mref ,e ,(constant type-disp)) (def-len vector-length mask-vector type-vector vector-type-disp vector-length-offset)
(constant length-offset)
(constant fixnum-offset))
(immediate ,(- (constant fixnum-factor))))])]))
(def-len fxvector-length mask-fxvector type-fxvector fxvector-type-disp fxvector-length-offset) (def-len fxvector-length mask-fxvector type-fxvector fxvector-type-disp fxvector-length-offset)
(def-len string-length mask-string type-string string-type-disp string-length-offset) (def-len string-length mask-string type-string string-type-disp string-length-offset)
(def-len bytevector-length mask-bytevector type-bytevector bytevector-type-disp bytevector-length-offset) (def-len bytevector-length mask-bytevector type-bytevector bytevector-type-disp bytevector-length-offset)
@ -4904,11 +4939,10 @@
`(if ,(%type-check mask-typed-object type-typed-object ,e) `(if ,(%type-check mask-typed-object type-typed-object ,e)
,(bind #t ([t/l (%mref ,e ,(constant type-disp))]) ,(bind #t ([t/l (%mref ,e ,(constant type-disp))])
`(if ,(%type-check mask type ,t/l) `(if ,(%type-check mask type ,t/l)
,(%inline logand ,(extract-length t/l (constant type) (constant length-offset))
,(translate t/l (constant length-offset) (constant fixnum-offset))
(immediate ,(- (constant fixnum-factor))))
(goto ,Lerr))) (goto ,Lerr)))
(label ,Lerr ,(build-libcall #t #f sexpr prim e)))))])])) (label ,Lerr ,(build-libcall #t #f sexpr prim e)))))])]))
(def-len vector-length mask-vector type-vector vector-type-disp vector-length-offset)
(def-len fxvector-length mask-fxvector type-fxvector fxvector-type-disp fxvector-length-offset) (def-len fxvector-length mask-fxvector type-fxvector fxvector-type-disp fxvector-length-offset)
(def-len string-length mask-string type-string string-type-disp string-length-offset) (def-len string-length mask-string type-string string-type-disp string-length-offset)
(def-len bytevector-length mask-bytevector type-bytevector bytevector-type-disp bytevector-length-offset)) (def-len bytevector-length mask-bytevector type-bytevector bytevector-type-disp bytevector-length-offset))
@ -5252,7 +5286,7 @@
,(%constant sfalse)) ,(%constant sfalse))
,e ,e
,libcall))) ,libcall)))
(safe-assert (= (constant log2-ptr-bytes) (constant fixnum-offset))) (meta-assert (= (constant log2-ptr-bytes) (constant fixnum-offset)))
(define-inline 3 virtual-register (define-inline 3 virtual-register
[(e-idx) [(e-idx)
(or (constant-ref e-idx) (or (constant-ref e-idx)
@ -7612,33 +7646,7 @@
[(e-name e-handler e-ib e-ob) (go e-name e-handler e-ib e-ob `(quote #f))] [(e-name e-handler e-ib e-ob) (go e-name e-handler e-ib e-ob `(quote #f))]
[(e-name e-handler e-ib e-ob e-info) (go e-name e-handler e-ib e-ob e-info)])))) [(e-name e-handler e-ib e-ob e-info) (go e-name e-handler e-ib e-ob e-info)]))))
(let () (let ()
(define build-fxvector-ref-check (define build-fxvector-ref-check (build-ref-check fxvector-type-disp maximum-fxvector-length fxvector-length-offset type-fxvector mask-fxvector))
(lambda (e-fv e-i maybe-e-new)
; NB: caller must bind e-fv, e-i, and maybe-e-new
(safe-assert (no-need-to-bind? #t e-fv))
(safe-assert (no-need-to-bind? #t e-i))
(safe-assert (or (not maybe-e-new) (no-need-to-bind? #t maybe-e-new)))
(build-and
(%type-check mask-typed-object type-typed-object ,e-fv)
(bind #t ([t (%mref ,e-fv ,(constant fxvector-type-disp))])
(build-and
(%type-check mask-fxvector type-fxvector ,t)
(cond
[(expr->index e-i 1 (constant maximum-fxvector-length)) =>
(lambda (index)
((lambda (e) (if maybe-e-new (build-and (build-fixnums? (list maybe-e-new)) e) e))
(%inline u<
(immediate ,(logor (ash index (constant fxvector-length-offset)) (constant type-fxvector)))
,t)))]
[else
(build-and
(build-fixnums? (if maybe-e-new (list e-i maybe-e-new) (list e-i)))
(%inline u< ,e-i
,(%inline logand
,(translate t
(constant fxvector-length-offset)
(constant fixnum-offset))
(immediate ,(- (constant fixnum-factor))))))]))))))
(define-inline 2 $fxvector-ref-check? (define-inline 2 $fxvector-ref-check?
[(e-fv e-i) (bind #t (e-fv e-i) (build-fxvector-ref-check e-fv e-i #f))]) [(e-fv e-i) (bind #t (e-fv e-i) (build-fxvector-ref-check e-fv e-i #f))])
(let () (let ()
@ -7679,29 +7687,7 @@
(let () (let ()
(define build-string-ref-check (define build-string-ref-check
(lambda (e-s e-i) (lambda (e-s e-i)
; NB: caller must bind e-s and e-i ((build-ref-check string-type-disp maximum-string-length string-length-offset type-string mask-string) e-s e-i #f)))
(safe-assert (no-need-to-bind? #t e-s))
(safe-assert (no-need-to-bind? #t e-i))
(build-and
(%type-check mask-typed-object type-typed-object ,e-s)
(bind #t ([t (%mref ,e-s ,(constant string-type-disp))])
(build-and
(%type-check mask-string type-string ,t)
(cond
[(expr->index e-i 1 (constant maximum-string-length)) =>
(lambda (index)
(%inline u<
(immediate ,(logor (ash index (constant string-length-offset)) (constant type-string)))
,t))]
[else
(build-and
(%type-check mask-fixnum type-fixnum ,e-i)
(%inline u< ,e-i
,(%inline logand
,(translate t
(constant string-length-offset)
(constant fixnum-offset))
(immediate ,(- (constant fixnum-factor))))))]))))))
(define-inline 2 $string-ref-check? (define-inline 2 $string-ref-check?
[(e-s e-i) (bind #t (e-s e-i) (build-string-ref-check e-s e-i))]) [(e-s e-i) (bind #t (e-s e-i) (build-string-ref-check e-s e-i))])
(let () (let ()
@ -7752,18 +7738,7 @@
,(go e-s e-i e-new) ,(go e-s e-i e-new)
,(build-libcall #t src sexpr string-set! e-s e-i e-new)))]))) ,(build-libcall #t src sexpr string-set! e-s e-i e-new)))])))
(let () (let ()
; assumes vector type is a fixnum (define build-vector-ref-check (build-ref-check vector-type-disp maximum-vector-length vector-length-offset type-vector mask-vector))
(define build-vector-ref-check
(lambda (e-v e-i maybe-e-new)
; NB: caller must bind e-v and e-i
(safe-assert (no-need-to-bind? #t e-v))
(safe-assert (no-need-to-bind? #t e-i))
(build-and
(%type-check mask-typed-object type-typed-object ,e-v)
(bind #t ([t (%mref ,e-v ,(constant vector-type-disp))])
(build-and
(%inline u< ,e-i ,t)
(build-fixnums? (if maybe-e-new (list e-i t maybe-e-new) (list e-i t))))))))
(define-inline 2 $vector-ref-check? (define-inline 2 $vector-ref-check?
[(e-v e-i) (bind #t (e-v e-i) (build-vector-ref-check e-v e-i #f))]) [(e-v e-i) (bind #t (e-v e-i) (build-vector-ref-check e-v e-i #f))])
(let () (let ()
@ -7842,11 +7817,7 @@
,(if (fx= bytes 1) ,(if (fx= bytes 1)
e-i e-i
(%inline + ,e-i (immediate ,(fix (fx- bytes 1))))) (%inline + ,e-i (immediate ,(fix (fx- bytes 1)))))
,(%inline logand ,(extract-length t (constant type-bytevector) (constant bytevector-length-offset))))]))))))]
,(translate t
(constant bytevector-length-offset)
(constant fixnum-offset))
(immediate ,(- (constant fixnum-factor))))))]))))))]
[(seq (profile ,src) ,[e]) (and e `(seq (profile ,src) ,e))] [(seq (profile ,src) ,[e]) (and e `(seq (profile ,src) ,e))]
[else #f])]) [else #f])])
(let () (let ()
@ -7886,10 +7857,10 @@
(immediate ,(- (constant byte-alignment)))))]) (immediate ,(- (constant byte-alignment)))))])
(seq (seq
(set! ,(%mref ,t-vec ,(constant bytevector-type-disp)) (set! ,(%mref ,t-vec ,(constant bytevector-type-disp))
,(%inline logor ,(build-type/length t-bytes
,(%inline sll ,t-bytes (constant type-bytevector)
,(%constant bytevector-length-offset)) 0
,(%constant type-bytevector))) (constant bytevector-length-offset)))
,(if maybe-e-fill ,(if maybe-e-fill
(build-bytevector-fill t-vec t-bytes maybe-e-fill) (build-bytevector-fill t-vec t-bytes maybe-e-fill)
t-vec)))))))))) t-vec))))))))))
@ -7991,11 +7962,10 @@
(quote ,(bytevector)) (quote ,(bytevector))
(seq (seq
(set! ,(%mref ,bv ,(constant bytevector-type-disp)) (set! ,(%mref ,bv ,(constant bytevector-type-disp))
,(%inline logor ,(build-type/length len
,(%inline sll (constant type-bytevector)
,(build-unfix len) (constant fixnum-offset)
,(%constant bytevector-length-offset)) (constant bytevector-length-offset)))
,(%constant type-bytevector)))
,bv))))]) ,bv))))])
(let () (let ()
@ -8307,11 +8277,10 @@
(quote ,(string)) (quote ,(string))
(seq (seq
(set! ,(%mref ,e-str ,(constant string-type-disp)) (set! ,(%mref ,e-str ,(constant string-type-disp))
,(%inline logor ,(build-type/length e-len
,(translate e-len (constant type-string)
(constant fixnum-offset) (constant fixnum-offset)
(constant string-length-offset)) (constant string-length-offset)))
,(%constant type-string)))
,e-str))))]) ,e-str))))])
(let () (let ()
@ -8349,11 +8318,10 @@
(immediate ,(- (constant byte-alignment)))))]) (immediate ,(- (constant byte-alignment)))))])
(seq (seq
(set! ,(%mref ,t-str ,(constant string-type-disp)) (set! ,(%mref ,t-str ,(constant string-type-disp))
,(%inline logor ,(build-type/length t-bytes
,(translate t-bytes (constant type-string)
(constant string-char-offset) (constant string-char-offset)
(constant string-length-offset)) (constant string-length-offset)))
,(%constant type-string)))
,(build-string-fill t-str t-bytes e-fill)))))))))) ,(build-string-fill t-str t-bytes e-fill))))))))))
(define default-fill `(immediate ,(ptr->imm #\nul))) (define default-fill `(immediate ,(ptr->imm #\nul)))
(define-inline 3 make-string (define-inline 3 make-string
@ -8391,7 +8359,7 @@
(let () (let ()
(define build-fxvector-fill (define build-fxvector-fill
(make-build-fill (constant ptr-bytes) (constant fxvector-data-disp))) (make-build-fill (constant ptr-bytes) (constant fxvector-data-disp)))
(safe-assert (= (constant log2-ptr-bytes) (constant fixnum-offset))) (meta-assert (= (constant log2-ptr-bytes) (constant fixnum-offset)))
(let () (let ()
(define do-make-fxvector (define do-make-fxvector
(lambda (e-length e-fill) (lambda (e-length e-fill)
@ -8421,11 +8389,10 @@
(immediate ,(- (constant byte-alignment)))))]) (immediate ,(- (constant byte-alignment)))))])
(seq (seq
(set! ,(%mref ,t-fxv ,(constant fxvector-type-disp)) (set! ,(%mref ,t-fxv ,(constant fxvector-type-disp))
,(%inline logor ,(build-type/length e-length
,(translate e-length (constant type-fxvector)
(constant fixnum-offset) (constant fixnum-offset)
(constant fxvector-length-offset)) (constant fxvector-length-offset)))
,(%constant type-fxvector)))
,(build-fxvector-fill t-fxv e-length e-fill))))))))) ,(build-fxvector-fill t-fxv e-length e-fill)))))))))
(define default-fill `(immediate ,(fix 0))) (define default-fill `(immediate ,(fix 0)))
(define-inline 3 make-fxvector (define-inline 3 make-fxvector
@ -8463,7 +8430,7 @@
(let () (let ()
(define build-vector-fill (define build-vector-fill
(make-build-fill (constant ptr-bytes) (constant vector-data-disp))) (make-build-fill (constant ptr-bytes) (constant vector-data-disp)))
(safe-assert (= (constant log2-ptr-bytes) (constant fixnum-offset))) (meta-assert (= (constant log2-ptr-bytes) (constant fixnum-offset)))
(let () (let ()
(define do-make-vector (define do-make-vector
(lambda (e-length e-fill) (lambda (e-length e-fill)
@ -8478,7 +8445,8 @@
(fx+ (constant header-size-vector) bytes))]) (fx+ (constant header-size-vector) bytes))])
`(seq `(seq
(set! ,(%mref ,t ,(constant vector-type-disp)) (set! ,(%mref ,t ,(constant vector-type-disp))
(immediate ,(fix n))) (immediate ,(+ (fx* n (constant vector-length-factor))
(constant type-vector))))
,(build-vector-fill t `(immediate ,bytes) e-fill)))))) ,(build-vector-fill t `(immediate ,bytes) e-fill))))))
(bind #t (e-length) ; fixnum length doubles as byte count (bind #t (e-length) ; fixnum length doubles as byte count
(let ([t-vec (make-tmp 'tvec)]) (let ([t-vec (make-tmp 'tvec)])
@ -8491,7 +8459,11 @@
(fx- (constant byte-alignment) 1)))) (fx- (constant byte-alignment) 1))))
(immediate ,(- (constant byte-alignment)))))]) (immediate ,(- (constant byte-alignment)))))])
(seq (seq
(set! ,(%mref ,t-vec ,(constant vector-type-disp)) ,e-length) (set! ,(%mref ,t-vec ,(constant vector-type-disp))
,(build-type/length e-length
(constant type-vector)
(constant fixnum-offset)
(constant vector-length-offset)))
,(build-vector-fill t-vec e-length e-fill))))))))) ,(build-vector-fill t-vec e-length e-fill)))))))))
(define default-fill `(immediate ,(fix 0))) (define default-fill `(immediate ,(fix 0)))
(define-inline 3 make-vector (define-inline 3 make-vector
@ -8512,7 +8484,7 @@
(do-make-vector e-length e-fill))])))) (do-make-vector e-length e-fill))]))))
(let () (let ()
(safe-assert (= (constant log2-ptr-bytes) (constant fixnum-offset))) (meta-assert (= (constant log2-ptr-bytes) (constant fixnum-offset)))
(define-inline 3 $make-eqhash-vector (define-inline 3 $make-eqhash-vector
[(e-length) [(e-length)
(let ([t-vec (make-tmp 'tvec)] (let ([t-vec (make-tmp 'tvec)]
@ -8528,7 +8500,11 @@
(fx- (constant byte-alignment) 1)))) (fx- (constant byte-alignment) 1))))
(immediate ,(- (constant byte-alignment)))))]) (immediate ,(- (constant byte-alignment)))))])
(seq (seq
(set! ,(%mref ,t-vec ,(constant vector-type-disp)) ,t-idx) (set! ,(%mref ,t-vec ,(constant vector-type-disp))
,(build-type/length t-idx
(constant type-vector)
(constant fixnum-offset)
(constant vector-length-offset)))
(label ,Ltop (label ,Ltop
,(%seq ,(%seq
(set! ,t-idx ,(%inline - ,t-idx (immediate ,(fix 1)))) (set! ,t-idx ,(%inline - ,t-idx (immediate ,(fix 1))))
@ -9908,7 +9884,7 @@
(CaseLambdaExpr : CaseLambdaExpr (ir) -> CaseLambdaExpr () (CaseLambdaExpr : CaseLambdaExpr (ir) -> CaseLambdaExpr ()
[(case-lambda ,info ,cl* ...) [(case-lambda ,info ,cl* ...)
(let-values ([(local* tlbody) (flatten-clauses info cl* (info-lambda-dcl* info))]) (let-values ([(local* tlbody) (flatten-clauses info cl* (info-lambda-dcl* info))])
(safe-assert (nodups local*)) (safe-assert (nodups local*))
(info-lambda-dcl*-set! info (filter direct-call-label-referenced (info-lambda-dcl* info))) (info-lambda-dcl*-set! info (filter direct-call-label-referenced (info-lambda-dcl* info)))
`(lambda ,info (,local* ...) ,tlbody))]) `(lambda ,info (,local* ...) ,tlbody))])
(Tail : Tail (ir) -> Tail ()) (Tail : Tail (ir) -> Tail ())
@ -11839,9 +11815,21 @@
(set! ,%td ,(%inline + ,%ac0 (immediate ,(fx+ (constant ptr-bytes) (fx- (constant byte-alignment) 1))))) (set! ,%td ,(%inline + ,%ac0 (immediate ,(fx+ (constant ptr-bytes) (fx- (constant byte-alignment) 1)))))
(set! ,%td ,(%inline logand ,%td (immediate ,(- (constant byte-alignment))))) (set! ,%td ,(%inline logand ,%td (immediate ,(- (constant byte-alignment)))))
(set! ,%xp (alloc ,(make-info-alloc (constant type-typed-object) #f #f) ,%td)) (set! ,%xp (alloc ,(make-info-alloc (constant type-typed-object) #f #f) ,%td))
,(begin ,(let ([delta (fx- (constant vector-length-offset) (constant log2-ptr-bytes))])
(safe-assert (fx= (constant log2-ptr-bytes) (constant fixnum-offset))) (safe-assert (fx>= delta 0))
`(set! ,(%mref ,%xp ,(constant vector-type-disp)) ,%ac0)) (if (fx= delta 0)
(if (fx= (constant type-vector) 0)
`(set! ,(%mref ,%xp ,(constant vector-type-disp)) ,%ac0)
(%seq
(set! ,%td ,(%inline logor ,%ac0 (immediate ,(constant type-vector))))
(set! ,(%mref ,%xp ,(constant vector-type-disp)) ,%td)))
(%seq
(set! ,%td ,(%inline sll ,%ac0 (immediate ,delta)))
,(if (fx= (constant type-vector) 0)
`(set! ,(%mref ,%xp ,(constant vector-type-disp)) ,%td)
(%seq
(set! ,%td ,(%inline logor ,%td (immediate ,(constant type-vector))))
(set! ,(%mref ,%xp ,(constant vector-type-disp)) ,%td))))))
,(let f ([reg* arg-registers] [i 0]) ,(let f ([reg* arg-registers] [i 0])
(if (null? reg*) (if (null? reg*)
(%seq (%seq

4
s/mkheader.ss
View File

@ -238,7 +238,7 @@
(deftypep "Sprocedurep" ($ mask-closure) ($ type-closure)) (deftypep "Sprocedurep" ($ mask-closure) ($ type-closure))
(deftypep "Sflonump" ($ mask-flonum) ($ type-flonum)) (deftypep "Sflonump" ($ mask-flonum) ($ type-flonum))
(deftotypep "Svectorp" ($ mask-fixnum) ($ type-fixnum)) (deftotypep "Svectorp" ($ mask-vector) ($ type-vector))
(deftotypep "Sfxvectorp" ($ mask-fxvector) ($ type-fxvector)) (deftotypep "Sfxvectorp" ($ mask-fxvector) ($ type-fxvector))
(deftotypep "Sbytevectorp" ($ mask-bytevector) ($ type-bytevector)) (deftotypep "Sbytevectorp" ($ mask-bytevector) ($ type-bytevector))
(deftotypep "Sstringp" ($ mask-string) ($ type-string)) (deftotypep "Sstringp" ($ mask-string) ($ type-string))
@ -265,7 +265,7 @@
(def "Svector_length(x)" (def "Svector_length(x)"
(format "((iptr)((uptr)~a>>~d))" (format "((iptr)((uptr)~a>>~d))"
(access "x" vector type) (access "x" vector type)
($ fixnum-offset))) ($ vector-length-offset)))
(defref Svector_ref vector data) (defref Svector_ref vector data)
(def "Sfxvector_length(x)" (def "Sfxvector_length(x)"

4
s/prims.ss
View File

@ -286,10 +286,14 @@
(define make-vector (define make-vector
(case-lambda (case-lambda
[(n x) [(n x)
; if this fails, we have to change the test and message below
(meta-assert (= (constant maximum-vector-length) (constant most-positive-fixnum)))
(unless (and (fixnum? n) (fx>= n 0)) (unless (and (fixnum? n) (fx>= n 0))
($oops 'make-vector "~s is not a nonnegative fixnum" n)) ($oops 'make-vector "~s is not a nonnegative fixnum" n))
(make-vector n x)] (make-vector n x)]
[(n) [(n)
; if this fails, we have to change the test and message below
(meta-assert (= (constant maximum-vector-length) (constant most-positive-fixnum)))
(unless (and (fixnum? n) (fx>= n 0)) (unless (and (fixnum? n) (fx>= n 0))
($oops 'make-vector "~s is not a nonnegative fixnum" n)) ($oops 'make-vector "~s is not a nonnegative fixnum" n))
(make-vector n)])) (make-vector n)]))