From c05ea153dc52ae79fca3ac4bc099dc7c712c9208 Mon Sep 17 00:00:00 2001
From: Peter Bex <address@hidden>
Date: Sun, 21 May 2017 18:54:38 +0200
Subject: [PATCH] In the scrutinizer, do not assume big fixnums will fit into
 32 bits

When the scrutinizer applies a specialization for a fixnum, it should
make sure it really is a fixnum.  If compiling on a 64-bit platform, a
fixnum literal might no longer be a fixnum when the program is running
on a 32-bit platform.

Thus, we check whether the literal is a big-fixnum? first.

Similarly, small bignums are rewritten to 'integer for the reverse
situation: when compiling on 32-bit, a bignum might become a fixnum
when running on 64-bit.
---
 NEWS                      |  4 ++++
 lfa2.scm                  | 11 ++++-------
 scrutinizer.scm           | 11 +++++------
 support.scm               |  7 ++++++-
 tests/typematch-tests.scm | 21 +++++++++++++++++++++
 5 files changed, 40 insertions(+), 14 deletions(-)

diff --git a/NEWS b/NEWS
index 492546a..aa626c7 100644
--- a/NEWS
+++ b/NEWS
@@ -105,6 +105,10 @@
 - Build system
   - Fixed broken compilation on NetBSD, due to missing _NETBSD_SOURCE.
 
+- Compiler
+  - The scrutinizer no longer uses 'fixnum as the type for fixnums
+    that might not fit into a fixnum on 32-bit architectures.
+
 
 4.12.0
 
diff --git a/lfa2.scm b/lfa2.scm
index 0fd4612..4c7ff84 100644
--- a/lfa2.scm
+++ b/lfa2.scm
@@ -173,17 +173,14 @@
       ;; a simplified variant of the one in scrutinizer.scm
       (cond ((string? lit) 'string)
 	    ((symbol? lit) 'symbol)
+	    ;; Do not assume fixnum width matches target platform's!
+	    ((or (big-fixnum? lit)
+		 (bignum? lit))
+	     'integer)
 	    ((fixnum? lit) 'fixnum)
-	    ((bignum? lit) 'bignum)
 	    ((flonum? lit) 'float)
 	    ((ratnum? lit) 'ratnum)
 	    ((cplxnum? lit) 'cplxnum)
-	    ((exact-integer? lit) 'integer)
-	    ((number? lit) 
-	     (case number-type 
-	       ((fixnum) 'fixnum)
-	       ((flonum) 'flonum)
-	       (else 'number)))
 	    ((boolean? lit) 'boolean)
 	    ((null? lit) 'null)
 	    ((list? lit) 'list)
diff --git a/scrutinizer.scm b/scrutinizer.scm
index cf7c6ad..2d63f19 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -196,16 +196,15 @@
     (define (constant-result lit)
       (cond ((string? lit) 'string)
 	    ((symbol? lit) 'symbol)
+	    ;; Do not assume fixnum width matches target platform's!
+	    ((or (big-fixnum? lit)
+		 (small-bignum? lit))
+	     'integer)
 	    ((fixnum? lit) 'fixnum)
-	    ((flonum? lit) 'float)	; Why not "flonum", for consistency?
 	    ((bignum? lit) 'bignum)
+	    ((flonum? lit) 'float)	; Why not "flonum", for consistency?
 	    ((ratnum? lit) 'ratnum)
 	    ((cplxnum? lit) 'cplxnum)
-	    ((number? lit) 
-	     (case number-type 
-	       ((fixnum) 'fixnum)
-	       ((flonum) 'flonum)
-	       (else 'number)))		; in case...
 	    ((boolean? lit)
 	     (if lit 'true 'false))
 	    ((null? lit) 'null)
diff --git a/support.scm b/support.scm
index 0048836..731c484 100644
--- a/support.scm
+++ b/support.scm
@@ -64,7 +64,7 @@
      clear-real-name-table! get-real-name set-real-name!
      real-name real-name2 display-real-name-table
      source-info->string source-info->line call-info constant-form-eval
-     dump-nodes read-info-hook read/source-info big-fixnum?
+     dump-nodes read-info-hook read/source-info big-fixnum? small-bignum?
      hide-variable export-variable variable-hidden? variable-visible?
      mark-variable variable-mark intrinsic? predicate? foldable?
      load-identifier-database
@@ -1596,6 +1596,11 @@
        (or (fx> x 1073741823)
 	   (fx< x -1073741824) ) ) )
 
+(define (small-bignum? x) ;; XXX: This should probably be in c-platform
+  (and (bignum? x)
+       (not (feature? #:64bit))
+       (fx<= (integer-length x) 62) ) )
+
 
 ;;; symbol visibility and other global variable properties
 
diff --git a/tests/typematch-tests.scm b/tests/typematch-tests.scm
index 26d36d8..565ea24 100644
--- a/tests/typematch-tests.scm
+++ b/tests/typematch-tests.scm
@@ -219,6 +219,7 @@
 (mx (forall (a) (procedure (#!rest a) a)) +)
 (mx (list fixnum) '(1))
 
+
 (mx port (open-input-string "foo"))
 (mx input-port (open-input-string "bar"))
 (mx port (open-output-string))
@@ -374,3 +375,23 @@
  (compiler-typecase 1
    (number #t)
    (fixnum #f)))
+
+;; Always a fixnum
+(assert
+ (compiler-typecase #x3fffffff
+   (bignum #f)
+   (fixnum #t)))
+
+;; Is a fixnum on 64-bit, bignum on 32-bit, thus type must be 'integer
+(assert
+ (compiler-typecase #x4fffffff
+   (fixnum #f)
+   (bignum #f)
+   (integer #t)))
+
+;; Always a bignum
+(assert
+ (compiler-typecase #x7fffffffffffffff
+   (fixnum #f)
+   (bignum #t)))
+
-- 
2.1.4