- various tweaks to the immutable object support; also taught cp0
to simplify ($fxu< (most-positive-fixnum) e) => (fx< e 0) so we
don't have any incentive in special casing length checks where
the maximum length happens to be (most-positive-fixnum).
5_4.ss, 5_6.ss, bytevector.ss, cmacros.ss, cp0.ss, cpnanopass.ss,
mkheader.ss, primdata.ss, prims.ss,
fasl.c, gc.c, types.h
root-experr*, patch*
original commit: 9eb63deda025fd4560b54746b21a881c01af46d6
This commit is contained in:
Kent Dybvig
parent
9cd0199a39
commit
c503362914
10
LOG
10
LOG
|
|
@ -383,5 +383,13 @@
|
|||
5_4.ss, 5_6.ss, bytevector.ss, cmacros.ss, cpnanopass.ss,
|
||||
fasl.ss, library.ss, mkheader.ss, primdata.ss, prims.ss,
|
||||
externs.h, types.h, alloc.c, fasl.c, gc.c, scheme.c,
|
||||
5_5.ms, 5_6.ms, bytevector.ms, misc.ms, root-experr*, patch*,
|
||||
5_5.ms, 5_6.ms, bytevector.ms, misc.ms, root-experr*
|
||||
objects.stex
|
||||
- various tweaks to the immutable object support; also taught cp0
|
||||
to simplify ($fxu< (most-positive-fixnum) e) => (fx< e 0) so we
|
||||
don't have any incentive in special casing length checks where
|
||||
the maximum length happens to be (most-positive-fixnum).
|
||||
5_4.ss, 5_6.ss, bytevector.ss, cmacros.ss, cp0.ss, cpnanopass.ss,
|
||||
mkheader.ss, primdata.ss, prims.ss,
|
||||
fasl.c, gc.c, types.h
|
||||
root-experr*, patch*
|
||||
|
|
|
|||
8
c/fasl.c
8
c/fasl.c
|
|
@ -649,7 +649,7 @@ static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) {
|
|||
if (Svector_length(*x) == 0)
|
||||
*x = NULLIMMUTABLEVECTOR(tc);
|
||||
else
|
||||
Svector_set_immutable(*x);
|
||||
VECTTYPE(*x) |= vector_immutable_flag;
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
|
@ -668,7 +668,7 @@ static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) {
|
|||
if (Sfxvector_length(*x) == 0)
|
||||
*x = NULLIMMUTABLEFXVECTOR(tc);
|
||||
else
|
||||
Sfxvector_set_immutable(*x);
|
||||
FXVECTOR_TYPE(*x) |= fxvector_immutable_flag;
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
|
@ -682,7 +682,7 @@ static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) {
|
|||
if (Sbytevector_length(*x) == 0)
|
||||
*x = NULLIMMUTABLEBYTEVECTOR(tc);
|
||||
else
|
||||
Sbytevector_set_immutable(*x);
|
||||
BYTEVECTOR_TYPE(*x) |= bytevector_immutable_flag;
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
|
@ -837,7 +837,7 @@ static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) {
|
|||
if (n == 0)
|
||||
str = NULLIMMUTABLESTRING(tc);
|
||||
else
|
||||
Sstring_set_immutable(str);
|
||||
STRTYPE(str) |= string_immutable_flag;
|
||||
}
|
||||
*x = str;
|
||||
return;
|
||||
|
|
|
|||
8
c/gc.c
8
c/gc.c
|
|
@ -267,7 +267,7 @@ static ptr copy(pp, pps) ptr pp; ISPC pps; {
|
|||
S_G.bytesof[tg][countof_vector] += n;
|
||||
#endif /* ENABLE_OBJECT_COUNTS */
|
||||
/* assumes vector lengths look like fixnums; if not, vectors will need their own space */
|
||||
if (TYPE_IMMP(tf, vector_immutable_flag)) {
|
||||
if ((uptr)tf & vector_immutable_flag) {
|
||||
find_room(space_pure, tg, type_typed_object, n, p);
|
||||
} else {
|
||||
find_room(space_impure, tg, type_typed_object, n, p);
|
||||
|
|
@ -325,7 +325,11 @@ static ptr copy(pp, pps) ptr pp; ISPC pps; {
|
|||
#ifdef ENABLE_OBJECT_COUNTS
|
||||
S_G.countof[tg][countof_box] += 1;
|
||||
#endif /* ENABLE_OBJECT_COUNTS */
|
||||
find_room(space_impure, tg, type_typed_object, size_box, p);
|
||||
if ((uptr)tf == type_immutable_box) {
|
||||
find_room(space_pure, tg, type_typed_object, size_box, p);
|
||||
} else {
|
||||
find_room(space_impure, tg, type_typed_object, size_box, p);
|
||||
}
|
||||
BOXTYPE(p) = (iptr)tf;
|
||||
INITBOXREF(p) = Sunbox(pp);
|
||||
} else if ((iptr)tf == type_ratnum) {
|
||||
|
|
|
|||
|
|
@ -235,7 +235,6 @@ typedef struct _bucket_pointer_list {
|
|||
#define UNFIX(x) Sfixnum_value(x)
|
||||
|
||||
#define TYPEP(x,mask,type) (((iptr)(x) & (mask)) == (type))
|
||||
#define TYPE_IMMP(x,immutable_flag) ((iptr)(x) & (immutable_flag))
|
||||
|
||||
/* reloc fields */
|
||||
#define RELOC_EXTENDED_FORMAT(x) ((x)&reloc_extended_format)
|
||||
|
|
|
|||
|
|
@ -2632,8 +2632,8 @@
|
|||
(equal?
|
||||
(parameterize ([cd "/"] [source-directories (list (cd))])
|
||||
(call-with-values
|
||||
(lambda () (((inspect/object fatfib) 'code) 'source-path))
|
||||
list))
|
||||
(lambda () (((inspect/object fatfib) 'code) 'source-path))
|
||||
list))
|
||||
(list (format "~a/../examples/fatfib.ss" (cd)) 16 4)))
|
||||
(begin
|
||||
(parameterize ([source-directories (list (parameterize ([cd ".."]) (cd)))])
|
||||
|
|
|
|||
5
s/5_4.ss
5
s/5_4.ss
|
|
@ -111,12 +111,11 @@
|
|||
|
||||
(set-who! string->immutable-string
|
||||
(lambda (v)
|
||||
(unless (string? v)
|
||||
($oops who "~s is not a string" v))
|
||||
(cond
|
||||
[(immutable-string? v) v]
|
||||
[(fx= 0 (string-length v)) ($tc-field 'null-immutable-string ($tc))]
|
||||
[(eqv? v "") ($tc-field 'null-immutable-string ($tc))]
|
||||
[else
|
||||
(unless (string? v) ($oops who "~s is not a string" v))
|
||||
(let ([v2 (string-copy v)])
|
||||
($string-set-immutable! v2)
|
||||
v2)])))
|
||||
|
|
|
|||
10
s/5_6.ss
10
s/5_6.ss
|
|
@ -71,12 +71,11 @@
|
|||
|
||||
(set-who! vector->immutable-vector
|
||||
(lambda (v)
|
||||
(unless (vector? v)
|
||||
($oops who "~s is not a vector" v))
|
||||
(cond
|
||||
[(immutable-vector? v) v]
|
||||
[(fx= 0 (vector-length v)) ($tc-field 'null-immutable-vector ($tc))]
|
||||
[(eqv? v '#()) ($tc-field 'null-immutable-vector ($tc))]
|
||||
[else
|
||||
(unless (vector? v) ($oops who "~s is not a vector" v))
|
||||
(let ([v2 (vector-copy v)])
|
||||
($vector-set-immutable! v2)
|
||||
v2)])))
|
||||
|
|
@ -130,12 +129,11 @@
|
|||
|
||||
(set-who! fxvector->immutable-fxvector
|
||||
(lambda (v)
|
||||
(unless (fxvector? v)
|
||||
($oops who "~s is not a fxvector" v))
|
||||
(cond
|
||||
[(immutable-fxvector? v) v]
|
||||
[(fx= 0 (fxvector-length v)) ($tc-field 'null-immutable-fxvector ($tc))]
|
||||
[(eqv? v '#vfx()) ($tc-field 'null-immutable-fxvector ($tc))]
|
||||
[else
|
||||
(unless (fxvector? v) ($oops who "~s is not a fxvector" v))
|
||||
(let ([v2 (fxvector-copy v)])
|
||||
($fxvector-set-immutable! v2)
|
||||
v2)])))
|
||||
|
|
|
|||
|
|
@ -502,16 +502,13 @@
|
|||
(set-who! make-bytevector
|
||||
(case-lambda
|
||||
[(n fill)
|
||||
(meta-assert (<= (constant maximum-bytevector-length) (constant most-positive-fixnum)))
|
||||
(unless (and (fixnum? n) ($fxu< n (fx+ (constant maximum-bytevector-length) 1)))
|
||||
(unless (and (fixnum? n) (not ($fxu< (constant maximum-bytevector-length) n)))
|
||||
($oops who "~s is not a valid bytevector length" n))
|
||||
(unless (fill? fill) (invalid-fill-value who fill))
|
||||
(#3%make-bytevector n fill)]
|
||||
[(n)
|
||||
(meta-assert (<= (constant maximum-bytevector-length) (constant most-positive-fixnum)))
|
||||
(unless (and (fixnum? n) ($fxu< n (fx+ (constant maximum-bytevector-length) 1)))
|
||||
(unless (and (fixnum? n) (not ($fxu< (constant maximum-bytevector-length) n)))
|
||||
($oops who "~s is not a valid bytevector length" n))
|
||||
(unless (fx<= n (constant maximum-bytevector-length)) ($oops who "~s is too large" n))
|
||||
(#3%make-bytevector n)]))
|
||||
|
||||
(set! bytevector? (lambda (x) (#2%bytevector? x)))
|
||||
|
|
@ -775,12 +772,11 @@
|
|||
|
||||
(set-who! bytevector->immutable-bytevector
|
||||
(lambda (v)
|
||||
(unless (bytevector? v)
|
||||
($oops who "~s is not a bytevector" v))
|
||||
(cond
|
||||
[(immutable-bytevector? v) v]
|
||||
[(fx= 0 (bytevector-length v)) ($tc-field 'null-immutable-bytevector ($tc))]
|
||||
[(eqv? v '#vu8()) ($tc-field 'null-immutable-bytevector ($tc))]
|
||||
[else
|
||||
(unless (bytevector? v) ($oops who "~s is not a bytevector" v))
|
||||
(let ([v2 (bytevector-copy v)])
|
||||
($bytevector-set-immutable! v2)
|
||||
v2)])))
|
||||
|
|
|
|||
30
s/cmacros.ss
30
s/cmacros.ss
|
|
@ -705,7 +705,7 @@
|
|||
(define-constant ptr black-hole #b01000110)
|
||||
(define-constant ptr sbwp #b01001110)
|
||||
|
||||
;;; vector type/length field is a fixnum
|
||||
;;; vector type/length field must look like a fixnum. an immutable bit sits just above the fixnum tag, with the length above that.
|
||||
(define-constant type-vector (constant type-fixnum))
|
||||
; #b000 occupied by vectors on 32- and 64-bit machines
|
||||
(define-constant type-string #b001)
|
||||
|
|
@ -761,7 +761,7 @@
|
|||
(define-constant bigit-bits 32)
|
||||
(define-constant bigit-bytes (/ (constant bigit-bits) 8))
|
||||
|
||||
; vector length field is a fixnum shifted by 1 for immutability bit
|
||||
; vector length field (high bits) + immutabilty is stored with type
|
||||
(define-constant vector-length-offset (fx+ 1 (constant fixnum-offset)))
|
||||
(define-constant vector-immutable-flag
|
||||
(expt 2 (- (constant vector-length-offset) 1)))
|
||||
|
|
@ -828,8 +828,6 @@
|
|||
|
||||
(define-constant byte-constant-mask (- (ash 1 (constant ptr-bits)) 1))
|
||||
|
||||
;;; mask-fixnum is assumed to be all ones followed by some number of
|
||||
;;; zeros at least by vector, fxvector, and bytevector index checks
|
||||
(define-constant mask-fixnum (- (ash 1 (constant fixnum-offset)) 1))
|
||||
|
||||
;;; octets are fixnums in the range 0..255
|
||||
|
|
@ -851,7 +849,7 @@
|
|||
(define-constant mask-nil (constant byte-constant-mask))
|
||||
(define-constant mask-bwp (constant byte-constant-mask))
|
||||
|
||||
;;; vector type/length field is a fixnum
|
||||
;;; vector type/length field must look like a fixnum. an immutable bit sits just above the fixnum tag, with the length above that.
|
||||
(define-constant mask-vector (constant mask-fixnum))
|
||||
(define-constant mask-string #b111)
|
||||
(define-constant mask-fxvector #b111)
|
||||
|
|
@ -898,32 +896,32 @@
|
|||
(define-constant mask-thread (constant byte-constant-mask))
|
||||
(define-constant mask-tlc (constant byte-constant-mask))
|
||||
|
||||
(define-constant mask-positive-fixnum #x80000003)
|
||||
|
||||
(define-constant type-mutable-vector (constant type-vector))
|
||||
(define-constant type-immutable-vector
|
||||
(fxior (constant type-vector) (constant vector-immutable-flag)))
|
||||
(fxlogor (constant type-vector) (constant vector-immutable-flag)))
|
||||
(define-constant mask-mutable-vector
|
||||
(logior (constant mask-vector) (constant vector-immutable-flag)))
|
||||
(fxlogor (constant mask-vector) (constant vector-immutable-flag)))
|
||||
|
||||
(define-constant type-mutable-string (constant type-string))
|
||||
(define-constant type-immutable-string
|
||||
(fxior (constant type-string) (constant string-immutable-flag)))
|
||||
(fxlogor (constant type-string) (constant string-immutable-flag)))
|
||||
(define-constant mask-mutable-string
|
||||
(logior (constant mask-string) (constant string-immutable-flag)))
|
||||
(fxlogor (constant mask-string) (constant string-immutable-flag)))
|
||||
|
||||
(define-constant type-mutable-fxvector (constant type-fxvector))
|
||||
(define-constant type-immutable-fxvector
|
||||
(fxior (constant type-fxvector) (constant fxvector-immutable-flag)))
|
||||
(fxlogor (constant type-fxvector) (constant fxvector-immutable-flag)))
|
||||
(define-constant mask-mutable-fxvector
|
||||
(logior (constant mask-fxvector) (constant fxvector-immutable-flag)))
|
||||
(fxlogor (constant mask-fxvector) (constant fxvector-immutable-flag)))
|
||||
|
||||
(define-constant type-mutable-bytevector (constant type-bytevector))
|
||||
(define-constant type-immutable-bytevector
|
||||
(fxior (constant type-bytevector) (constant fxvector-immutable-flag)))
|
||||
(fxlogor (constant type-bytevector) (constant fxvector-immutable-flag)))
|
||||
(define-constant mask-mutable-bytevector
|
||||
(logior (constant mask-bytevector) (constant bytevector-immutable-flag)))
|
||||
(fxlogor (constant mask-bytevector) (constant bytevector-immutable-flag)))
|
||||
|
||||
(define-constant type-mutable-box (constant type-box))
|
||||
(define-constant mask-mutable-box (constant byte-constant-mask))
|
||||
(define-constant mask-immutable-box (constant byte-constant-mask))
|
||||
|
||||
(define-constant fixnum-factor (expt 2 (constant fixnum-offset)))
|
||||
(define-constant vector-length-factor (expt 2 (constant vector-length-offset)))
|
||||
|
|
|
|||
9
s/cp0.ss
9
s/cp0.ss
|
|
@ -2411,7 +2411,14 @@
|
|||
(lambda (x y)
|
||||
(if (#2%< x 0)
|
||||
(and (#2%< y 0) (#2%< x y))
|
||||
(or (#2%< y 0) (#2%< x y)))))
|
||||
(or (#2%< y 0) (#2%< x y))))
|
||||
(lambda (level ctxt x y)
|
||||
(let ([xval (value-visit-operand! x)]
|
||||
[yval (value-visit-operand! y)])
|
||||
(and (cp0-constant? (lambda (obj) (eqv? obj (constant most-positive-fixnum))) (result-exp xval))
|
||||
(begin
|
||||
(residualize-seq (list y) (list x) ctxt)
|
||||
(build-primcall (app-preinfo ctxt) level 'fx< (list yval `(quote 0))))))))
|
||||
|
||||
(fold (fxmax tfixnum? . tfixnum?) tfixnum? #2%max)
|
||||
(fold (fxmin tfixnum? . tfixnum?) tfixnum? #2%min)
|
||||
|
|
|
|||
|
|
@ -3546,12 +3546,10 @@
|
|||
(%inline sll ,e (immediate ,(fx- 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))))))))
|
||||
(lambda (t/l length-offset)
|
||||
(%inline logand
|
||||
,(translate t/l length-offset (constant fixnum-offset))
|
||||
(immediate ,(- (constant fixnum-factor))))))
|
||||
(define build-type/length
|
||||
(lambda (e type current-shift target-shift)
|
||||
(let ([e (translate e current-shift target-shift)])
|
||||
|
|
@ -3560,7 +3558,7 @@
|
|||
(%inline logor ,e (immediate ,type))))))
|
||||
(define-syntax build-ref-check
|
||||
(syntax-rules ()
|
||||
[(_ type-disp maximum-length length-offset type mask full-mask)
|
||||
[(_ 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))
|
||||
|
|
@ -3582,7 +3580,7 @@
|
|||
(%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 full-mask) (constant length-offset)))])
|
||||
(let ([e (%inline u< ,e-i ,(extract-length t (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))))
|
||||
|
|
@ -4653,6 +4651,8 @@
|
|||
(type-pred $unbound-object? mask-unbound sunbound)
|
||||
(typed-object-pred bignum? mask-bignum type-bignum)
|
||||
(typed-object-pred box? mask-box type-box)
|
||||
(typed-object-pred mutable-box? mask-mutable-box type-mutable-box)
|
||||
(typed-object-pred immutable-box? mask-mutable-box type-immutable-box)
|
||||
(typed-object-pred bytevector? mask-bytevector type-bytevector)
|
||||
(typed-object-pred mutable-bytevector? mask-mutable-bytevector type-mutable-bytevector)
|
||||
(typed-object-pred immutable-bytevector? mask-mutable-bytevector type-immutable-bytevector)
|
||||
|
|
@ -4946,31 +4946,31 @@
|
|||
(let ()
|
||||
(define-syntax def-len
|
||||
(syntax-rules ()
|
||||
[(_ prim full-mask type type-disp length-offset)
|
||||
[(_ prim type-disp length-offset)
|
||||
(define-inline 3 prim
|
||||
[(e) (extract-length (%mref ,e ,(constant type-disp)) (constant full-mask) (constant length-offset))])]))
|
||||
(def-len vector-length mask-mutable-vector type-vector vector-type-disp vector-length-offset)
|
||||
(def-len fxvector-length mask-mutable-fxvector type-fxvector fxvector-type-disp fxvector-length-offset)
|
||||
(def-len string-length mask-mutable-string type-string string-type-disp string-length-offset)
|
||||
(def-len bytevector-length mask-mutable-bytevector type-bytevector bytevector-type-disp bytevector-length-offset)
|
||||
(def-len $bignum-length mask-bignum type-bignum bignum-type-disp bignum-length-offset))
|
||||
[(e) (extract-length (%mref ,e ,(constant type-disp)) (constant length-offset))])]))
|
||||
(def-len vector-length vector-type-disp vector-length-offset)
|
||||
(def-len fxvector-length fxvector-type-disp fxvector-length-offset)
|
||||
(def-len string-length string-type-disp string-length-offset)
|
||||
(def-len bytevector-length bytevector-type-disp bytevector-length-offset)
|
||||
(def-len $bignum-length bignum-type-disp bignum-length-offset))
|
||||
(let ()
|
||||
(define-syntax def-len
|
||||
(syntax-rules ()
|
||||
[(_ prim mask full-mask type type-disp length-offset)
|
||||
[(_ prim mask type type-disp length-offset)
|
||||
(define-inline 2 prim
|
||||
[(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 type-disp))])
|
||||
`(if ,(%type-check mask type ,t/l)
|
||||
,(extract-length t/l (constant full-mask) (constant length-offset))
|
||||
,(extract-length t/l (constant length-offset))
|
||||
(goto ,Lerr)))
|
||||
(label ,Lerr ,(build-libcall #t #f sexpr prim e)))))])]))
|
||||
(def-len vector-length mask-vector mask-mutable-vector type-vector vector-type-disp vector-length-offset)
|
||||
(def-len fxvector-length mask-fxvector mask-mutable-fxvector type-fxvector fxvector-type-disp fxvector-length-offset)
|
||||
(def-len string-length mask-string mask-mutable-string type-string string-type-disp string-length-offset)
|
||||
(def-len bytevector-length mask-bytevector mask-mutable-bytevector type-bytevector bytevector-type-disp bytevector-length-offset))
|
||||
(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 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))
|
||||
; TODO: consider adding integer?, integer-valued?, rational?, rational-valued?,
|
||||
; real?, and real-valued?
|
||||
(let ()
|
||||
|
|
@ -4989,12 +4989,6 @@
|
|||
[(e) (build-number? e)])
|
||||
(define-inline 2 complex?
|
||||
[(e) (build-number? e)]))
|
||||
(define-inline 3 mutable-box?
|
||||
[(e) (bind #t (e)
|
||||
(%typed-object-check mask-immutable-box type-mutable-box ,e))])
|
||||
(define-inline 3 immutable-box?
|
||||
[(e) (bind #t (e)
|
||||
(%typed-object-check mask-immutable-box type-immutable-box ,e))])
|
||||
(define-inline 3 set-car!
|
||||
[(e1 e2) (build-dirty-store e1 (constant pair-car-disp) e2)])
|
||||
(define-inline 3 set-cdr!
|
||||
|
|
@ -5014,7 +5008,7 @@
|
|||
(define-inline 2 set-box!
|
||||
[(e-box e-new)
|
||||
(bind #t (e-box e-new)
|
||||
`(if ,(%typed-object-check mask-mutable-box type-box ,e-box)
|
||||
`(if ,(%typed-object-check mask-mutable-box type-mutable-box ,e-box)
|
||||
,(build-dirty-store e-box (constant box-ref-disp) e-new)
|
||||
,(build-libcall #t src sexpr set-box! e-box e-new)))])
|
||||
(define-inline 2 set-car!
|
||||
|
|
@ -7676,10 +7670,8 @@
|
|||
[(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)]))))
|
||||
(let ()
|
||||
(define build-fxvector-ref-check (build-ref-check fxvector-type-disp maximum-fxvector-length fxvector-length-offset
|
||||
type-fxvector mask-fxvector mask-mutable-fxvector))
|
||||
(define build-fxvector-set!-check (build-ref-check fxvector-type-disp maximum-fxvector-length fxvector-length-offset
|
||||
type-mutable-fxvector mask-mutable-fxvector mask-mutable-fxvector))
|
||||
(define build-fxvector-ref-check (build-ref-check fxvector-type-disp maximum-fxvector-length fxvector-length-offset type-fxvector mask-fxvector))
|
||||
(define build-fxvector-set!-check (build-ref-check fxvector-type-disp maximum-fxvector-length fxvector-length-offset type-mutable-fxvector mask-mutable-fxvector))
|
||||
(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))])
|
||||
(define-inline 2 $fxvector-set!-check?
|
||||
|
|
@ -7719,19 +7711,15 @@
|
|||
`(if ,(build-fxvector-set!-check e-fv e-i e-new)
|
||||
,(go e-fv e-i e-new)
|
||||
,(build-libcall #t src sexpr fxvector-set! e-fv e-i e-new)))])
|
||||
(define-inline 3 $fxvector-set-immutable!
|
||||
[(e-fv) ((build-set-immutable! fxvector-type-disp fxvector-immutable-flag) e-fv)])))
|
||||
(define-inline 3 $fxvector-set-immutable!
|
||||
[(e-fv) ((build-set-immutable! fxvector-type-disp fxvector-immutable-flag) e-fv)])))
|
||||
(let ()
|
||||
(define build-string-ref-check
|
||||
(lambda (e-s e-i)
|
||||
((build-ref-check string-type-disp maximum-string-length string-length-offset
|
||||
type-string mask-string mask-mutable-string)
|
||||
e-s e-i #f)))
|
||||
((build-ref-check string-type-disp maximum-string-length string-length-offset type-string mask-string) e-s e-i #f)))
|
||||
(define build-string-set!-check
|
||||
(lambda (e-s e-i)
|
||||
((build-ref-check string-type-disp maximum-string-length string-length-offset
|
||||
type-mutable-string mask-mutable-string mask-mutable-string)
|
||||
e-s e-i #f)))
|
||||
((build-ref-check string-type-disp maximum-string-length string-length-offset type-mutable-string mask-mutable-string) e-s e-i #f)))
|
||||
(define-inline 2 $string-ref-check?
|
||||
[(e-s e-i) (bind #t (e-s e-i) (build-string-ref-check e-s e-i))])
|
||||
(define-inline 2 $string-set!-check?
|
||||
|
|
@ -7786,12 +7774,8 @@
|
|||
(define-inline 3 $string-set-immutable!
|
||||
[(e-s) ((build-set-immutable! string-type-disp string-immutable-flag) e-s)])))
|
||||
(let ()
|
||||
(define build-vector-ref-check
|
||||
(build-ref-check vector-type-disp maximum-vector-length vector-length-offset
|
||||
type-vector mask-vector mask-mutable-vector))
|
||||
(define build-vector-set!-check
|
||||
(build-ref-check vector-type-disp maximum-vector-length vector-length-offset
|
||||
type-mutable-vector mask-mutable-vector mask-mutable-vector))
|
||||
(define build-vector-ref-check (build-ref-check vector-type-disp maximum-vector-length vector-length-offset type-vector mask-vector))
|
||||
(define build-vector-set!-check (build-ref-check vector-type-disp maximum-vector-length vector-length-offset type-mutable-vector mask-mutable-vector))
|
||||
(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))])
|
||||
(define-inline 2 $vector-set!-check?
|
||||
|
|
@ -7826,8 +7810,8 @@
|
|||
`(if ,(build-vector-set!-check e-v e-i #f)
|
||||
,(go e-v e-i e-new)
|
||||
,(build-libcall #t src sexpr vector-set! e-v e-i e-new)))])
|
||||
(define-inline 3 $vector-set-immutable!
|
||||
[(e-fv) ((build-set-immutable! vector-type-disp vector-immutable-flag) e-fv)]))
|
||||
(define-inline 3 $vector-set-immutable!
|
||||
[(e-fv) ((build-set-immutable! vector-type-disp vector-immutable-flag) e-fv)]))
|
||||
(let ()
|
||||
(define (go e-v e-i e-new)
|
||||
`(set!
|
||||
|
|
|
|||
|
|
@ -930,23 +930,6 @@
|
|||
(defref RPHEADERLIVEMASK rp-header livemask)
|
||||
(defref RPHEADERTOPLINK rp-header toplink)
|
||||
|
||||
(def "Svector_set_immutable(x)"
|
||||
(format "~a |= ~d"
|
||||
(access "x" vector type)
|
||||
($ vector-immutable-flag)))
|
||||
(def "Sfxvector_set_immutable(x)"
|
||||
(format "~a |= ~d"
|
||||
(access "x" fxvector type)
|
||||
($ fxvector-immutable-flag)))
|
||||
(def "Sbytevector_set_immutable(x)"
|
||||
(format "~a |= ~d"
|
||||
(access "x" bytevector type)
|
||||
($ bytevector-immutable-flag)))
|
||||
(def "Sstring_set_immutable(x)"
|
||||
(format "~a |= ~d"
|
||||
(access "x" string type)
|
||||
($ string-immutable-flag)))
|
||||
|
||||
(nl)
|
||||
(comment "machine types")
|
||||
(pr "#define machine_type_names ")
|
||||
|
|
|
|||
|
|
@ -1139,7 +1139,7 @@
|
|||
(bytevector [sig [(u8/s8 ...) -> (bytevector)]] [flags alloc cp02])
|
||||
(bytevector->s8-list [sig [(bytevector) -> (list)]] [flags alloc])
|
||||
(bytevector-truncate! [sig [(bytevector length) -> (bytevector)]] [flags true])
|
||||
(bytevector->immutable-bytevector [sig [(bytevector) -> (bytevector)]] [flags alloc discard])
|
||||
(bytevector->immutable-bytevector [sig [(bytevector) -> (bytevector)]] [flags alloc])
|
||||
(bytevector-s24-ref [sig [(bytevector sub-index symbol) -> (s24)]] [flags true mifoldable discard])
|
||||
(bytevector-s24-set! [sig [(bytevector sub-index symbol s24) -> (void)]] [flags true])
|
||||
(bytevector-s40-ref [sig [(bytevector sub-index symbol) -> (s40)]] [flags true mifoldable discard])
|
||||
|
|
@ -1333,7 +1333,7 @@
|
|||
(fxvector->list [sig [(fxvector) -> (list)]] [flags alloc])
|
||||
(fxvector-copy [sig [(fxvector) -> (fxvector)]] [flags alloc])
|
||||
(fxvector-fill! [sig [(fxvector fixnum) -> (fxvector)]] [flags true])
|
||||
(fxvector->immutable-fxvector [sig [(fxvector) -> (fxvector)]] [flags alloc discard])
|
||||
(fxvector->immutable-fxvector [sig [(fxvector) -> (fxvector)]] [flags alloc])
|
||||
(fxvector-length [sig [(fxvector) -> (length)]] [flags pure mifoldable discard true])
|
||||
(fxvector-ref [sig [(fxvector sub-index) -> (fixnum)]] [flags mifoldable discard cp02])
|
||||
(fxvector-set! [sig [(fxvector sub-index fixnum) -> (void)]] [flags true])
|
||||
|
|
@ -1607,7 +1607,7 @@
|
|||
(string-ci>=? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard ieee r5rs]) ; not restricted to 2+ arguments
|
||||
(string-ci>? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard ieee r5rs]) ; not restricted to 2+ arguments
|
||||
(string-copy! [sig [(string sub-length string sub-length sub-length) -> (void)]] [flags true])
|
||||
(string->immutable-string [sig [(string) -> (string)]] [flags alloc discard])
|
||||
(string->immutable-string [sig [(string) -> (string)]] [flags alloc])
|
||||
(string-truncate! [sig [(string length) -> (string)]] [flags true])
|
||||
(strip-fasl-file [sig [(pathname pathname fasl-strip-options) -> (void)]] [flags true])
|
||||
(sub1 [sig [(number) -> (number)]] [flags arith-op mifoldable discard])
|
||||
|
|
@ -1662,7 +1662,7 @@
|
|||
(utf-16le-codec [sig [() -> (codec)]] [flags pure unrestricted true])
|
||||
(utf-16be-codec [sig [() -> (codec)]] [flags pure unrestricted true])
|
||||
(vector-copy [sig [(vector) -> (vector)]] [flags alloc])
|
||||
(vector->immutable-vector [sig [(vector) -> (vector)]] [flags alloc discard])
|
||||
(vector->immutable-vector [sig [(vector) -> (vector)]] [flags alloc])
|
||||
(vector-set-fixnum! [sig [(vector sub-index fixnum) -> (void)]] [flags true])
|
||||
(virtual-register [sig [(sub-index) -> (ptr)]] [flags discard])
|
||||
(virtual-register-count [sig [() -> (length)]] [flags pure unrestricted true cp02])
|
||||
|
|
@ -1698,7 +1698,7 @@
|
|||
($bytevector-ref-check? [flags])
|
||||
($bytevector-set!-check? [flags])
|
||||
($bytevector-set! [flags])
|
||||
($bytevector-set-immutable! [sig [(bytevector) -> (ptr)]] [flags true])
|
||||
($bytevector-set-immutable! #;[sig [(bytevector) -> (ptr)]] [flags true])
|
||||
($capture-fasl-target [flags])
|
||||
($c-error [flags])
|
||||
($check-heap-errors [flags])
|
||||
|
|
@ -1953,7 +1953,7 @@
|
|||
($fxu< [flags pure cp02])
|
||||
($fxvector-ref-check? [flags])
|
||||
($fxvector-set!-check? [flags])
|
||||
($fxvector-set-immutable! [sig [(fxvector) -> (ptr)]] [flags true])
|
||||
($fxvector-set-immutable! #;[sig [(fxvector) -> (ptr)]] [flags true])
|
||||
($gc-cpu-time [flags true])
|
||||
($gc-real-time [flags true])
|
||||
($gensym->pretty-name [flags])
|
||||
|
|
@ -2148,7 +2148,7 @@
|
|||
($string-char-foldcase [flags])
|
||||
($string-ref-check? [flags])
|
||||
($string-set!-check? [flags])
|
||||
($string-set-immutable! [sig [(string) -> (ptr)]] [flags true])
|
||||
($string-set-immutable! #;[sig [(string) -> (ptr)]] [flags true])
|
||||
($str->num [flags])
|
||||
($subsequent? [flags])
|
||||
($swap-object-ref [flags]) ; can't fold since optimize-level 2 version does no checks
|
||||
|
|
@ -2196,7 +2196,7 @@
|
|||
($unwrap-ftype-pointer [flags])
|
||||
($vector-ref-check? [flags])
|
||||
($vector-set!-check? [flags])
|
||||
($vector-set-immutable! [sig [(vector) -> (ptr)]] [flags true])
|
||||
($vector-set-immutable! #;[sig [(vector) -> (ptr)]] [flags true])
|
||||
($verify-ftype-address [flags cp02])
|
||||
($verify-ftype-pointer [flags])
|
||||
($visit [flags])
|
||||
|
|
|
|||
24
s/prims.ss
24
s/prims.ss
|
|
@ -269,55 +269,45 @@
|
|||
(define-who make-string
|
||||
(case-lambda
|
||||
[(n c)
|
||||
(meta-assert (<= (constant maximum-string-length) (constant most-positive-fixnum)))
|
||||
(unless (and (fixnum? n) ($fxu< n (fx+ (constant maximum-string-length) 1)))
|
||||
(unless (and (fixnum? n) (not ($fxu< (constant maximum-string-length) n)))
|
||||
($oops who "~s is not a valid string length" n))
|
||||
(unless (char? c)
|
||||
($oops who "~s is not a character" c))
|
||||
(make-string n c)]
|
||||
[(n)
|
||||
(meta-assert (<= (constant maximum-string-length) (constant most-positive-fixnum)))
|
||||
(unless (and (fixnum? n) ($fxu< n (fx+ (constant maximum-string-length) 1)))
|
||||
(unless (and (fixnum? n) (not ($fxu< (constant maximum-string-length) n)))
|
||||
($oops who "~s is not a valid string length" n))
|
||||
(unless (fx<= n (constant maximum-string-length))
|
||||
($oops who "~s is too large" n))
|
||||
(make-string n)]))
|
||||
|
||||
(define-who make-vector
|
||||
(case-lambda
|
||||
[(n x)
|
||||
(meta-assert (<= (constant maximum-vector-length) (constant most-positive-fixnum)))
|
||||
(unless (and (fixnum? n) ($fxu< n (fx+ (constant maximum-vector-length) 1)))
|
||||
(unless (and (fixnum? n) (not ($fxu< (constant maximum-vector-length) n)))
|
||||
($oops who "~s is not a valid vector length" n))
|
||||
(make-vector n x)]
|
||||
[(n)
|
||||
(meta-assert (<= (constant maximum-vector-length) (constant most-positive-fixnum)))
|
||||
(unless (and (fixnum? n) ($fxu< n (fx+ (constant maximum-vector-length) 1)))
|
||||
(unless (and (fixnum? n) (not ($fxu< (constant maximum-vector-length) n)))
|
||||
($oops who "~s is not a valid vector length" n))
|
||||
(make-vector n)]))
|
||||
|
||||
(define $make-eqhash-vector
|
||||
(case-lambda
|
||||
[(n)
|
||||
(unless (and (fixnum? n) (fx>= n 0))
|
||||
(unless (and (fixnum? n) (not ($fxu< (constant maximum-vector-length) n)))
|
||||
($oops '$make-eqhash-vector "~s is not a nonnegative fixnum" n))
|
||||
($make-eqhash-vector n)]))
|
||||
|
||||
(define-who make-fxvector
|
||||
(case-lambda
|
||||
[(n x)
|
||||
(meta-assert (<= (constant maximum-fxvector-length) (constant most-positive-fixnum)))
|
||||
(unless (and (fixnum? n) ($fxu< n (fx+ (constant maximum-fxvector-length) 1)))
|
||||
(unless (and (fixnum? n) (not ($fxu< (constant maximum-fxvector-length) n)))
|
||||
($oops who "~s is not a valid fxvector length" n))
|
||||
(unless (fixnum? x)
|
||||
($oops who "~s is not a fixnum" x))
|
||||
(make-fxvector n x)]
|
||||
[(n)
|
||||
(meta-assert (<= (constant maximum-fxvector-length) (constant most-positive-fixnum)))
|
||||
(unless (and (fixnum? n) ($fxu< n (fx+ (constant maximum-fxvector-length) 1)))
|
||||
(unless (and (fixnum? n) (not ($fxu< (constant maximum-fxvector-length) n)))
|
||||
($oops who "~s is not a valid fxvector length" n))
|
||||
(unless (fx<= n (constant maximum-fxvector-length))
|
||||
($oops who "~s is too large" n))
|
||||
(make-fxvector n)]))
|
||||
|
||||
(define string-fill!
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user