From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 7 Jan 2017 09:54:31 +0000 (-0800)
Subject: Eliminate use of vector-8b in char.
X-Git-Tag: mit-scheme-pucked-9.2.12~227^2~185
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=9eb2fe45088ffcc008a92457ecbba9e489e4b29e;p=mit-scheme.git

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.
---

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 (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>=? 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)
-	  %char<?
-	  downcase-table
-	  upcase-table)
-  (export (runtime parser)
-	  downcase-table
-	  identity-table)
   (export (runtime unicode)
 	  legal-code-16?
 	  legal-code-32?)
diff --git a/src/runtime/string.scm b/src/runtime/string.scm
index 1c32c3cb9..ec5300994 100644
--- a/src/runtime/string.scm
+++ b/src/runtime/string.scm
@@ -67,22 +67,6 @@ USA.
 
 (define (string-ci-hash key #!optional modulus)
   (string-hash (string-downcase key) modulus))
-
-;;; Character optimizations
-
-(define-integrable (%%char-downcase char)
-  (integer->char (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-ci<? c1 c2)
-  (fix:< (vector-8b-ref upcase-table (char->integer 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<? (string-ref string1 index)
-			(string-ref string2 index))
+	      ((char<? (string-ref string1 index)
+		       (string-ref string2 index))
 	       (if<))
 	      (else
 	       (if>)))))))
@@ -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<? (string-ref string1 index)
-			   (string-ref string2 index))
+	      ((char-ci<? (string-ref string1 index)
+			  (string-ref string2 index))
 	       (if<))
 	      (else
 	       (if>)))))))
@@ -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)
@@ -1089,7 +1073,7 @@ USA.
       (let loop ((i 0))
 	(if (fix:= i end)
 	    (fix:< end1 end2)
-	    (or (%char<? (string-ref string1 i) (string-ref string2 i))
+	    (or (char<? (string-ref string1 i) (string-ref string2 i))
 		(and (char=? (string-ref string1 i) (string-ref string2 i))
 		     (loop (fix:+ i 1)))))))))
 
@@ -1104,8 +1088,8 @@ USA.
       (let loop ((i 0))
 	(if (fix:= i end)
 	    (fix:< end1 end2)
-	    (or (%char-ci<? (string-ref string1 i) (string-ref string2 i))
-		(and (%char-ci=? (string-ref string1 i) (string-ref string2 i))
+	    (or (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)
@@ -1121,7 +1105,7 @@ USA.
       (let loop ((i1 start1) (i2 start2))
 	(if (fix:= i1 end)
 	    (fix:< len1 len2)
-	    (or (%char<? (string-ref string1 i1) (string-ref string2 i2))
+	    (or (char<? (string-ref string1 i1) (string-ref string2 i2))
 		(and (char=? (string-ref string1 i1) (string-ref string2 i2))
 		     (loop (fix:+ i1 1) (fix:+ i2 1)))))))))
 
@@ -1138,9 +1122,9 @@ USA.
       (let loop ((i1 start1) (i2 start2))
 	(if (fix:= i1 end)
 	    (fix:< len1 len2)
-	    (or (%char-ci<? (string-ref string1 i1) (string-ref string2 i2))
-		(and (%char-ci=? (string-ref string1 i1)
-				 (string-ref string2 i2))
+	    (or (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-integrable (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)))))))