diff --git a/mats/cptypes.ms b/mats/cptypes.ms index 2ac5d6a82..f1ed11132 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,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)))) @@ -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)))) @@ -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 diff --git a/release_notes/release_notes.stex b/release_notes/release_notes.stex index f1cc115ed..95b1cc685 100644 --- a/release_notes/release_notes.stex +++ b/release_notes/release_notes.stex @@ -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 diff --git a/s/cptypes.ss b/s/cptypes.ss index 5c8f8639d..f91b6cedd 100644 --- a/s/cptypes.ss +++ b/s/cptypes.ss @@ -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 @@ -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]))) ) @@ -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*)) @@ -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)] @@ -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)] @@ -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 () 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])