From bef0573a24250567c97a36352d2ded4d3c6680c1 Mon Sep 17 00:00:00 2001 From: Gustavo Massaccesi Date: Sat, 21 Feb 2026 22:38:18 -0300 Subject: [PATCH 1/5] Fix real->flonum in cptypes The expansion used `#3%$real->flonum` that is marked as `discard` in primdata, so it was incorrectly deleted in contexts where the result was ignored. --- mats/cptypes.ms | 10 ++++++++-- s/5_3.ss | 2 +- s/cpprim.ss | 2 +- s/cptypes.ss | 4 ++-- s/library.ss | 2 +- s/primdata.ss | 3 ++- 6 files changed, 15 insertions(+), 8 deletions(-) diff --git a/mats/cptypes.ms b/mats/cptypes.ms index 61366a05f..fb6048d6b 100644 --- a/mats/cptypes.ms +++ b/mats/cptypes.ms @@ -1150,12 +1150,18 @@ '(lambda (x) (when (bignum? 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 (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..c3b3bc0f5 100644 --- a/s/5_3.ss +++ b/s/5_3.ss @@ -1445,7 +1445,7 @@ (set-who! inexact (lambda (z) (convert-to-inexact z who))) (set-who! exact->inexact (lambda (z) (convert-to-inexact z who)))) -(set! $real->flonum +(set! $real->flonum* (lambda (who z) (type-case z [(fixnum?) (fixnum->flonum z)] diff --git a/s/cpprim.ss b/s/cpprim.ss index 01a0e2260..ce0f36153 100644 --- a/s/cpprim.ss +++ b/s/cpprim.ss @@ -5459,7 +5459,7 @@ (if ,(%type-check mask-flonum type-flonum ,e-x) ,e-x ,(build-libcall #t src sexpr $real->flonum `(quote real->flonum) e-x)))))]) - (define-inline 3 $real->flonum + (define-inline 2 $real->flonum [(who x) (build-$real->flonum src sexpr who x)]) ) (define-inline 2 $record diff --git a/s/cptypes.ss b/s/cptypes.ss index 6b621bc28..2574b339d 100644 --- a/s/cptypes.ss +++ b/s/cptypes.ss @@ -1637,13 +1637,13 @@ 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)))) ret ntypes #f #f)]))]) - (define-specialize 2 $real->flonum + (define-specialize 2 ($real->flonum $real->flonum*) [(w n) (let ([rw (get-type w)] [rn (get-type n)]) (when (predicate-implies? rw maybe-symbol-pred) diff --git a/s/library.ss b/s/library.ss index 5d949e6d5..6f6e870a1 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* who x)] [else (real-oops who x)])) ) diff --git a/s/primdata.ss b/s/primdata.ss index 8aeaac26d..e62180b1e 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* [sig [(maybe-who real) -> (flonum)]] [flags single-valued arith-op mifoldable discard safeongoodargs cptypes2]) ($real-sym-name [flags single-valued]) ($recompile-condition? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable]) ($recompile-importer-path [flags single-valued]) From e9f384b54a8b9b4aded5eea192f310fe99c2624b Mon Sep 17 00:00:00 2001 From: Gustavo Massaccesi Date: Fri, 6 Mar 2026 09:43:52 -0300 Subject: [PATCH 2/5] $other-real->fonum --- mats/cptypes.ms | 12 ++++++++++++ s/5_3.ss | 10 +++------- s/cp0.ss | 1 + s/cpprim.ss | 11 ++++++++++- s/cptypes-lattice.ss | 2 ++ s/cptypes.ss | 5 ++++- s/library.ss | 2 +- s/primdata.ss | 2 +- s/prims.ss | 1 + 9 files changed, 35 insertions(+), 11 deletions(-) diff --git a/mats/cptypes.ms b/mats/cptypes.ms index fb6048d6b..f757161f7 100644 --- a/mats/cptypes.ms +++ b/mats/cptypes.ms @@ -1148,6 +1148,11 @@ '(lambda (x) (when (bignum? x) (real->flonum x))) '(lambda (x) (when (bignum? x) + (#3%$other-real->flonum 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 (integer? x) (exact? x)) @@ -1156,6 +1161,13 @@ (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))) diff --git a/s/5_3.ss b/s/5_3.ss index c3b3bc0f5..5e8cecca9 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! $other-real->flonum + ; assume x is a bignum or ratnum + (lambda (x) (float x))) (let () (define convert-to-exact diff --git a/s/cp0.ss b/s/cp0.ss index a52ee3bba..8de287ba4 100644 --- a/s/cp0.ss +++ b/s/cp0.ss @@ -3233,6 +3233,7 @@ (fold (fixnum->flonum fixnum?) flonum? #2%inexact) (fold (flonum->fixnum flonum?) target-fixnum? (lambda (x) (#2%truncate (#2%exact x)))) + (fold ($other-real->flonum (lambda (x) (or (target-bignum? x) (ratnum? x)))) flonum? #2%inexact) (fold (fxzero? tfixnum?) boolean? zero?) (fold (fxnegative? tfixnum?) boolean? negative?) diff --git a/s/cpprim.ss b/s/cpprim.ss index ce0f36153..ea369736d 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 @@ -5459,8 +5460,16 @@ (if ,(%type-check mask-flonum type-flonum ,e-x) ,e-x ,(build-libcall #t src sexpr $real->flonum `(quote real->flonum) e-x)))))]) - (define-inline 2 $real->flonum + (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 (symbol? 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 2574b339d..c8fb9c03c 100644 --- a/s/cptypes.ss +++ b/s/cptypes.ss @@ -1630,6 +1630,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 @@ -1643,13 +1644,15 @@ Notes: ,irot)))) ret ntypes #f #f)]))]) - (define-specialize 2 ($real->flonum $real->flonum*) + (define-specialize 2 $real->flonum [(w n) (let ([rw (get-type w)] [rn (get-type n)]) (when (predicate-implies? rw maybe-symbol-pred) (let ([pr (cond [(predicate-implies? rn fixnum-pred) (lookup-primref 3 'fixnum->flonum)] + [(predicate-implies? rn bignum-or-ratnum-pred) + (lookup-primref 3 '$other-real->flonum)] [(predicate-implies? rn flonum-pred) (lookup-primref 3 'fl+)] [else #f])]) diff --git a/s/library.ss b/s/library.ss index 6f6e870a1..5030e1098 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)) ($real->flonum* who x)] + [(or (bignum? x) (ratnum? x)) ($other-real->flonum x)] [else (real-oops who x)])) ) diff --git a/s/primdata.ss b/s/primdata.ss index e62180b1e..06c62da22 100644 --- a/s/primdata.ss +++ b/s/primdata.ss @@ -2388,7 +2388,7 @@ ($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 safeongoodargs cptypes2]) - ($real->flonum* [sig [(maybe-who real) -> (flonum)]] [flags single-valued arith-op mifoldable discard safeongoodargs cptypes2]) + ($other-real->flonum [sig [(sub-real) -> (flonum)]] [flags single-valued arith-op cp02 discard]) ; no #2% version, the argument shlould be 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..9584f7e25 100644 --- a/s/prims.ss +++ b/s/prims.ss @@ -2451,6 +2451,7 @@ (define ($real->flonum who x) (unless (or (not who) (symbol? who) (string? who)) ($oops '$real->flonum "invalid who argument ~s" who)) + ; !!! (#3%$real->flonum who x)) (define (real->flonum x) (#2%real->flonum x)) From 718715c915453da3bc0c66be0d8cc14353dc5743 Mon Sep 17 00:00:00 2001 From: Gustavo Massaccesi Date: Mon, 9 Mar 2026 15:39:38 -0300 Subject: [PATCH 3/5] rename $other-real->flonum to $real->flonum/slow --- mats/cptypes.ms | 2 +- s/5_3.ss | 4 ++-- s/cp0.ss | 1 - s/cptypes.ss | 2 +- s/library.ss | 2 +- s/primdata.ss | 2 +- 6 files changed, 6 insertions(+), 7 deletions(-) diff --git a/mats/cptypes.ms b/mats/cptypes.ms index f757161f7..bd619b907 100644 --- a/mats/cptypes.ms +++ b/mats/cptypes.ms @@ -1148,7 +1148,7 @@ '(lambda (x) (when (bignum? x) (real->flonum x))) '(lambda (x) (when (bignum? x) - (#3%$other-real->flonum x)))) + (#3%$real->flonum/slow x)))) (cptypes-equivalent-expansion? '(lambda (x) (when (or (bignum? x) (flonum? x)) (real->flonum x))) diff --git a/s/5_3.ss b/s/5_3.ss index 5e8cecca9..28f6a8ae5 100644 --- a/s/5_3.ss +++ b/s/5_3.ss @@ -1445,8 +1445,8 @@ (set-who! inexact (lambda (z) (convert-to-inexact z who))) (set-who! exact->inexact (lambda (z) (convert-to-inexact z who)))) -(set! $other-real->flonum - ; assume x is a bignum or ratnum +(set! $real->flonum/slow + ; slow path for bignum or ratnum (lambda (x) (float x))) (let () diff --git a/s/cp0.ss b/s/cp0.ss index 8de287ba4..a52ee3bba 100644 --- a/s/cp0.ss +++ b/s/cp0.ss @@ -3233,7 +3233,6 @@ (fold (fixnum->flonum fixnum?) flonum? #2%inexact) (fold (flonum->fixnum flonum?) target-fixnum? (lambda (x) (#2%truncate (#2%exact x)))) - (fold ($other-real->flonum (lambda (x) (or (target-bignum? x) (ratnum? x)))) flonum? #2%inexact) (fold (fxzero? tfixnum?) boolean? zero?) (fold (fxnegative? tfixnum?) boolean? negative?) diff --git a/s/cptypes.ss b/s/cptypes.ss index c8fb9c03c..f39810486 100644 --- a/s/cptypes.ss +++ b/s/cptypes.ss @@ -1652,7 +1652,7 @@ Notes: [(predicate-implies? rn fixnum-pred) (lookup-primref 3 'fixnum->flonum)] [(predicate-implies? rn bignum-or-ratnum-pred) - (lookup-primref 3 '$other-real->flonum)] + (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 5030e1098..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)) ($other-real->flonum 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 06c62da22..19f0bd314 100644 --- a/s/primdata.ss +++ b/s/primdata.ss @@ -2388,7 +2388,7 @@ ($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 safeongoodargs cptypes2]) - ($other-real->flonum [sig [(sub-real) -> (flonum)]] [flags single-valued arith-op cp02 discard]) ; no #2% version, the argument shlould be bignum-or-ratnum + ($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]) From 22d356112bd75afce2ecef299b9e658447ee7b50 Mon Sep 17 00:00:00 2001 From: Gustavo Massaccesi Date: Sat, 14 Mar 2026 10:53:57 -0300 Subject: [PATCH 4/5] fix details --- s/cpprim.ss | 4 +++- s/prims.ss | 3 ++- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/s/cpprim.ss b/s/cpprim.ss index ea369736d..d1a77c730 100644 --- a/s/cpprim.ss +++ b/s/cpprim.ss @@ -5466,7 +5466,9 @@ [(who x) (nanopass-case (L7 Expr) who [(quote ,d) - (guard (symbol? 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])]) diff --git a/s/prims.ss b/s/prims.ss index 9584f7e25..cb7dc66ea 100644 --- a/s/prims.ss +++ b/s/prims.ss @@ -2451,7 +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)) From 5fad257dc4f4f0db288b0361394a2655915e66ec Mon Sep 17 00:00:00 2001 From: Gustavo Massaccesi Date: Sat, 14 Mar 2026 11:02:49 -0300 Subject: [PATCH 5/5] minor fix --- s/cptypes.ss | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/s/cptypes.ss b/s/cptypes.ss index f39810486..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)]