From e7ea36ad88ca2c793be3b89f82a8959ff535eebd Mon Sep 17 00:00:00 2001
From: Matt Birkholz <matt@birchwood-abbey.net>
Date: Fri, 3 Feb 2017 13:23:28 -0700
Subject: [PATCH] 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).
---
 src/runtime/bytevector.scm | 211 +++++++++++++++----------------------
 src/runtime/fixart.scm     |  57 +++++-----
 src/runtime/make.scm       |   1 -
 src/runtime/runtime.pkg    |   3 +-
 4 files changed, 110 insertions(+), 162 deletions(-)

diff --git a/src/runtime/bytevector.scm b/src/runtime/bytevector.scm
index 6d3bbf2a3..50bc5ad8c 100644
--- 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.
 
 ;;;; 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)))))
+
+(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))))
-
-(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)))
 
 (define-integrable (string-encoder char-byte-length allocator encode-char!
 				   caller)
diff --git a/src/runtime/fixart.scm b/src/runtime/fixart.scm
index 475f98432..9d88f5a10 100644
--- 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)))
 
-(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)
-
 ;;;; Flonums
 
 (define-primitives
diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index 12e4d4336..eed707df4 100644
--- 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 046eabde9..9ff8d529e 100644
--- 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")
-- 
2.25.1