Skip to content

Commit

Permalink
Add 1+, 1- and -1+, and improve abs in cptypes (#888)
Browse files Browse the repository at this point in the history 
Add 1+, 1- and -1+ to cptypes

Add a special case for `abs`, in particular because
`(abs (most-negative-fixnum))` is not a fixnum.
  • Loading branch information
@gus-massa
gus-massa authored Nov 29, 2024
1 parent aeeaf29 commit 063485e
Show file tree
Hide file tree
Showing 4 changed files with 90 additions and 84 deletions.
78 changes: 35 additions & 43 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,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))))
(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
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
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
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 063485e

Please sign in to comment.