From 8918279b21ffdea70140d0025ef03d0075731737 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 15 Dec 2016 11:44:23 -0600 Subject: [PATCH] adjust ->i so that when it sees that it got a flat contract, it doesn't apply it the second time (since we know that the only difference for indy blame is in the negative position and we know that flat contracts never assign negative blame) This commit combined with the two previous (2b9d855 and 003e8c7) do not seem to have a significant effect on the performance of ->i contract checking. In particular, I see a 50% slowdown between the version before and the version after these commits on the third `time` expression below, but no significant difference on the first two. (without the improvement to flat-contract?, these commits are a significant slowdown to `g`) #lang racket (require profile) (define f (contract (->i ([y () integer?] [x (y) integer?]) (values [a () integer?] [b (a) integer?])) values 'pos 'neg)) (define g (contract (->i ([y () (<=/c 10)] [x (y) (>=/c y)]) (values [a () (<=/c 10)] [b (a) (>=/c a)])) values 'pos 'neg)) (define (slow-predicate n) (cond [(zero? n) #t] [else (slow-predicate (- n 1))])) (define h (contract (->i ([y () slow-predicate] [x (y) slow-predicate]) (values [a () slow-predicate] [b (a) slow-predicate])) values 'pos 'neg)) (time (for ([x (in-range 100000)]) (f 1 2) (f 1 2) (f 1 2) (f 1 2) (f 1 2) (f 1 2) (f 1 2) (f 1 2) (f 1 2))) (time (for ([x (in-range 100000)]) (g 1 2) (g 1 2) (g 1 2) (g 1 2) (g 1 2) (g 1 2) (g 1 2) (g 1 2) (g 1 2))) (time (for ([x (in-range 10000)]) (h 50000 50000))) --- .../tests/racket/contract/arrow-i.rkt | 21 ++++++++++ .../racket/contract/private/arr-i.rkt | 41 +++++++++++-------- 2 files changed, 46 insertions(+), 16 deletions(-) diff --git a/pkgs/racket-test/tests/racket/contract/arrow-i.rkt b/pkgs/racket-test/tests/racket/contract/arrow-i.rkt index 704001062f..2e323bdc97 100644 --- a/pkgs/racket-test/tests/racket/contract/arrow-i.rkt +++ b/pkgs/racket-test/tests/racket/contract/arrow-i.rkt @@ -980,6 +980,27 @@ ;; this is probably right (but not what we really really want, of course) '(5 4 5 4 3 2 1 2 1)) + + (test/spec-passed/result + '->i57 + '(let ([b '()]) + ((contract (->i ([y () (begin (set! b (cons 1 b)) + (λ (y) (set! b (cons 2 b)) #t))] + [z (y) (begin (set! b (cons 3 b)) + (λ (y) (set! b (cons 4 b)) #t))]) + (values + [a () (begin (set! b (cons 6 b)) + (λ (a) (set! b (cons 7 b)) #t))] + [b (a) (begin (set! b (cons 8 b)) + (λ (a) (set! b (cons 9 b)) #t))])) + (λ args (set! b (cons 5 b)) (values 0 0)) + 'pos 'neg) + 1 2) + b) + '(9 8 7 6 5 4 3 2 1) + + ;; this is probably right (but not what we really really want, of course) + '(9 8 7 6 9 8 7 6 5 4 3 2 1 4 3 2 1)) (test/pos-blame '->i-arity1 diff --git a/racket/collects/racket/contract/private/arr-i.rkt b/racket/collects/racket/contract/private/arr-i.rkt index cb5a9e7164..a69dfcdd42 100644 --- a/racket/collects/racket/contract/private/arr-i.rkt +++ b/racket/collects/racket/contract/private/arr-i.rkt @@ -693,7 +693,9 @@ evaluted left-to-right.) [indy-arg/res-proj-var (vector-ref indy-arg/res-proj-vars index)]) ;; bound to the result of calling the dependent function - ;; (so computes what the contract will be for the given argument/res value) + ;; (which isn't a contract directly, but is a function that returns + ;; the projection for a contract) + ;; the result computes what the contract will be for the given argument/res value. (define contract-identifier (car (generate-temporaries (list indy-arg/res-var)))) (define indy-binding @@ -708,7 +710,8 @@ evaluted left-to-right.) #`(#,contract-identifier #,wrapper-arg #,(build-blame-identifier #t swapped-blame? (arg/res-var an-arg/res)) - neg-party) + neg-party + #t) #`(#,indy-arg/res-proj-var #,wrapper-arg neg-party)))]) (list))) @@ -735,12 +738,14 @@ evaluted left-to-right.) #,(build-blame-identifier #f swapped-blame? (arg/res-var an-arg/res)) - neg-party)] + neg-party + #f)] [(arg/res-vars an-arg/res) #`(#,contract-identifier #,wrapper-arg #,(build-blame-identifier #f swapped-blame? (arg/res-var an-arg/res)) - neg-party)] + neg-party + #f)] [else #`(#,arg/res-proj-var #,wrapper-arg neg-party)]))] #,@indy-binding) @@ -1085,24 +1090,26 @@ evaluted left-to-right.) #`(f #,@argument-list))) (begin-encourage-inline - (define (un-dep/maybe-chaperone orig-ctc obj blame neg-party chaperone?) + (define (un-dep/maybe-chaperone orig-ctc obj blame neg-party chaperone? indy-blame?) (cond [(and (procedure? orig-ctc) (procedure-arity-includes? orig-ctc 1)) - (if (orig-ctc obj) + (if (or indy-blame? (orig-ctc obj)) obj (raise-predicate-blame-error-failure blame obj neg-party (contract-name orig-ctc)))] + [(and indy-blame? (flat-contract? orig-ctc)) + obj] [else (define ctc (if chaperone? (coerce-chaperone-contract '->i orig-ctc) (coerce-contract '->i orig-ctc))) (((get/build-late-neg-projection ctc) blame) obj neg-party)])) - (define (un-dep/chaperone orig-ctc obj blame neg-party) - (un-dep/maybe-chaperone orig-ctc obj blame neg-party #t)) + (define (un-dep/chaperone orig-ctc obj blame neg-party indy-blame?) + (un-dep/maybe-chaperone orig-ctc obj blame neg-party #t indy-blame?)) - (define (un-dep orig-ctc obj blame neg-party) - (un-dep/maybe-chaperone orig-ctc obj blame neg-party #f))) + (define (un-dep orig-ctc obj blame neg-party indy-blame?) + (un-dep/maybe-chaperone orig-ctc obj blame neg-party #f indy-blame?))) (define-for-syntax (mk-used-indy-vars an-istx) (let ([vars (make-free-identifier-mapping)]) @@ -1237,11 +1244,11 @@ evaluted left-to-right.) (gensym '->i-indy-boundary))) #`(λ (#,@orig-vars) (define the-contract #,ctc-stx) - (λ (val blame neg-party) + (λ (val blame neg-party indy-blame?) ;; this used to use opt/direct, but ;; opt/direct duplicates code (bad!) (#,(if is-chaperone-contract? #'un-dep/chaperone #'un-dep) - the-contract val blame neg-party))))) + the-contract val blame neg-party indy-blame?))))) ;; then the non-dependent argument contracts that are themselves dependend on (list #,@(filter values (map (λ (arg/res indy-id) @@ -1272,15 +1279,17 @@ evaluted left-to-right.) (gensym '->i-indy-boundary))) (if (eres? arg) #`(λ #,orig-vars - #,@(arg/res-vars arg) (opt/c #,arg-stx)) #`(λ (#,@orig-vars) (define the-contract #,arg-stx) - (λ (val blame neg-party) + (λ (val blame neg-party indy-blame?) ;; this used to use opt/direct, but ;; opt/direct duplicates code (bad!) - (#,(if is-chaperone-contract? #'un-dep/chaperone #'un-dep) - the-contract val blame neg-party)))))) + (#,(if is-chaperone-contract? + #'un-dep/chaperone + #'un-dep) + the-contract val blame neg-party + indy-blame?)))))) #''()) #,(if (istx-ress an-istx) #`(list #,@(filter values