Type inference distinguishes &fixnum and &bignum types

This will allow heap-object? / inum? predicates to do something useful.

* module/language/cps/types.scm (&fixnum, &bignum): Split &exact-integer
  into these types.  Keep &exact-integer as a union type.
  (type<=?): New helper.
  (constant-type): Return &fixnum or &bignum as appropriate.
  (define-exact-integer!): New helper, tries to make exact integer
  results be &fixnum if they are within range.  Adapt users.
  (restricted-comparison-ranges, define-binary-result!): Use type<=?
  instead of = for &exact-integer.
* module/language/cps/type-fold.scm (logtest, mul, logbit?): Use
  type<=?.
* module/language/cps/specialize-numbers.scm (inferred-sigbits):
  (specialize-operations): Use type<=?.

module/language/cps/specialize-numbers.scm

@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2015, 2016 Free Software Foundation, Inc.
+;; Copyright (C) 2015, 2016, 2017 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -186,7 +186,7 @@
 (define (inferred-sigbits types label var)
   (call-with-values (lambda () (lookup-pre-type types label var))
     (lambda (type min max)
-      (and (or (eqv? type &exact-integer) (eqv? type &u64))
+      (and (type<=? type (logior &exact-integer &u64 &s64))
            (range->sigbits min max)))))
 
 (define significant-bits-handlers (make-hash-table))
@@ -284,7 +284,7 @@ BITS indicating the significant bits needed for a variable.  BITS may be
       (call-with-values (lambda ()
                           (lookup-pre-type types label var))
         (lambda (type min max)
-          (and (eqv? type &type) (<= &min min max &max)))))
+          (and (type<=? type &type) (<= &min min max &max)))))
     (define (u64-operand? var)
       (operand-in-range? var &exact-integer 0 #xffffffffffffffff))
     (define (all-u64-bits-set? var)
@@ -300,7 +300,7 @@ BITS indicating the significant bits needed for a variable.  BITS may be
               (lambda ()
                 (lookup-post-type types label result 0))
             (lambda (type min max)
-              (and (eqv? type &exact-integer)
+              (and (type<=? type &exact-integer)
                    (<= 0 min max #xffffffffffffffff))))))
     (define (f64-operands? vara varb)
       (let-values (((typea mina maxa) (lookup-pre-type types label vara))
@@ -326,7 +326,7 @@ BITS indicating the significant bits needed for a variable.  BITS may be
                  (with-cps cps
                    (let$ body (specialize-f64-binop k src op a b))
                    (setk label ($kargs names vars ,body))))
-                ((and (eqv? type &exact-integer)
+                ((and (type<=? type &exact-integer)
                       (or (<= 0 min max #xffffffffffffffff)
                           (only-u64-bits-used? result))
                       (u64-operand? a) (u64-operand? b)
@@ -349,7 +349,7 @@ BITS indicating the significant bits needed for a variable.  BITS may be
                (cond
                 ((or (not (u64-result? result))
                      (not (u64-operand? a))
-                     (not (eqv? b-type &exact-integer))
+                     (not (type<=? b-type &exact-integer))
                      (< b-min 0 b-max)
                      (<= b-min -64)
                      (<= 64 b-max))

module/language/cps/type-fold.scm

@@ -1,5 +1,5 @@
 ;;; Abstract constant folding on CPS
-;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc.
+;;; Copyright (C) 2014, 2015, 2017 Free Software Foundation, Inc.
 ;;;
 ;;; This library is free software: you can redistribute it and/or modify
 ;;; it under the terms of the GNU Lesser General Public License as
@@ -41,7 +41,7 @@
 ;; Branch folders.
 
 (define &scalar-types
-  (logior &exact-integer &flonum &char &unspecified &false &true &nil &null))
+  (logior &fixnum &bignum &flonum &char &unspecified &false &true &nil &null))
 
 (define *branch-folders* (make-hash-table))
 
@@ -157,7 +157,8 @@
     (if (< a b 0)
         0
         (max a b)))
-  (if (and (= min0 max0) (= min1 max1) (eqv? type0 type1 &exact-integer))
+  (if (and (= min0 max0) (= min1 max1)
+           (type<=? (logior type0 type1) &exact-integer))
       (values #t (logtest min0 min1))
       (values #f #f)))
 
@@ -212,16 +213,16 @@
              (build-term ($continue k src ($primcall 'ash (arg bits)))))))))
   (define (mul/constant constant constant-type arg arg-type)
     (cond
-     ((not (or (= constant-type &exact-integer) (= constant-type arg-type)))
+     ((not (or (type<=? constant-type &exact-integer)
+               (= constant-type arg-type)))
       (fail))
      ((eqv? constant -1)
       ;; (* arg -1) -> (- 0 arg)
       (negate arg))
      ((eqv? constant 0)
-      ;; (* arg 0) -> 0 if arg is not a flonum or complex
+      ;; (* arg 0) -> 0 if arg is exact
-      (and (= constant-type &exact-integer)
+      (and (type<=? constant-type &exact-integer)
-           (zero? (logand arg-type
+           (type<=? arg-type (logior &exact-integer &fraction))
-                          (lognot (logior &flonum &complex))))
            (zero)))
      ((eqv? constant 1)
       ;; (* arg 1) -> arg
@@ -229,7 +230,7 @@
      ((eqv? constant 2)
       ;; (* arg 2) -> (+ arg arg)
       (double arg))
-     ((and (= constant-type arg-type &exact-integer)
+     ((and (type<=? (logior constant-type arg-type) &exact-integer)
            (positive? constant)
            (zero? (logand constant (1- constant))))
       ;; (* arg power-of-2) -> (ash arg (log2 power-of-2
@@ -268,7 +269,7 @@
   ;; Hairiness because we are converting from a primcall with unknown
   ;; arity to a branching primcall.
   (let ((positive-fixnum-bits (- (* (target-word-size) 8) 3)))
-    (if (and (= type0 &exact-integer)
+    (if (and (type<=? type0 &exact-integer)
              (<= 0 min0 positive-fixnum-bits)
              (<= 0 max0 positive-fixnum-bits))
         (match (intmap-ref cps k)
@@ -304,7 +305,8 @@
 (define (local-type-fold start end cps)
   (define (scalar-value type val)
     (cond
-     ((eqv? type &exact-integer) val)
+     ((eqv? type &fixnum) val)
+     ((eqv? type &bignum) val)
      ((eqv? type &flonum) (exact->inexact val))
      ((eqv? type &char) (integer->char val))
      ((eqv? type &unspecified) *unspecified*)

module/language/cps/types.scm

@@ -1,5 +1,5 @@
 ;;; Type analysis on CPS
-;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc.
+;;; Copyright (C) 2014, 2015, 2017 Free Software Foundation, Inc.
 ;;;
 ;;; This library is free software: you can redistribute it and/or modify
 ;;; it under the terms of the GNU Lesser General Public License as
@@ -86,7 +86,8 @@
   #:use-module (srfi srfi-11)
   #:use-module ((system syntax internal) #:select (syntax?))
   #:export (;; Specific types.
-            &exact-integer
+            &fixnum
+            &bignum
             &flonum
             &complex
             &fraction
@@ -116,13 +117,17 @@
             &syntax
 
             ;; Union types.
-            &number &real
+            &exact-integer &number &real
 
             ;; Untagged types.
             &f64
             &u64
             &s64
 
+            ;; Helper.
+            type<=?
+
+            ;; Interface for type inference.
             infer-types
             lookup-pre-type
             lookup-post-type
@@ -143,7 +148,8 @@
 
 ;; More precise types have fewer bits.
 (define-flags &all-types &type-bits
-  &exact-integer
+  &fixnum
+  &bignum
   &flonum
   &complex
   &fraction
@@ -178,10 +184,15 @@
 
 (define-syntax &no-type (identifier-syntax 0))
 
+(define-syntax &exact-integer
+  (identifier-syntax (logior &fixnum &bignum)))
 (define-syntax &number
-  (identifier-syntax (logior &exact-integer &flonum &complex &fraction)))
+  (identifier-syntax (logior &fixnum &bignum &flonum &complex &fraction)))
 (define-syntax &real
-  (identifier-syntax (logior &exact-integer &flonum &fraction)))
+  (identifier-syntax (logior &fixnum &bignum &flonum &fraction)))
+
+(define-syntax-rule (type<=? x type)
+  (zero? (logand x (lognot type))))
 
 ;; Versions of min and max that do not coerce exact numbers to become
 ;; inexact.
@@ -326,7 +337,11 @@ minimum, and maximum."
   (cond
    ((number? val)
     (cond
-     ((exact-integer? val) (return &exact-integer val))
+     ((exact-integer? val)
+      (return (if (<= most-negative-fixnum val most-positive-fixnum)
+                  &fixnum
+                  &bignum)
+              val))
      ((eqv? (imag-part val) 0)
       (if (nan? val)
           (make-type-entry &flonum -inf.0 +inf.0)
@@ -369,6 +384,14 @@ minimum, and maximum."
 (define-type-helper &min)
 (define-type-helper &max)
 
+(define-syntax-rule (define-exact-integer! result min max)
+  (let ((min* min) (max* max))
+    (define! result
+      (if (<= most-negative-fixnum min* max* most-positive-fixnum)
+          &fixnum
+          &exact-integer)
+      min* max*)))
+
 ;; Accessors to use in type inferrers where you know that the values
 ;; must be in some range for the computation to proceed (not throw an
 ;; error).  Note that these accessors should be used even for &u64 and
@@ -761,7 +784,7 @@ minimum, and maximum."
 (define-type-checker (u64->scm u64)
   #t)
 (define-type-inferrer (u64->scm u64 result)
-  (define! result &exact-integer (&min/0 u64) (&max/u64 u64)))
+  (define-exact-integer! result (&min/0 u64) (&max/u64 u64)))
 
 (define-type-checker (scm->s64 scm)
   (check-type scm &exact-integer &s64-min &s64-max))
@@ -773,7 +796,7 @@ minimum, and maximum."
 (define-type-checker (s64->scm s64)
   #t)
 (define-type-inferrer (s64->scm s64 result)
-  (define! result &exact-integer (&min/s64 s64) (&max/s64 s64)))
+  (define-exact-integer! result (&min/s64 s64) (&max/s64 s64)))
 
 
 
@@ -851,7 +874,7 @@ minimum, and maximum."
     (match op
       ((or '< '<=) (values min0 (min max0 max1) (max min0 min1) max1))
       ((or '> '>=) (values (max min0 min1) max0 min1 (min max0 max1)))))
-  (if (= (logior type0 type1) &exact-integer)
+  (if (type<=? (logior type0 type1) &exact-integer)
       (infer-integer-ranges)
       (infer-real-ranges)))
 
@@ -982,8 +1005,8 @@ minimum, and maximum."
                                  (logior &complex &flonum))))
         (define! result result-type min* max*)))
      ;; Exact integers are closed under some operations.
-     ((and closed? (eqv? a-type &exact-integer) (eqv? b-type &exact-integer))
+     ((and closed? (type<=? (logior a-type b-type) &exact-integer))
-      (define! result &exact-integer min* max*))
+      (define-exact-integer! result min* max*))
      (else
       (let* ((type (logior a-type b-type))
              ;; Fractions may become integers.
@@ -1150,11 +1173,11 @@ minimum, and maximum."
   (let ((max-abs-rem (1- (max (abs (&min b)) (abs (&max b))))))
     (cond
      ((< (&min a) 0)
-      (if (< 0 (&max a))
+      (define-exact-integer! result
-          (define! result &exact-integer (- max-abs-rem) max-abs-rem)
+        (- max-abs-rem)
-          (define! result &exact-integer (- max-abs-rem) 0)))
+        (if (< 0 (&max a)) max-abs-rem 0)))
      (else
-      (define! result &exact-integer 0 max-abs-rem)))))
+      (define-exact-integer! result 0 max-abs-rem)))))
 
 (define-type-checker-aliases quo mod)
 (define-type-inferrer (mod a b result)
@@ -1164,11 +1187,11 @@ minimum, and maximum."
   (let ((max-abs-mod (1- (max (abs (&min b)) (abs (&max b))))))
     (cond
      ((< (&min b) 0)
-      (if (< 0 (&max b))
+      (define-exact-integer! result
-          (define! result &exact-integer (- max-abs-mod) max-abs-mod)
+        (- max-abs-mod)
-          (define! result &exact-integer (- max-abs-mod) 0)))
+        (if (< 0 (&max b)) max-abs-mod 0)))
      (else
-      (define! result &exact-integer 0 max-abs-mod)))))
+      (define-exact-integer! result 0 max-abs-mod)))))
 
 ;; Predicates.
 (define-syntax-rule (define-number-kind-predicate-inferrer name type)
@@ -1246,7 +1269,7 @@ minimum, and maximum."
         (-+ (ash* (&min val) (&max count)))
         (++ (ash* (&max val) (&max count)))
         (+- (ash* (&max val) (&min count))))
-    (define! result &exact-integer
+    (define-exact-integer! result
       (min -- -+ ++ +-)
       (max -- -+ ++ +-))))
 
@@ -1291,7 +1314,7 @@ minimum, and maximum."
         0))
   (restrict! a &exact-integer -inf.0 +inf.0)
   (restrict! b &exact-integer -inf.0 +inf.0)
-  (define! result &exact-integer
+  (define-exact-integer! result
     (logand-min (&min a) (&min b))
     (logand-max (&max a) (&max b))))
 
@@ -1324,7 +1347,7 @@ minimum, and maximum."
   (call-with-values (lambda ()
                       (logsub-bounds (&min a) (&max a) (&min b) (&max b)))
     (lambda (min max)
-      (define! result &exact-integer min max))))
+      (define-exact-integer! result min max))))
 
 (define-simple-type-checker (ulogsub &u64 &u64))
 (define-type-inferrer (ulogsub a b result)
@@ -1349,7 +1372,7 @@ minimum, and maximum."
      (else (saturate (logior a b)))))
   (restrict! a &exact-integer -inf.0 +inf.0)
   (restrict! b &exact-integer -inf.0 +inf.0)
-  (define! result &exact-integer
+  (define-exact-integer! result
     (logior-min (&min a) (&min b))
     (logior-max (&max a) (&max b))))
 
@@ -1373,7 +1396,7 @@ minimum, and maximum."
 (define-simple-type-checker (lognot &exact-integer))
 (define-type-inferrer (lognot a result)
   (restrict! a &exact-integer -inf.0 +inf.0)
-  (define! result &exact-integer
+  (define-exact-integer! result
     (- -1 (&max a))
     (- -1 (&min a))))