Undo 4e9e832; choose fixnum/bignum ops for u32s at compile-time.

This avoids irritating LIAR/i386 which signals an obscure error when
compiling (fix:<= object #xFFFFFFFF).

diff --git a/src/runtime/bytevector.scm b/src/runtime/bytevector.scm
index 6d3bbf2a384fadef281268d48c72e80b78ad5d1a..50bc5ad8c26695309976ca632ff6cf170c7854b4 100644 (file)
--- a/src/runtime/bytevector.scm
+++ b/src/runtime/bytevector.scm
@@ -32,7 +32,9 @@ USA.
 (define (register-mit-bytevector-predicates!)
   (register-predicate! u8? 'u8 '<= index-fixnum?)
   (register-predicate! u16? 'u16 '<= index-fixnum?)
-  (register-predicate! u32? 'u32 '<= exact-nonnegative-integer?))
+  (register-predicate! u32? 'u32 '<= (if (fix:fixnum? #xFFFFFFFF)
+                                        index-fixnum?
+                                        exact-nonnegative-integer?)))
 
 (define (u8? object)
   (and (index-fixnum? object)
@@ -162,142 +164,95 @@ USA.
 \f
 ;;;; U32 accessors
 
-;;; A lot of trouble to use fixnums if the architecture supports them.  When
-;;; Scheme is started it does the test and chooses the impleemntation.  The
-;;; exported names are fixed so that stashed copies of their values always get
-;;; the current implementation.
+(define-syntax select-u32-code
+  (er-macro-transformer
+   (lambda (form rename compare)
+     rename compare
+     (syntax-check '(KEYWORD EXPRESSION EXPRESSION) form)
+     (if (fix:fixnum? #xFFFFFFFF)
+        (cadr form)
+        (caddr form)))))
+
+(select-u32-code
+ ;; Can use fixnums:
+ (begin
+   (define-integrable (bytes->u32be b0 b1 b2 b3)
+     (fix:or (fix:or (fix:lsh b0 24)
+                    (fix:lsh b1 16))
+            (fix:or (fix:lsh b2 8)
+                    b3)))
+
+   (define-integrable (u32be-byte0 u32) (fix:lsh u32 -24))
+   (define-integrable (u32be-byte1 u32) (fix:and (fix:lsh u32 -16) #xFF))
+   (define-integrable (u32be-byte2 u32) (fix:and (fix:lsh u32 -8) #xFF))
+   (define-integrable (u32be-byte3 u32) (fix:and u32 #xFF))
+
+   (define (u32? object)
+     (and (index-fixnum? object)
+         (fix:<= object #xFFFFFFFF))))
+ ;; Must use bignums:
+ (begin
+   (define-integrable (bytes->u32be b0 b1 b2 b3)
+     (int:+ (int:+ (int:* b0 #x1000000)
+                  (int:* b1 #x10000))
+           (int:+ (int:* b2 #x100)
+                  b3)))
+
+   (define-integrable (u32be-byte0 u32)
+     (int:quotient u32 #x1000000))
+
+   (define-integrable (u32be-byte1 u32)
+     (int:remainder (int:quotient u32 #x10000) #x100))
+
+   (define-integrable (u32be-byte2 u32)
+     (int:remainder (int:quotient u32 #x100) #x100))
+
+   (define-integrable (u32be-byte3 u32)
+     (int:remainder u32 #x100))
+
+   (define (u32? object)
+     (and (exact-nonnegative-integer? object)
+         (int:<= object #xFFFFFFFF)))))
+\f
+(define-integrable (bytes->u32le b0 b1 b2 b3) (bytes->u32be b3 b2 b1 b0))
+(define-integrable u32le-byte0 u32be-byte3)
+(define-integrable u32le-byte1 u32be-byte2)
+(define-integrable u32le-byte2 u32be-byte1)
+(define-integrable u32le-byte3 u32be-byte0)
 
 (define (bytevector-u32be-ref bytevector index)
-  (%u32be-ref bytevector index))
+  (if (not (fix:< (fix:+ index 3) (bytevector-length bytevector)))
+      (error:bad-range-argument index 'bytevector-u32be-ref))
+  (bytes->u32be (bytevector-u8-ref bytevector index)
+               (bytevector-u8-ref bytevector (fix:+ index 1))
+               (bytevector-u8-ref bytevector (fix:+ index 2))
+               (bytevector-u8-ref bytevector (fix:+ index 3))))
 
 (define (bytevector-u32be-set! bytevector index u32)
-  (%u32be-set! bytevector index u32))
+  (if (not (fix:< (fix:+ index 3) (bytevector-length bytevector)))
+      (error:bad-range-argument index 'bytevector-u32be-ref))
+  (guarantee u32? u32 'bytevector-u32be-set!)
+  (bytevector-u8-set! bytevector index (u32be-byte0 u32))
+  (bytevector-u8-set! bytevector (fix:+ index 1) (u32be-byte1 u32))
+  (bytevector-u8-set! bytevector (fix:+ index 2) (u32be-byte2 u32))
+  (bytevector-u8-set! bytevector (fix:+ index 3) (u32be-byte3 u32)))
 
 (define (bytevector-u32le-ref bytevector index)
-  (%u32le-ref bytevector index))
-
-(define (bytevector-u32le-set! bytevector index u32)
-  (%u32le-set! bytevector index u32))
-
-(define (u32? object)
-  (%u32? object))
-
-(define %u32?)
-(define %u32be-ref)
-(define %u32be-set!)
-(define %u32le-ref)
-(define %u32le-set!)
-(define (choose-u32-type!)
-  (if (<= #xFFFFFFFF (fix:largest-value))
-      (begin
-       (set! %u32? fix:u32?)
-       (set! %u32be-ref fix:u32be-ref)
-       (set! %u32be-set! fix:u32be-set!)
-       (set! %u32le-ref fix:u32le-ref)
-       (set! %u32le-set! fix:u32le-set!))
-      (begin
-       (set! %u32? int:u32?)
-       (set! %u32be-ref int:u32be-ref)
-       (set! %u32be-set! int:u32be-set!)
-       (set! %u32le-ref int:u32le-ref)
-       (set! %u32le-set! int:u32le-set!)))
-  unspecific)
-
-(add-boot-init!
- (lambda ()
-   (choose-u32-type!)
-   (add-event-receiver! event:after-restore choose-u32-type!)))
-
-(define-integrable (u32-getter bytes->u32 caller)
-  (lambda (bytevector index)
-    (if (not (fix:< (fix:+ index 3) (bytevector-length bytevector)))
-       (error:bad-range-argument index caller))
-    (bytes->u32 (bytevector-u8-ref bytevector index)
+  (if (not (fix:< (fix:+ index 3) (bytevector-length bytevector)))
+      (error:bad-range-argument index 'bytevector-u32le-ref))
+  (bytes->u32le (bytevector-u8-ref bytevector index)
                (bytevector-u8-ref bytevector (fix:+ index 1))
                (bytevector-u8-ref bytevector (fix:+ index 2))
-               (bytevector-u8-ref bytevector (fix:+ index 3)))))
-
-(define-integrable (u32-setter u32-byte0 u32-byte1 u32-byte2 u32-byte3
-                              u32? caller)
-  (lambda (bytevector index u32)
-    (if (not (fix:< (fix:+ index 3) (bytevector-length bytevector)))
-       (error:bad-range-argument index caller))
-    (guarantee u32? u32 caller)
-    (bytevector-u8-set! bytevector index (u32-byte0 u32))
-    (bytevector-u8-set! bytevector (fix:+ index 1) (u32-byte1 u32))
-    (bytevector-u8-set! bytevector (fix:+ index 2) (u32-byte2 u32))
-    (bytevector-u8-set! bytevector (fix:+ index 3) (u32-byte3 u32))))
-\f
-(define-integrable (fix:bytes->u32be b0 b1 b2 b3)
-  (fix:or (fix:or (fix:lsh b0 24)
-                 (fix:lsh b1 16))
-         (fix:or (fix:lsh b2 8)
-                 b3)))
-
-(define-integrable (fix:u32be-byte0 u32) (fix:lsh u32 -24))
-(define-integrable (fix:u32be-byte1 u32) (fix:and (fix:lsh u32 -16) #xFF))
-(define-integrable (fix:u32be-byte2 u32) (fix:and (fix:lsh u32 -8) #xFF))
-(define-integrable (fix:u32be-byte3 u32) (fix:and u32 #xFF))
-
-(define (fix:u32? object)
-  (and (index-fixnum? object)
-       (fix:<= object #xFFFFFFFF)))
-
-(define-integrable (fix:bytes->u32le b0 b1 b2 b3)
-  (fix:bytes->u32be b3 b2 b1 b0))
-
-(define fix:u32be-ref
-  (u32-getter fix:bytes->u32be 'bytevector-u32be-ref))
+               (bytevector-u8-ref bytevector (fix:+ index 3))))
 
-(define fix:u32be-set!
-  (u32-setter fix:u32be-byte0 fix:u32be-byte1 fix:u32be-byte2 fix:u32be-byte3
-             fix:u32? 'bytevector-u32be-set!))
-
-(define fix:u32le-ref
-  (u32-getter fix:bytes->u32le 'bytevector-u32le-ref))
-
-(define fix:u32le-set!
-  (u32-setter fix:u32be-byte3 fix:u32be-byte2 fix:u32be-byte1 fix:u32be-byte0
-             fix:u32? 'bytevector-u32le-set!))
-
-(define-integrable (int:bytes->u32be b0 b1 b2 b3)
-  (int:+ (int:+ (int:* b0 #x1000000)
-               (int:* b1 #x10000))
-        (int:+ (int:* b2 #x100)
-               b3)))
-
-(define-integrable (int:u32be-byte0 u32)
-  (int:quotient u32 #x1000000))
-
-(define-integrable (int:u32be-byte1 u32)
-  (int:remainder (int:quotient u32 #x10000) #x100))
-
-(define-integrable (int:u32be-byte2 u32)
-  (int:remainder (int:quotient u32 #x100) #x100))
-
-(define-integrable (int:u32be-byte3 u32)
-  (int:remainder u32 #x100))
-
-(define (int:u32? object)
-  (and (exact-nonnegative-integer? object)
-       (int:<= object #xFFFFFFFF)))
-
-(define-integrable (int:bytes->u32le b0 b1 b2 b3)
-  (int:bytes->u32be b3 b2 b1 b0))
-
-(define int:u32be-ref
-  (u32-getter int:bytes->u32be 'bytevector-u32be-ref))
-
-(define int:u32be-set!
-  (u32-setter int:u32be-byte0 int:u32be-byte1 int:u32be-byte2 int:u32be-byte3
-             int:u32? 'bytevector-u32be-set!))
-
-(define int:u32le-ref
-  (u32-getter int:bytes->u32le 'bytevector-u32le-ref))
-
-(define int:u32le-set!
-  (u32-setter int:u32be-byte3 int:u32be-byte2 int:u32be-byte1 int:u32be-byte0
-             int:u32? 'bytevector-u32le-set!))
+(define (bytevector-u32le-set! bytevector index u32)
+  (if (not (fix:< (fix:+ index 3) (bytevector-length bytevector)))
+      (error:bad-range-argument index 'bytevector-u32le-ref))
+  (guarantee u32? u32 'bytevector-u32le-set!)
+  (bytevector-u8-set! bytevector index (u32le-byte0 u32))
+  (bytevector-u8-set! bytevector (fix:+ index 1) (u32le-byte1 u32))
+  (bytevector-u8-set! bytevector (fix:+ index 2) (u32le-byte2 u32))
+  (bytevector-u8-set! bytevector (fix:+ index 3) (u32le-byte3 u32)))
 \f
 (define-integrable (string-encoder char-byte-length allocator encode-char!
                                   caller)

diff --git a/src/runtime/fixart.scm b/src/runtime/fixart.scm
index 475f984324c5a9a84fc4461f9156c46b606b25cd..9d88f5a10f04947779eb0888648bb35bd9d5e050 100644 (file)
--- a/src/runtime/fixart.scm
+++ b/src/runtime/fixart.scm
@@ -93,6 +93,32 @@ USA.
 (define (fix:min n m) (if (fix:< n m) n m))
 (define (fix:max n m) (if (fix:> n m) n m))
 
+(define (fix:largest-value)
+  (force largest-fixnum-promise))
+
+(define largest-fixnum-promise
+  (delay
+    (let loop ((n 1))
+      (if (fix:fixnum? n)
+         (loop (* n 2))
+         (let ((n (- n 1)))
+           (if (not (fix:fixnum? n))
+               (error "Unable to compute largest fixnum:" n))
+           n)))))
+
+(define (fix:smallest-value)
+  (force smallest-fixnum-promise))
+
+(define smallest-fixnum-promise
+  (delay
+    (let loop ((n -1))
+      (if (fix:fixnum? n)
+         (loop (* n 2))
+         (let ((n (quotient n 2)))
+           (if (not (fix:fixnum? n))
+               (error "Unable to compute smallest fixnum:" n))
+           n)))))
+
 (define (fix:iota count #!optional start step)
   (guarantee index-fixnum? count 'fix:iota)
   (let ((start
@@ -135,37 +161,6 @@ USA.
            (error:bad-range-argument start caller))
        start)))
 \f
-(define (fix:largest-value)
-  largest-fixnum-value)
-
-(define (fix:smallest-value)
-  smallest-fixnum-value)
-
-(define (initialize-package!)
-  (initialize-microcode-dependencies!)
-  (add-event-receiver! event:after-restore initialize-microcode-dependencies!))
-
-(define largest-fixnum-value)
-(define smallest-fixnum-value)
-(define (initialize-microcode-dependencies!)
-  (set! largest-fixnum-value
-       (let loop ((n 1))
-         (if (fix:fixnum? n)
-             (loop (* n 2))
-             (let ((n (- n 1)))
-               (if (not (fix:fixnum? n))
-                   (error "Unable to compute largest fixnum:" n))
-               n))))
-  (set! smallest-fixnum-value
-       (let loop ((n -1))
-         (if (fix:fixnum? n)
-             (loop (* n 2))
-             (let ((n (quotient n 2)))
-               (if (not (fix:fixnum? n))
-                   (error "Unable to compute smallest fixnum:" n))
-               n))))
-  unspecific)
-\f
 ;;;; Flonums
 
 (define-primitives

diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index 12e4d433637b2660eb9ef69a6bd56e301802e319..eed707df46316ec8cfab98b4852a6f7c5537eef7 100644 (file)
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -440,7 +440,6 @@ USA.
    ;; Basic data structures
    (RUNTIME NUMBER)
    ((RUNTIME NUMBER) INITIALIZE-DRAGON4!)
-   (RUNTIME FIXNUM-ARITHMETIC)
    (RUNTIME MISCELLANEOUS-GLOBAL)
    (RUNTIME CHARACTER)
    (RUNTIME BYTEVECTOR)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 046eabde9bc8c2984b48306c477a352e9b3a7306..9ff8d529eefe30d905c9716e47acf1c5b738c79e 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -318,8 +318,7 @@ USA.
          negative-fixnum?
          non-negative-fixnum?
          non-positive-fixnum?
-         positive-fixnum?)
-  (initialization (initialize-package!)))
+         positive-fixnum?))
 
 (define-package (runtime floating-point-environment)
   (files "floenv")