From 9eb2fe45088ffcc008a92457ecbba9e489e4b29e Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sat, 7 Jan 2017 01:54:31 -0800 Subject: [PATCH] Eliminate use of vector-8b in char. * Arrange for bytevector to be available early in the cold load. * Eliminate redundant type-checking on procedures that call char->integer. --- src/runtime/bytevector.scm | 5 -- src/runtime/char.scm | 82 ++++++++---------------------- src/runtime/make.scm | 1 - src/runtime/parse.scm | 13 ++--- src/runtime/predicate-metadata.scm | 2 + src/runtime/runtime.pkg | 7 --- src/runtime/string.scm | 64 +++++++++-------------- 7 files changed, 49 insertions(+), 125 deletions(-) diff --git a/src/runtime/bytevector.scm b/src/runtime/bytevector.scm index 5fdd04ee3..1e0247089 100644 --- a/src/runtime/bytevector.scm +++ b/src/runtime/bytevector.scm @@ -40,11 +40,6 @@ USA. (bytevector-u8-set! 3) (bytevector? 1)) -(add-boot-init! - (lambda () - (register-predicate! byte? 'byte '<= exact-nonnegative-integer?) - (register-predicate! bytevector? 'bytevector))) - (define (make-bytevector k #!optional byte) (let ((bytevector (allocate-bytevector k))) (if (not (default-object? byte)) diff --git a/src/runtime/char.scm b/src/runtime/char.scm index bb90f90d8..5d2c5c4de 100644 --- a/src/runtime/char.scm +++ b/src/runtime/char.scm @@ -38,15 +38,6 @@ USA. (define-integrable char-bits-limit #x10) (define-integrable char-integer-limit #x2000000) -(define-integrable (%make-char code bits) - (integer->char (fix:or (fix:lsh bits 21) code))) - -(define-integrable (%char-code char) - (fix:and (char->integer char) #x1FFFFF)) - -(define-integrable (%char-bits char) - (fix:lsh (char->integer char) -21)) - (define-guarantee char "character") (define (make-char code bits) @@ -54,39 +45,36 @@ USA. (guarantee-limited-index-fixnum bits char-bits-limit 'MAKE-CHAR) (%make-char code bits)) +(define-integrable (%make-char code bits) + (integer->char (fix:or (fix:lsh bits 21) code))) + (define (code->char code) (guarantee-limited-index-fixnum code char-code-limit 'CODE->CHAR) (integer->char code)) (define (char-code char) - (guarantee-char char 'CHAR-CODE) - (%char-code char)) + (fix:and (char->integer char) #x1FFFFF)) (define (char-bits char) - (guarantee-char char 'CHAR-BITS) - (%char-bits char)) + (fix:lsh (char->integer char) -21)) (define (char-bits-set? bits char) (guarantee-limited-index-fixnum bits char-bits-limit 'CHAR-BITS-SET?) - (guarantee-char char 'CHAR-BITS-SET?) - (fix:= bits (fix:and (%char-bits char) bits))) + (fix:= bits (fix:and (char-bits char) bits))) (define (char-bits-clear? bits char) (guarantee-limited-index-fixnum bits char-bits-limit 'CHAR-BITS-CLEAR?) - (guarantee-char char 'CHAR-BITS-CLEAR?) - (fix:= 0 (fix:and (%char-bits char) bits))) + (fix:= 0 (fix:and (char-bits char) bits))) (define (set-char-bits bits char) (guarantee-limited-index-fixnum bits char-bits-limit 'SET-CHAR-BITS) - (guarantee-char char 'SET-CHAR-BITS) - (%make-char (%char-code char) - (fix:or (%char-bits char) bits))) + (%make-char (char-code char) + (fix:or (char-bits char) bits))) (define (clear-char-bits bits char) (guarantee-limited-index-fixnum bits char-bits-limit 'CLEAR-CHAR-BITS) - (guarantee-char char 'CLEAR-CHAR-BITS) - (%make-char (%char-code char) - (fix:andc (%char-bits char) bits))) + (%make-char (char-code char) + (fix:andc (char-bits char) bits))) (define (unicode-char? object) (and (char? object) @@ -128,7 +116,6 @@ USA. (error:not-8-bit-char object))) (define (char-ascii? char) - (guarantee-char char 'CHAR-ASCII?) (let ((n (char->integer char))) (and (fix:< n 256) n))) @@ -145,41 +132,18 @@ USA. (map char->ascii chars)) (define (char=? x y) - ;; There's no %CHAR=? because the compiler recodes CHAR=? as EQ?. - (guarantee-char x 'CHAR=?) - (guarantee-char y 'CHAR=?) (fix:= (char->integer x) (char->integer y))) (define (charinteger x) (char->integer y))) (define (char<=? x y) - (guarantee-char x 'CHAR<=?) - (guarantee-char y 'CHAR<=?) - (%char<=? x y)) - -(define-integrable (%char<=? x y) (fix:<= (char->integer x) (char->integer y))) (define (char>? x y) - (guarantee-char x 'CHAR>?) - (guarantee-char y 'CHAR>?) - (%char>? x y)) - -(define-integrable (%char>? x y) (fix:> (char->integer x) (char->integer y))) (define (char>=? x y) - (guarantee-char x 'CHAR>=?) - (guarantee-char y 'CHAR>=?) - (%char>=? x y)) - -(define-integrable (%char>=? x y) (fix:>= (char->integer x) (char->integer y))) (define (char-ci=? x y) @@ -201,39 +165,34 @@ USA. (char->integer (char-upcase char))) (define (char-downcase char) - (guarantee-char char 'CHAR-DOWNCASE) (%case-map-char char downcase-table)) (define (char-upcase char) - (guarantee-char char 'CHAR-UPCASE) (%case-map-char char upcase-table)) (define-integrable (%case-map-char char table) - (if (fix:< (%char-code char) #x100) - (%make-char (vector-8b-ref table (%char-code char)) - (%char-bits char)) + (if (fix:< (char-code char) #x100) + (%make-char (bytevector-u8-ref table (char-code char)) + (char-bits char)) char)) (define downcase-table) -(define identity-table) (define upcase-table) (define (initialize-case-conversions!) - (set! downcase-table (make-string #x100)) - (set! identity-table (make-string #x100)) - (set! upcase-table (make-string #x100)) + (set! downcase-table (make-bytevector #x100)) + (set! upcase-table (make-bytevector #x100)) (do ((i 0 (fix:+ i 1))) ((fix:= i #x100)) - (vector-8b-set! downcase-table i i) - (vector-8b-set! identity-table i i) - (vector-8b-set! upcase-table i i)) + (bytevector-u8-set! downcase-table i i) + (bytevector-u8-set! upcase-table i i)) (let ((case-range (lambda (uc-low uc-high lc-low) (do ((i uc-low (fix:+ i 1)) (j lc-low (fix:+ j 1))) ((fix:> i uc-high)) - (vector-8b-set! downcase-table i j) - (vector-8b-set! upcase-table j i))))) + (bytevector-u8-set! downcase-table i j) + (bytevector-u8-set! upcase-table j i))))) (case-range 65 90 97) (case-range 192 214 224) (case-range 216 222 248))) @@ -267,7 +226,6 @@ USA. (string-ref "0123456789abcdefghijklmnopqrstuvwxyz" digit)) (define (char->digit char #!optional radix) - (guarantee-char char 'CHAR->DIGIT) (let ((code (char->integer char)) (radix (cond ((default-object? radix) diff --git a/src/runtime/make.scm b/src/runtime/make.scm index 90cdfb4c9..4ec950ce3 100644 --- a/src/runtime/make.scm +++ b/src/runtime/make.scm @@ -457,7 +457,6 @@ USA. (RUNTIME TAGGING) (RUNTIME HASH) (RUNTIME DYNAMIC) - (RUNTIME BYTEVECTOR) (RUNTIME REGULAR-SEXPRESSION) ;; Microcode data structures (RUNTIME HISTORY) diff --git a/src/runtime/parse.scm b/src/runtime/parse.scm index 5f6713669..9226c96cd 100644 --- a/src/runtime/parse.scm +++ b/src/runtime/parse.scm @@ -529,19 +529,12 @@ USA. (define (parse-atom-1 port db prefix quoting?) (let ((port* (open-output-string)) - (table + (%canon (if (db-canonicalize-symbols? db) - downcase-table - identity-table)) + char-downcase + (lambda (char) char))) (atom-delimiters (db-atom-delimiters db)) (constituents (db-constituents db))) - (define (%canon char) - ;; Assumption: No character involved in I/O has bucky bits, and - ;; case conversion applies only to ISO-8859-1 characters. - (let ((integer (char->integer char))) - (if (fix:< integer #x100) - (integer->char (vector-8b-ref table integer)) - char))) (define (%read) (if (pair? prefix) (let ((char (car prefix))) diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm index f6149db4f..e5486f7fb 100644 --- a/src/runtime/predicate-metadata.scm +++ b/src/runtime/predicate-metadata.scm @@ -210,6 +210,7 @@ USA. (lambda () ;; R7RS (register-predicate! boolean? 'boolean) + (register-predicate! bytevector? 'bytevector) (register-predicate! char? 'char) (register-predicate! default-object? 'default-object) (register-predicate! eof-object? 'eof-object) @@ -245,6 +246,7 @@ USA. (register-predicate! exact-positive-integer? 'exact-positive-integer '<= exact-integer?) (register-predicate! exact-rational? 'exact-rational '<= rational?) + (register-predicate! byte? 'byte '<= exact-nonnegative-integer?) (register-predicate! fix:fixnum? 'fixnum '<= exact-integer?) (register-predicate! index-fixnum? 'index-fixnum '<= fix:fixnum?) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 5cf6b9366..33b9560b3 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -1259,13 +1259,6 @@ USA. set-char-bits unicode-char? unicode-scalar-value?) - (export (runtime string) - %charchar (vector-8b-ref downcase-table (char->integer char)))) - -(define-integrable (%%char-upcase char) - (integer->char (vector-8b-ref upcase-table (char->integer char)))) - -(define-integrable (%char-ci=? c1 c2) - (fix:= (vector-8b-ref upcase-table (char->integer c1)) - (vector-8b-ref upcase-table (char->integer c2)))) - -(define-integrable (%char-ciinteger c1)) - (vector-8b-ref upcase-table (char->integer c2)))) ;;;; Basic Operations @@ -697,7 +681,7 @@ USA. (let ((string* (make-string end))) (do ((i 0 (fix:+ i 1))) ((fix:= i end)) - (string-set! string* i (%%char-upcase (string-ref string i)))) + (string-set! string* i (char-upcase (string-ref string i)))) string*))) (define (string-upcase! string) @@ -711,7 +695,7 @@ USA. (define (%substring-upcase! string start end) (do ((i start (fix:+ i 1))) ((fix:= i end)) - (string-set! string i (%%char-upcase (string-ref string i))))) + (string-set! string i (char-upcase (string-ref string i))))) (define (string-lower-case? string) (guarantee-string string 'STRING-LOWER-CASE?) @@ -742,7 +726,7 @@ USA. (let ((string* (make-string end))) (do ((i 0 (fix:+ i 1))) ((fix:= i end)) - (string-set! string* i (%%char-downcase (string-ref string i)))) + (string-set! string* i (char-downcase (string-ref string i)))) string*))) (define (string-downcase! string) @@ -756,7 +740,7 @@ USA. (define (%substring-downcase! string start end) (do ((i start (fix:+ i 1))) ((fix:= i end)) - (string-set! string i (%%char-downcase (string-ref string i))))) + (string-set! string i (char-downcase (string-ref string i))))) (define (string-capitalized? string) (guarantee-string string 'STRING-CAPITALIZED?) @@ -922,8 +906,8 @@ USA. ((char=? (string-ref string1 index) (string-ref string2 index)) (loop (fix:+ index 1))) - ((%char))))))) @@ -943,11 +927,11 @@ USA. (if=) (if<)) (if>))) - ((%char-ci=? (string-ref string1 index) - (string-ref string2 index)) + ((char-ci=? (string-ref string1 index) + (string-ref string2 index)) (loop (fix:+ index 1))) - ((%char-ci))))))) @@ -1049,7 +1033,7 @@ USA. (and (fix:= end (string-length string2)) (let loop ((i 0)) (or (fix:= i end) - (and (%char-ci=? (string-ref string1 i) (string-ref string2 i)) + (and (char-ci=? (string-ref string1 i) (string-ref string2 i)) (loop (fix:+ i 1)))))))) (define (substring=? string1 start1 end1 string2 start2 end2) @@ -1075,7 +1059,7 @@ USA. (and (fix:= (fix:- end1 start1) (fix:- end2 start2)) (let loop ((i1 start1) (i2 start2)) (or (fix:= i1 end1) - (and (%char-ci=? (string-ref string1 i1) (string-ref string2 i2)) + (and (char-ci=? (string-ref string1 i1) (string-ref string2 i2)) (loop (fix:+ i1 1) (fix:+ i2 1))))))) (define (string? string1 string2) @@ -1196,8 +1180,8 @@ USA. (let ((end (fix:+ start1 (fix:min (fix:- end1 start1) (fix:- end2 start2))))) (let loop ((i1 start1) (i2 start2)) (if (or (fix:= i1 end) - (not (%char-ci=? (string-ref string1 i1) - (string-ref string2 i2)))) + (not (char-ci=? (string-ref string1 i1) + (string-ref string2 i2)))) (fix:- i1 start1) (loop (fix:+ i1 1) (fix:+ i2 1)))))) @@ -1239,7 +1223,7 @@ USA. (if (fix:= end1 start) 0 (let loop ((i1 (fix:- end1 1)) (i2 (fix:- end2 1))) - (if (%char-ci=? (string-ref string1 i1) (string-ref string2 i2)) + (if (char-ci=? (string-ref string1 i1) (string-ref string2 i2)) (if (fix:= i1 start) (fix:- end1 i1) (loop (fix:- i1 1) (fix:- i2 1))) @@ -1352,7 +1336,7 @@ USA. (define (%substring-find-next-char-ci string start end char) (let loop ((i start)) (cond ((fix:= i end) #f) - ((%char-ci=? (string-ref string i) char) i) + ((char-ci=? (string-ref string i) char) i) (else (loop (fix:+ i 1)))))) (define (string-find-previous-char string char) @@ -1387,7 +1371,7 @@ USA. (if (fix:= start end) #f (let loop ((i (fix:- end 1))) - (cond ((%char-ci=? (string-ref string i) char) i) + (cond ((char-ci=? (string-ref string i) char) i) ((fix:= start i) #f) (else (loop (fix:- i 1))))))) -- 2.25.1