Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Add 1+, 1- and -1+, and improve abs in cptypes #888

Merged
merged 2 commits into from
Nov 29, 2024
Merged

Add 1+, 1- and -1+, and improve abs in cptypes #888

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
b52be98
Add 1+, 1- and -1+ to cptypes
gus-massa Nov 13, 2024
cbcd12b
Improve fixnum case of abs in cptypes
gus-massa Nov 14, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
78 changes: 35 additions & 43 deletions mats/cptypes.ms
View file
Open in desktop
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,13 +893,6 @@
(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))))
Expand All @@ -897,28 +903,16 @@
(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))))
Expand All @@ -929,48 +923,46 @@
(bignum? (sub1 x))))
'(lambda (x) (when (bignum? x)
#t))))
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Should this test have been kept? I don't think it's covered by the test-closed1 generalization, but I might be missing something else.

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I undeleted the test. It's a to ensure I don't make an easy mistake in the future. I don't know why I deleted it.

It's not included in test-closed1. Moreover, I was thinking about writing test-not-closed1 to reduce duplication, but I decided that it was too weird. But Perhaps I'll add it in the future if there are too many cases of almost-closed functions.

(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?
'(lambda (x) (when (fixnum? x)
(abs x)))
'(lambda (x) (when (fixnum? x)
(let ([t x])
(if (#3%fx= t (most-negative-fixnum))
(pariah (- (most-negative-fixnum)))
(#3%fxabs t))))))
(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))))
(abs x)))
'(lambda (x) (when (flonum? x)
#t)))
(#3%flabs x))))
(test-closed1 '(add1 1+ sub1 1- -1+ abs)
'(flonum? real? (lambda (x) (and (integer? x) (exact? x)))))
)

(mat cptypes-rest-argument
Expand Down
5 changes: 5 additions & 0 deletions release_notes/release_notes.stex
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -116,6 +116,11 @@ Online versions of both books can be found at
%-----------------------------------------------------------------------------
\section{Functionality Changes}\label{section:functionality}

\subsection{Type recovery improvements (10.2.0)}

The type recovery pass has improved support for \scheme{abs} with a fixnum argument
and added support for \scheme{1+}, \scheme{1-}, and \scheme{-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
85 changes: 47 additions & 38 deletions s/cptypes.ss
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -298,10 +298,38 @@ Notes:
(ensure-single-value e1 #f)
(make-seq ctxt (ensure-single-value e1 #f)
(loop (car e*) (cdr e*)))))]))
(define (build-let var* e* body)
(if (null? var*)
body
`(call ,(make-preinfo-call) ,(build-lambda var* body) ,e* ...)))

(define (prepare-let e* r*) ; ==> (before* var* e* ref*)
; The arguments e* and r* must have the same length.
; In the results:
; before*, var* and e* may be shorter than the arguments.
; var* and e* have the same length.
; ref* has the same length as the arguments.
; It may be a mix of: references to the new variables
; references to variables in the context
; propagated constants
(let loop ([rev-rbefore* '()] [rev-rvar* '()] [rev-re* '()] [rev-rref* '()]
[e* e*] [r* r*])
(cond
[(and (null? e*) (null? r*))
(values (reverse rev-rbefore*) (reverse rev-rvar*) (reverse rev-re*) (reverse rev-rref*))]
[(check-constant-is? (car r*))
(loop (cons (car e*) rev-rbefore*) rev-rvar* rev-re* (cons (car r*) rev-rref*)
(cdr e*) (cdr r*))]
[(try-ref->prelex/not-assigned (car e*))
=> (lambda (v)
(set-prelex-multiply-referenced! v #t) ; just in case it was singly referenced
(loop rev-rbefore* rev-rvar* rev-re* (cons (car e*) rev-rref*)
(cdr e*) (cdr r*)))]
[else
(let ([v (make-temp-prelex #t)])
(loop rev-rbefore* (cons v rev-rvar*) (cons (car e*) rev-re*) (cons (build-ref v) rev-rref*)
(cdr e*) (cdr r*)))])))

(define (build-let var* e* body)
(if (null? var*)
body
`(call ,(make-preinfo-call) ,(build-lambda var* body) ,e* ...)))

(define build-lambda
(case-lambda
Expand All @@ -318,10 +346,10 @@ Notes:
(define (build-ref x)
`(ref #f ,x))

(define (try-ref->prelex v)
(define (try-ref->prelex/not-assigned v)
(and (Lsrc? v)
(nanopass-case (Lsrc Expr) v
[(ref ,maybe-src ,x) x]
[(ref ,maybe-src ,x) (and (not (prelex-assigned x)) x)]
[else #f])))
)

Expand Down Expand Up @@ -978,33 +1006,6 @@ Notes:
)

(let ()
(define (prepare-let e* r*) ; ==> (before* var* e* ref*)
; All the arguments must have the same length.
; In the results:
; before*, var* and e* may be shorter than the arguments.
; var* and e* have the same length.
; ref* has the same lenght than the arguments.
; It may be a mix of: references to the new variables
; references to variables in the context
; propagated constants
(let loop ([rev-rbefore* '()] [rev-rvar* '()] [rev-re* '()] [rev-rref* '()]
[e* e*] [r* r*])
(cond
[(null? e*)
(values (reverse rev-rbefore*) (reverse rev-rvar*) (reverse rev-re*) (reverse rev-rref*))]
[(check-constant-is? (car r*))
(loop (cons (car e*) rev-rbefore*) rev-rvar* rev-re* (cons (car r*) rev-rref*)
(cdr e*) (cdr r*))]
[(try-ref->prelex (car e*))
=> (lambda (v)
(set-prelex-multiply-referenced! v #t) ; just in case it was sinlge referenced
(loop rev-rbefore* rev-rvar* rev-re* (cons (car e*) rev-rref*)
(cdr e*) (cdr r*)))]
[else
(let ([v (make-temp-prelex #t)])
(loop rev-rbefore* (cons v rev-rvar*) (cons (car e*) rev-re*) (cons (build-ref v) rev-rref*)
(cdr e*) (cdr r*)))])))

(define (countmap f l*)
(fold-left (lambda (x l) (if (f l) (+ 1 x) x)) 0 l*))

Expand Down Expand Up @@ -1146,15 +1147,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 All @@ -1165,7 +1167,14 @@ Notes:
(define-specialize 2 abs
[(n) (let ([r (get-type n)])
(cond
; not closed for fixnums
[(predicate-implies? r 'fixnum)
(let-values ([(before* var* n* ref*) (prepare-let (list n) (list r))])
(values (make-seq ctxt (make-1seq* 'effect before*)
(build-let var* n*
`(if (call ,(make-preinfo-call) ,(lookup-primref 3 'fx=) ,(car ref*) (quote ,(constant most-negative-fixnum)))
,(make-seq ctxt `(pariah) `(quote ,(- (constant most-negative-fixnum))))
(call ,preinfo ,(lookup-primref 3 'fxabs) ,(car ref*)))))
'exact-integer ntypes #f #f))]
[(predicate-implies? r 'bignum)
(values `(call ,preinfo ,pr ,n)
'bignum ntypes #f #f)]
Expand Down Expand Up @@ -1603,7 +1612,7 @@ Notes:
(apply values sp-types untransposed))

(define (map-values l f v*)
; `l` is the default lenght, in case `v*` is null.
; `l` is the default length, in case `v*` is null.
(if (null? v*)
(apply values (make-list l '()))
(let ()
Expand Down
6 changes: 3 additions & 3 deletions s/primdata.ss
View file
Open in desktop
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