diff --git a/mats/cptypes.ms b/mats/cptypes.ms index 61366a05f..bd619b907 100644 --- a/mats/cptypes.ms +++ b/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))) diff --git a/s/5_3.ss b/s/5_3.ss index c34cce933..28f6a8ae5 100644 --- a/s/5_3.ss +++ b/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 diff --git a/s/cpprim.ss b/s/cpprim.ss index 01a0e2260..d1a77c730 100644 --- a/s/cpprim.ss +++ b/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)]) diff --git a/s/cptypes-lattice.ss b/s/cptypes-lattice.ss index befaf7e31..9a33fd43e 100644 --- a/s/cptypes-lattice.ss +++ b/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)) diff --git a/s/cptypes.ss b/s/cptypes.ss index 6b621bc28..38673d483 100644 --- a/s/cptypes.ss +++ b/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,6 +1632,7 @@ 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 @@ -1637,7 +1640,7 @@ Notes: (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])]) diff --git a/s/library.ss b/s/library.ss index 5d949e6d5..feee60228 100644 --- a/s/library.ss +++ b/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)])) ) diff --git a/s/primdata.ss b/s/primdata.ss index 8aeaac26d..19f0bd314 100644 --- a/s/primdata.ss +++ b/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]) diff --git a/s/prims.ss b/s/prims.ss index 7ed755d49..cb7dc66ea 100644 --- a/s/prims.ss +++ b/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))