From 35ce47d97ccb4a74e481d10e65d6812c40c979ec Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 15 Jan 2016 23:44:12 -0600 Subject: [PATCH] use procedure-result-arity in racket/contract This commit, combined with the use of unsafe-chaperone-procedure, achieves almost the same speedups as c24ddb4a7, but now correctly. More concretely, this program: #lang racket/base (module server racket/base (require racket/contract/base) (provide (contract-out [f (-> integer? integer?)])) (define (f x) x)) (require 'server) (time (let ([f f]) ;; <-- defeats the plus-one-arity optimiztion (for ([x (in-range 1000000)]) (f 1) (f 2) (f 3) (f 4) (f 5)))) runs only about 40% slower than the version without the "(let ([f f])" and this program #lang racket/base (module m racket/base (provide f) (define (f x) x)) (module n typed/racket/base (require/typed (submod ".." m) [f (-> Integer Integer)]) (time (for ([x (in-range 1000000)]) (f 1) (f 2) (f 3) (f 4)))) (require 'n) runs about 2.8x faster than it did before that same set of changes. --- .../contract/private/arrow-higher-order.rkt | 108 ++++++++++-------- .../contract/private/arrow-val-first.rkt | 2 +- .../racket/contract/private/arrow.rkt | 24 ++-- 3 files changed, 77 insertions(+), 57 deletions(-) diff --git a/racket/collects/racket/contract/private/arrow-higher-order.rkt b/racket/collects/racket/contract/private/arrow-higher-order.rkt index 9c1390722c..5b3b053084 100644 --- a/racket/collects/racket/contract/private/arrow-higher-order.rkt +++ b/racket/collects/racket/contract/private/arrow-higher-order.rkt @@ -169,22 +169,18 @@ [args (arrow:bad-number-of-results blame val rng-len args #:missing-party neg-party)])))) - (define (wrap-call-with-values-and-range-checking stx) + (define (wrap-call-with-values-and-range-checking stx assume-result-values?) (if rngs - ;; with this version, the unsafe-procedure-chaperone - ;; wrappers would work only when the number of values - ;; the function returns is known to be a match for - ;; what the contract wants. - #; - #`(let-values ([(rng-x ...) #,stx]) - (with-contract-continuation-mark - (cons blame neg-party) - (let () - post ... - (values (rng-late-neg-projs rng-x neg-party) ...)))) - #`(call-with-values - (λ () #,stx) - #,rng-checker) + (if assume-result-values? + #`(let-values ([(rng-x ...) #,stx]) + (with-contract-continuation-mark + (cons blame neg-party) + (let () + post ... + (values (rng-late-neg-projs rng-x neg-party) ...)))) + #`(call-with-values + (λ () #,stx) + #,rng-checker)) stx)) (let* ([min-method-arity (length doms)] @@ -266,31 +262,37 @@ (list rng-checker) inner-stx-gen) (inner-stx-gen #'())))] - [basic-unsafe-return - (let ([inner-stx-gen - (λ (stuff) - (define the-call/no-marks - (if need-apply? - #`(apply val - this-param ... - dom-projd-args ... - opt+rest-uses) - #`(val this-param ... dom-projd-args ...))) - (define the-call - #`(with-continuation-mark arrow:tail-contract-key - (list* neg-party blame-party-info #,rng-ctcs) - #,the-call/no-marks)) - (cond - [(null? (syntax-e stuff)) ;; surely there must a better way - the-call] - [else (wrap-call-with-values-and-range-checking the-call)]))]) - (if rngs - (arrow:check-tail-contract rng-ctcs - blame-party-info - neg-party - #'not-a-null - inner-stx-gen) - (inner-stx-gen #'())))] + [(basic-unsafe-return basic-unsafe-return/result-values-assumed) + (let () + (define (inner-stx-gen stuff assume-result-values?) + (define the-call/no-marks + (if need-apply? + #`(apply val + this-param ... + dom-projd-args ... + opt+rest-uses) + #`(val this-param ... dom-projd-args ...))) + (define the-call + #`(with-continuation-mark arrow:tail-contract-key + (list* neg-party blame-party-info #,rng-ctcs) + #,the-call/no-marks)) + (cond + [(null? (syntax-e stuff)) ;; surely there must a better way + the-call] + [else + (wrap-call-with-values-and-range-checking + the-call + assume-result-values?)])) + (define (mk-return assume-result-values?) + (if rngs + (arrow:check-tail-contract + rng-ctcs + blame-party-info + neg-party + #'not-a-null + (λ (x) (inner-stx-gen x assume-result-values?))) + (inner-stx-gen #'() assume-result-values?))) + (list (mk-return #f) (mk-return #t)))] [kwd-return (let* ([inner-stx-gen (if need-apply? @@ -333,11 +335,18 @@ (cons blame neg-party) (let () pre ... basic-return)))] - [basic-unsafe-lambda #'(λ basic-params - (with-contract-continuation-mark - (cons blame neg-party) - (let () - pre ... basic-unsafe-return)))] + [basic-unsafe-lambda + #'(λ basic-params + (with-contract-continuation-mark + (cons blame neg-party) + (let () + pre ... basic-unsafe-return)))] + [basic-unsafe-lambda/result-values-assumed + #'(λ basic-params + (with-contract-continuation-mark + (cons blame neg-party) + (let () + pre ... basic-unsafe-return/result-values-assumed)))] [kwd-lambda-name (gen-id 'kwd-lambda)] [kwd-lambda #`(λ kwd-lam-params (with-contract-continuation-mark @@ -348,7 +357,10 @@ [(and (null? req-keywords) (null? opt-keywords)) #`(arrow:arity-checking-wrapper val blame neg-party - basic-lambda basic-unsafe-lambda + basic-lambda + basic-unsafe-lambda + basic-unsafe-lambda/result-values-assumed + #,(and rngs (length rngs)) void #,min-method-arity #,max-method-arity @@ -359,7 +371,7 @@ [(pair? req-keywords) #`(arrow:arity-checking-wrapper val blame neg-party - void #t + void #t #f #f kwd-lambda #,min-method-arity #,max-method-arity @@ -370,7 +382,7 @@ [else #`(arrow:arity-checking-wrapper val blame neg-party - basic-lambda #t + basic-lambda #t #f #f kwd-lambda #,min-method-arity #,max-method-arity diff --git a/racket/collects/racket/contract/private/arrow-val-first.rkt b/racket/collects/racket/contract/private/arrow-val-first.rkt index 3198fa358e..0198a48dbf 100644 --- a/racket/collects/racket/contract/private/arrow-val-first.rkt +++ b/racket/collects/racket/contract/private/arrow-val-first.rkt @@ -963,7 +963,7 @@ args-dealt-with))))) (values (arrow:arity-checking-wrapper f blame neg-party - interposition-proc #f interposition-proc + interposition-proc #f interposition-proc #f #f min-arity max-arity min-arity max-arity mandatory-keywords optional-keywords) diff --git a/racket/collects/racket/contract/private/arrow.rkt b/racket/collects/racket/contract/private/arrow.rkt index b1ddfbb09d..9b18263218 100644 --- a/racket/collects/racket/contract/private/arrow.rkt +++ b/racket/collects/racket/contract/private/arrow.rkt @@ -398,7 +398,7 @@ #`(let-values ([(rng-checker-name ...) (values/drop rng-checker ...)]) (let ([basic-lambda-name basic-lambda]) (arity-checking-wrapper val blame neg-party - basic-lambda-name #f + basic-lambda-name #f #f #f void #,min-method-arity #,max-method-arity @@ -410,7 +410,7 @@ #`(let-values ([(rng-checker-name ...) (values/drop rng-checker ...)]) (let ([kwd-lambda-name kwd-lambda]) (arity-checking-wrapper val blame neg-party - void #f + void #f #f #f kwd-lambda-name #,min-method-arity #,max-method-arity @@ -423,7 +423,7 @@ (let ([basic-lambda-name basic-lambda] [kwd-lambda-name kwd-lambda]) (arity-checking-wrapper val blame neg-party - basic-lambda-name #f + basic-lambda-name #f #f #f kwd-lambda-name #,min-method-arity #,max-method-arity @@ -437,18 +437,26 @@ ;; namely the chaperone wrapper. Otherwise, returns two values, ;; a procedure and a boolean indicating it the procedure is the ;; basic-unsafe-lambda or not; note that basic-unsafe-lambda might -;; also be #f, but that happens only when we know that basic-lambda +;; also be #t, but that happens only when we know that basic-lambda ;; can't be chosen (because there are keywords involved) -(define (arity-checking-wrapper val blame neg-party basic-lambda basic-unsafe-lambda kwd-lambda +(define (arity-checking-wrapper val blame neg-party basic-lambda + basic-unsafe-lambda + basic-unsafe-lambda/result-values-assumed contract-result-val-count + kwd-lambda min-method-arity max-method-arity min-arity max-arity req-kwd opt-kwd) ;; should not build this unless we are in the 'else' case (and maybe not at all) (cond [(matches-arity-exactly? val min-arity max-arity req-kwd opt-kwd) (if (and (null? req-kwd) (null? opt-kwd)) - (if basic-unsafe-lambda - (values basic-unsafe-lambda #t) - basic-lambda) + (cond + [(and basic-unsafe-lambda/result-values-assumed + (equal? contract-result-val-count + (procedure-result-arity val))) + (values basic-unsafe-lambda/result-values-assumed #t)] + [basic-unsafe-lambda + (values basic-unsafe-lambda #t)] + [else basic-lambda]) (if basic-unsafe-lambda (values kwd-lambda #f) kwd-lambda))]