diff --git a/mats/cptypes.ms b/mats/cptypes.ms index b7d09b03d..4c1c9d5c8 100644 --- a/mats/cptypes.ms +++ b/mats/cptypes.ms @@ -933,11 +933,24 @@ (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 (flonum? x) + (abs x))) + '(lambda (x) (when (flonum? x) + (#3%flabs x)))) (test-closed1 '(add1 1+ sub1 1- -1+ abs) '(flonum? real? (lambda (x) (and (integer? x) (exact? x))))) ) diff --git a/release_notes/release_notes.stex b/release_notes/release_notes.stex index 7ac1a4ed3..e00850576 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{Improved support abs in type recovery (10.2.0)} + +The type recovery pass has improved support for abs when the argument is a fixnum. + \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+. diff --git a/s/cptypes.ss b/s/cptypes.ss index f1c44d3ad..154555508 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 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 + [(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 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 (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*)) @@ -1166,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)]