Skip to content

Commit

Permalink
Add 1+, 1- and -1+ to cptypes
Browse files Browse the repository at this point in the history 
This extends the reductions for add1 and sub1 to the other variants.
  • Loading branch information
@gus-massa
gus-massa committed Nov 21, 2024
1 parent aeeaf29 commit 6b2c73b
Show file tree
Hide file tree
Showing 4 changed files with 37 additions and 63 deletions.
83 changes: 26 additions & 57 deletions mats/cptypes.ms
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)))
Expand Down Expand Up @@ -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
Expand Down
4 changes: 4 additions & 0 deletions release_notes/release_notes.stex
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
7 changes: 4 additions & 3 deletions s/cptypes.ss
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)]
Expand Down
6 changes: 3 additions & 3 deletions s/primdata.ss
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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])
Expand Down

0 comments on commit 6b2c73b

Please sign in to comment.