From 6b2c73b801f19d0ea9c52196a66970d8b644f3b6 Mon Sep 17 00:00:00 2001 From: Gustavo Massaccesi Date: Wed, 13 Nov 2024 17:37:25 -0300 Subject: [PATCH] Add 1+, 1- and -1+ to cptypes This extends the reductions for add1 and sub1 to the other variants. --- mats/cptypes.ms | 83 ++++++++++---------------------- release_notes/release_notes.stex | 4 ++ s/cptypes.ss | 7 +-- s/primdata.ss | 6 +-- 4 files changed, 37 insertions(+), 63 deletions(-) diff --git a/mats/cptypes.ms b/mats/cptypes.ms index 2ac5d6a82..b7d09b03d 100644 --- a/mats/cptypes.ms +++ b/mats/cptypes.ms @@ -846,6 +846,19 @@ '(lambda (x f) (list->vector x) (f) #t))) ) +(define (test-closed1 f* p?*) + (let loop ([f* f*]) + (or (null? f*) + (let ([f (car f*)]) + (and (let loop ([p?* p?*]) + (or (null? p?*) + (let ([p? (car p?*)]) + (and (cptypes-equivalent-expansion? + `(lambda (x) (when (,p? x) (,p? (,f x)))) + `(lambda (x) (when (,p? x) (,f x) #t))) + (loop (cdr p?*)))))) + (loop (cdr f*))))))) + (mat cptypes-unsafe (cptypes-equivalent-expansion? '(lambda (x) (when (pair? x) (car x))) @@ -880,97 +893,53 @@ (not (cptypes-equivalent-expansion? '(lambda (x) (#2%exact? x)) '(lambda (x) (#3%exact? x)))) - (cptypes-equivalent-expansion? - '(lambda (x) (when (fixnum? x) - (let ([y (add1 x)]) - (and (integer? y) (exact? y))))) - '(lambda (x) (when (fixnum? x) - (let ([y (add1 x)]) - #t)))) (not (cptypes-equivalent-expansion? '(lambda (x) (when (fixnum? x) (fixnum? (add1 x)))) '(lambda (x) (when (fixnum? x) #t)))) - (not (cptypes-equivalent-expansion? - '(lambda (x) (when (bignum? x) - (bignum? (add1 x)))) - '(lambda (x) (when (bignum? x) - #t)))) - (cptypes-equivalent-expansion? - '(lambda (x) (when (real? x) - (real? (add1 x)))) - '(lambda (x) (when (real? x) - #t))) (cptypes-equivalent-expansion? '(lambda (x) (when (flonum? x) - (flonum? (add1 x)))) + (add1 x))) '(lambda (x) (when (flonum? x) - #t))) + (#3%fl+ x 1.0)))) (cptypes-equivalent-expansion? '(lambda (x) (when (flonum? x) - (add1 x))) + (1+ x))) '(lambda (x) (when (flonum? x) (#3%fl+ x 1.0)))) - (cptypes-equivalent-expansion? - '(lambda (x) (when (fixnum? x) - (let ([y (sub1 x)]) - (and (integer? y) (exact? y))))) - '(lambda (x) (when (fixnum? x) - (let ([y (sub1 x)]) - #t)))) (not (cptypes-equivalent-expansion? '(lambda (x) (when (fixnum? x) (fixnum? (sub1 x)))) '(lambda (x) (when (fixnum? x) #t)))) - (not (cptypes-equivalent-expansion? - '(lambda (x) (when (bignum? x) - (bignum? (sub1 x)))) - '(lambda (x) (when (bignum? x) - #t)))) - (cptypes-equivalent-expansion? - '(lambda (x) (when (real? x) - (real? (sub1 x)))) - '(lambda (x) (when (real? x) - #t))) (cptypes-equivalent-expansion? '(lambda (x) (when (flonum? x) - (flonum? (sub1 x)))) + (sub1 x))) '(lambda (x) (when (flonum? x) - #t))) + (#3%fl- x 1.0)))) (cptypes-equivalent-expansion? '(lambda (x) (when (flonum? x) - (sub1 x))) + (1- x))) '(lambda (x) (when (flonum? x) (#3%fl- x 1.0)))) (cptypes-equivalent-expansion? - '(lambda (x) (when (fixnum? x) - (let ([y (abs x)]) - (and (integer? y) (exact? y))))) - '(lambda (x) (when (fixnum? x) - (let ([y (abs x)]) - #t)))) + '(lambda (x) (when (flonum? x) + (-1+ x))) + '(lambda (x) (when (flonum? x) + (#3%fl- x 1.0)))) (not (cptypes-equivalent-expansion? '(lambda (x) (when (fixnum? x) (fixnum? (abs x)))) '(lambda (x) (when (fixnum? x) #t)))) - (cptypes-equivalent-expansion? + (cptypes-equivalent-expansion? ; unexpected, but correct '(lambda (x) (when (bignum? x) (bignum? (abs x)))) '(lambda (x) (when (bignum? x) #t))) - (cptypes-equivalent-expansion? - '(lambda (x) (when (real? x) - (real? (abs x)))) - '(lambda (x) (when (real? x) - #t))) - (cptypes-equivalent-expansion? - '(lambda (x) (when (flonum? x) - (flonum? (abs x)))) - '(lambda (x) (when (flonum? x) - #t))) + (test-closed1 '(add1 1+ sub1 1- -1+ abs) + '(flonum? real? (lambda (x) (and (integer? x) (exact? x))))) ) (mat cptypes-rest-argument diff --git a/release_notes/release_notes.stex b/release_notes/release_notes.stex index f1cc115ed..7ac1a4ed3 100644 --- a/release_notes/release_notes.stex +++ b/release_notes/release_notes.stex @@ -116,6 +116,10 @@ Online versions of both books can be found at %----------------------------------------------------------------------------- \section{Functionality Changes}\label{section:functionality} +\subsection{Add support for 1+, 1- and -1+ in type recovery (10.2.0)} + +The type recovery pass has support for 1+, 1- and -1+. + \subsection{Constrain signal delivery to the main thread (10.1.0)} Signals are now always delivered to the main Scheme thread to avoid crashes when a signal diff --git a/s/cptypes.ss b/s/cptypes.ss index 5c8f8639d..f1c44d3ad 100644 --- a/s/cptypes.ss +++ b/s/cptypes.ss @@ -1146,15 +1146,16 @@ Notes: (pred-env-add/ref ntypes val (rtd->record-predicate rtd #t) plxc)) #f)]))]) - (define-specialize 2 (add1 sub1) + (define-specialize 2 (add1 sub1 1+ 1- -1+) [(n) (let ([r (get-type n)]) (cond [(predicate-implies? r 'exact-integer) (values `(call ,preinfo ,pr ,n) 'exact-integer ntypes #f #f)] [(predicate-implies? r flonum-pred) - (values `(call ,preinfo ,(lookup-primref 3 (if (eq? prim-name 'add1) 'fl+ 'fl-)) ,n (quote 1.0)) - flonum-pred ntypes #f #f)] + (let ([flprim-name (if (memq prim-name '(add1 1+)) 'fl+ 'fl-)]) + (values `(call ,preinfo ,(lookup-primref 3 flprim-name) ,n (quote 1.0)) + flonum-pred ntypes #f #f))] [(predicate-implies? r real-pred) (values `(call ,preinfo ,pr ,n) real-pred ntypes #f #f)] diff --git a/s/primdata.ss b/s/primdata.ss index 8704e633e..0bd5e1baf 100644 --- a/s/primdata.ss +++ b/s/primdata.ss @@ -1138,9 +1138,9 @@ (= [sig [(number number ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs cptypes2]) ; not restricted to 2+ arguments (> [sig [(real real ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs cptypes2]) ; not restricted to 2+ arguments (>= [sig [(real real ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs cptypes2]) ; not restricted to 2+ arguments - (-1+ [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs]) - (1+ [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs]) - (1- [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs]) + (-1+ [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs cptypes2]) + (1+ [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs cptypes2]) + (1- [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs cptypes2]) (abort [sig [() (ptr) -> (bottom)]] [flags abort-op]) (acosh [sig [(number) -> (number)]] [flags arith-op mifoldable discard]) (add1 [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs cptypes2])