Fix real->flonum in cptypes

mats/cptypes.ms

@@ -1148,14 +1148,32 @@
     '(lambda (x) (when (bignum? x)
                    (real->flonum x)))
     '(lambda (x) (when (bignum? x)
+                   (#3%$real->flonum/slow x))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (when (or (bignum? x) (flonum? x))
+                   (real->flonum x)))
+    '(lambda (x) (when (or (bignum? x) (flonum? x))
                    (#3%$real->flonum 'real->flonum x))))
   (cptypes-equivalent-expansion?
-    '(lambda (x) (when (and (ineger? x) (exact? x))
+    '(lambda (x) (when (and (integer? x) (exact? x))
                    (real->flonum x)))
-    '(lambda (x) (when (and (ineger? x) (exact? x))
+    '(lambda (x) (when (and (integer? x) (exact? x))
                    (if (#2%fixnum? x) ;the specialization uses #2%fixnum?
                        (#3%fixnum->flonum x)
                        (#3%$real->flonum 'real->flonum x)))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (when (number? x)
+                   (#2%real->flonum x)))
+    '(lambda (x) (when (number? x)
+                   (if (#2%fixnum? x) ;the specialization uses #2%fixnum?
+                       (#3%fixnum->flonum x)
+                       (#2%$real->flonum 'real->flonum x)))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (when (real? x) (real->flonum x) 7))
+    '(lambda (x) (when (real? x) 7)))
+  (not (cptypes-equivalent-expansion?
+         '(lambda (x) (#2%real->flonum x) 7)
+         '(lambda (x) 7)))
   (cptypes-equivalent-expansion?
     '(lambda (x) (when (or (zero? x) (integer? x)) ; a subset of complex-rational? that is representable
                    (exact x)))

s/5_3.ss

@@ -1445,13 +1445,9 @@
   (set-who! inexact (lambda (z) (convert-to-inexact z who)))
   (set-who! exact->inexact (lambda (z) (convert-to-inexact z who))))
 
-(set! $real->flonum
-  (lambda (who z)
-    (type-case z
-      [(fixnum?) (fixnum->flonum z)]
-      [(bignum? ratnum?) (float z)]
-      [(flonum?) z]
-      [else (nonreal-error who z)])))
+(set! $real->flonum/slow
+  ; slow path for bignum or ratnum
+  (lambda (x) (float x)))
 
 (let ()
   (define convert-to-exact

s/cpprim.ss

@@ -742,6 +742,7 @@
                              (set! ,(%mref ,t ,offset) ,(car args))
                              ,(f (cdr args) (fx+ offset (constant ptr-bytes)))))))))))))
     (define build-$real->flonum
+      ; $real->flonum assumes the generated code will raise an error at runtime if x is not real
       (lambda (src sexpr who x)
         (if (known-flonum-result? x)
             x
@@ -5461,6 +5462,16 @@
                         ,(build-libcall #t src sexpr $real->flonum `(quote real->flonum) e-x)))))])
       (define-inline 3 $real->flonum
         [(who x) (build-$real->flonum src sexpr who x)])
+      (define-inline 2 $real->flonum
+        [(who x)
+         (nanopass-case (L7 Expr) who
+           [(quote ,d)
+            (guard (or (not d)
+                       (symbol? d)
+                       (string? d)))
+            ; assume the generated code will raise an error at runtime if x is not real
+            (build-$real->flonum src sexpr who x)]
+           [else #f])])
     )
     (define-inline 2 $record
       [(tag . args) (build-$record tag args)])

s/cptypes-lattice.ss

@@ -72,6 +72,7 @@
    zero-pred
    flzero-pred
    flinteger-pred
+   bignum-or-ratnum-pred
    exact-real-pred
    exact-pred
    inexact-pred
@@ -1511,6 +1512,7 @@
   (define integer-pred (predicate-union flinteger-pred exact-integer-pred))
   (define exact-pred (predicate-union exact*-pred exact-integer-pred))
   (define exact-real-pred (predicate-union ratnum-pred exact-integer-pred))
+  (define bignum-or-ratnum-pred (predicate-union bignum-pred ratnum-pred))
   (define inexact-pred (predicate-union inexact*-pred flzero-pred))
   (define real-pred (predicate-union (predicate-union real*-pred flzero-pred)
                                      exact-integer-pred))

s/cptypes.ss

@@ -159,8 +159,10 @@ Notes:
                        (st? e3 fuel))]
                  [(call ,preinfo ,pr ,e* ...)
                   (let ([flags (primref-flags pr)])
-                    (or (all-set? (prim-mask unsafe) flags)
-                        (all-set? (prim-mask unrestricted) flags)))]
+                    (and (if (all-set? (prim-mask unsafe) flags)
+                             (all-set? (prim-mask discard) flags)
+                             (all-set? (prim-mask (or discard unrestricted)) flags))
+                         (arity-okay? (primref-arity pr) (length e*))))]
                  [(call ,preinfo1 (case-lambda ,preinfo2 (clause (,x* ...) ,interface ,body)) ,e*  ...) ; let-like expressions
                   (guard (fx= interface (length e*)))
                   (st? body fuel)]
@@ -1630,14 +1632,15 @@ Notes:
                  [(predicate-implies? r fixnum-pred)
                   (fold-call/primref/shallow preinfo (lookup-primref 3 'fixnum->flonum) (list n) ret (list r) ctxt ntypes oldtypes plxc)]
                  [(predicate-disjoint? r fixnum-pred)
+                  ; $real->flonum does not inline the test for fixnums 
                   (fold-call/primref/shallow preinfo (lookup-primref 3 '$real->flonum) (list `(quote ,'real->flonum) n) ret (list `(quote ,'real->flonum) r) ctxt ntypes oldtypes plxc)]
                  [else
                   (values (build-let1 ctxt n r
                             (lambda (n)
                               (let-values ([(irfx retfx ntfx ttfx ftfx)
                                             (fold-call/primref/shallow (make-preinfo-call) (lookup-primref 3 'fixnum->flonum) (list n) ret (list (predicate-intersect r fixnum-pred)) ctxt ntypes oldtypes plxc)]
                                            [(irot retot ntot ttot ftot)
-                                            (fold-call/primref/shallow preinfo (lookup-primref 3 '$real->flonum) (list `(quote ,'real->flonum) n) ret (list `(quote ,'real->flonum) (predicate-substract r fixnum-pred)) ctxt ntypes oldtypes plxc)])
+                                            (fold-call/primref/shallow preinfo (lookup-primref level '$real->flonum) (list `(quote ,'real->flonum) n) ret (list `(quote ,'real->flonum) (predicate-substract r fixnum-pred)) ctxt ntypes oldtypes plxc)])
                                 `(if (call ,(make-preinfo-call) ,(lookup-primref 2 'fixnum?) ,n)
                                      ,irfx
                                      ,irot))))
@@ -1650,6 +1653,8 @@ Notes:
                    (let ([pr (cond
                                [(predicate-implies? rn fixnum-pred)
                                 (lookup-primref 3 'fixnum->flonum)]
+                               [(predicate-implies? rn bignum-or-ratnum-pred)
+                                (lookup-primref 3 '$real->flonum/slow)]
                                [(predicate-implies? rn flonum-pred)
                                 (lookup-primref 3 'fl+)]
                                [else #f])])

s/library.ss

@@ -439,7 +439,7 @@
   (define-library-entry ($real->flonum who x)
     (cond
       [(fixnum? x) (fixnum->flonum x)]
-      [(or (bignum? x) (ratnum? x)) (#2%$real->flonum who x)]
+      [(or (bignum? x) (ratnum? x)) ($real->flonum/slow x)]
       [else (real-oops who x)]))
 )
 

s/primdata.ss

@@ -2387,7 +2387,8 @@
   ($raw-terminated-cond [feature pthreads] [flags single-valued])
   ($read-performance-monitoring-counter [flags single-valued])
   ($read-time-stamp-counter [flags single-valued])
-  ($real->flonum [sig [(maybe-who real) -> (flonum)]] [flags single-valued arith-op mifoldable discard cptypes2])
+  ($real->flonum [sig [(maybe-who real) -> (flonum)]] [flags single-valued arith-op mifoldable discard safeongoodargs cptypes2])
+  ($real->flonum/slow [sig [(real) -> (flonum)]] [flags single-valued arith-op mifoldable discard safeongoodargs]) ; slow path for bignum or ratnum
   ($real-sym-name [flags single-valued])
   ($recompile-condition? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable])
   ($recompile-importer-path [flags single-valued])

s/prims.ss

@@ -2451,6 +2451,8 @@
 (define ($real->flonum who x)
   (unless (or (not who) (symbol? who) (string? who))
     ($oops '$real->flonum "invalid who argument ~s" who))
+  (unless (real? x)
+    ($oops '$real->flonum "~s is not a real number" x))
   (#3%$real->flonum who x))
 
 (define (real->flonum x) (#2%real->flonum x))