From 126c0905797b3924b090b0f9c671dde330f74656 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 20 Jan 2016 15:49:49 -0600 Subject: [PATCH] special case any/c when it appears syntactically in the argument to -> MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Skip calling the domain projection in that case and, if all of the arguments are any/c then also skip putting the contract continuation mark This appears to give about a 20% speed up on this program: #lang racket/base (require racket/contract/base) (define f (contract (-> any/c integer?) (λ (x) 1) 'pos 'neg)) (time (for ([x (in-range 4000000)]) (f 1))) --- .../tests/racket/contract/arrow.rkt | 24 ++++++ .../contract/private/arrow-higher-order.rkt | 43 +++++++---- .../contract/private/arrow-val-first.rkt | 77 +++++++++++-------- 3 files changed, 101 insertions(+), 43 deletions(-) diff --git a/pkgs/racket-test/tests/racket/contract/arrow.rkt b/pkgs/racket-test/tests/racket/contract/arrow.rkt index f5b87900b9..865e98b710 100644 --- a/pkgs/racket-test/tests/racket/contract/arrow.rkt +++ b/pkgs/racket-test/tests/racket/contract/arrow.rkt @@ -425,6 +425,30 @@ (struct s ()) ((impersonate-procedure s? (λ (x) (values (λ (r) "") x))) 11)) 'pos 'neg)) + + (test/spec-passed + 'any/c-in-domain1 + '((contract (-> any/c real?) + (λ (x) 0) + 'pos 'neg) 0)) + + (test/pos-blame + 'any/c-in-domain2 + '((contract (-> any/c real?) + (λ (x) #f) + 'pos 'neg) 0)) + + (test/spec-passed + 'any/c-in-domain3 + '((contract (-> any/c any/c any/c any/c real?) + (λ (x y z w) 0) + 'pos 'neg) 0 1 2 3)) + + (test/pos-blame + 'any/c-in-domain4 + '((contract (-> any/c any/c any/c any/c real?) + (λ (x y z w) #f) + 'pos 'neg) 0 1 2 3)) ;; this test ensures that no contract wrappers ;; are created for struct predicates diff --git a/racket/collects/racket/contract/private/arrow-higher-order.rkt b/racket/collects/racket/contract/private/arrow-higher-order.rkt index 9d08118eb9..572d8cb3b0 100644 --- a/racket/collects/racket/contract/private/arrow-higher-order.rkt +++ b/racket/collects/racket/contract/private/arrow-higher-order.rkt @@ -21,7 +21,11 @@ pre-post/desc-result->string) (define-for-syntax (build-chaperone-constructor/real this-args - mandatory-dom-projs + + ;; (listof (or/c #f stx)) + ;; #f => syntactically known to be any/c + mandatory-dom-projs + optional-dom-projs mandatory-dom-kwds optional-dom-kwds @@ -46,7 +50,9 @@ #,(create-chaperone #'blame #'neg-party #'blame-party-info #'f #'rng-ctcs this-args - (syntax->list #'(mandatory-dom-proj ...)) + (for/list ([id (in-list (syntax->list #'(mandatory-dom-proj ...)))] + [mandatory-dom-proj (in-list mandatory-dom-projs)]) + (and mandatory-dom-proj id)) (syntax->list #'(optional-dom-proj ...)) (map list mandatory-dom-kwds @@ -144,7 +150,6 @@ (list #`(check-post-cond/desc #,post/desc blame neg-party val))] [else null])]) (with-syntax ([(this-param ...) this-args] - [(dom-ctc ...) doms] [(dom-x ...) (generate-temporaries doms)] [(opt-dom-ctc ...) opt-doms] [(opt-dom-x ...) (generate-temporaries opt-doms)] @@ -193,7 +198,12 @@ [req-keywords (map (λ (p) (syntax-e (car p))) req-kwds)] [opt-keywords (map (λ (p) (syntax-e (car p))) opt-kwds)] [need-apply? (or dom-rest (not (null? opt-doms)))]) - (with-syntax ([(dom-projd-args ...) #'((dom-ctc dom-x neg-party) ...)] + (with-syntax ([(dom-projd-args ...) + (for/list ([dom (in-list doms)] + [dom-x (in-list (syntax->list #'(dom-x ...)))]) + (if dom + #`(#,dom #,dom-x neg-party) + dom-x))] [basic-params (cond [dom-rest @@ -274,15 +284,22 @@ #'(this-param ... dom-projd-args ... opt+rest-uses) #'(this-param ... dom-projd-args ...))) (define the-call/no-tail-mark - (with-syntax ([(tmps ...) (generate-temporaries - arg-checking-expressions)]) - #`(let-values ([(tmps ...) - (with-contract-continuation-mark - (cons blame neg-party) - (values #,@arg-checking-expressions))]) - #,(if need-apply? - #`(apply val tmps ...) - #`(val tmps ...))))) + (cond + [(for/and ([dom (in-list doms)]) + (not dom)) + (if need-apply? + #`(apply val #,@arg-checking-expressions) + #`(val #,@arg-checking-expressions))] + [else + (with-syntax ([(tmps ...) (generate-temporaries + arg-checking-expressions)]) + #`(let-values ([(tmps ...) + (with-contract-continuation-mark + (cons blame neg-party) + (values #,@arg-checking-expressions))]) + #,(if need-apply? + #`(apply val tmps ...) + #`(val tmps ...))))])) (define the-call #`(with-continuation-mark arrow:tail-contract-key (list* neg-party blame-party-info #,rng-ctcs) diff --git a/racket/collects/racket/contract/private/arrow-val-first.rkt b/racket/collects/racket/contract/private/arrow-val-first.rkt index 0198a48dbf..5f8e4497e4 100644 --- a/racket/collects/racket/contract/private/arrow-val-first.rkt +++ b/racket/collects/racket/contract/private/arrow-val-first.rkt @@ -52,19 +52,21 @@ ;; 'raco setup' of the current tree, these are all ;; the ones that appear at least 50 times (the ;; number indicate how many times each appeared) - `((0 0 () () #f 1) ; 1260 - (0 0 () () #t 1) ; 58 - (1 0 () () #f #f) ; 116 - (1 0 () () #f 1) ; 4140 - (1 0 () () #t 1) ; 71 - (1 1 () () #f 1) ; 186 - (1 2 () () #f 1) ; 125 - (2 0 () () #f #f) ; 99 - (2 0 () () #f 1) ; 1345 - (2 1 () () #f 1) ; 68 - (3 0 () () #f 1) ; 423 - (4 0 () () #f 1) ; 149 - (5 0 () () #f 1))) ; 74 + `((() 0 () () #f 1) ; 1260 + (() 0 () () #t 1) ; 58 + ((#f) 0 () () #f #f) ; 116 + ((#f) 0 () () #f 1) ; 4140 + ((#t) 0 () () #f 1) ; a new kind of key; expected to be popular + ((#f) 0 () () #t 1) ; 71 + ((#f) 1 () () #f 1) ; 186 + ((#f) 2 () () #f 1) ; 125 + ((#f #f) 0 () () #f #f) ; 99 + ((#f #f) 0 () () #f 1) ; 1345 + ((#f #f) 1 () () #f 1) ; 68 + ((#f #f #f) 0 () () #f 1) ; 423 + ((#f #f #f #f) 0 () () #f 1) ; 149 + ((#f #f #f #f #f) 0 () () #f 1))) ; 74 + (define-syntax (generate-popular-key-ids stx) (syntax-case stx () @@ -86,9 +88,14 @@ rest rngs post post/desc) + (define regular-args/no-any/c + (for/list ([stx (in-list regular-args)]) + (syntax-case stx () + [any/c #f] + [else stx]))) (define key (and (not pre) (not pre/desc) (not post) (not post/desc) - (list (length regular-args) + (list (map not regular-args/no-any/c) (length optional-args) (map syntax-e mandatory-kwds) (map syntax-e optional-kwds) @@ -115,7 +122,7 @@ post post/desc) (build-chaperone-constructor/real '() ;; this-args - regular-args + regular-args/no-any/c optional-args mandatory-kwds optional-kwds @@ -132,15 +139,20 @@ [key (in-list popular-keys)]) (define plus-one-id (list-ref ids 0)) (define chaperone-id (list-ref ids 1)) - (define-values (regular-arg-count + (define-values (regular-arg-any/c-or-not?s optional-arg-count mandatory-kwds optional-kwds rest rngs) (apply values key)) - (define mans (for/list ([x (in-range regular-arg-count)]) + (define mans (for/list ([is-any/c? (in-list regular-arg-any/c-or-not?s)] + [x (in-naturals)]) (string->symbol (format "man~a" x)))) + (define mans/no-any/c + (for/list ([is-any/c? (in-list regular-arg-any/c-or-not?s)] + [man-var (in-list mans)]) + (if is-any/c? #f man-var))) (define opts (for/list ([x (in-range optional-arg-count)]) (string->symbol (format "opt~a" x)))) (define rng-vars (and rngs (for/list ([x (in-range rngs)]) @@ -156,15 +168,20 @@ rng-vars #f #f)) (define #,(syntax-local-introduce chaperone-id) - #,(build-chaperone-constructor/real - '() ;; this arg - mans opts - mandatory-kwds - optional-kwds - #f #f - rest - rng-vars - #f #f)))) + #,(let ([ans (build-chaperone-constructor/real + '() ;; this arg + mans/no-any/c opts + mandatory-kwds + optional-kwds + #f #f + rest + rng-vars + #f #f)]) + #; + (when (equal? key (list '(#t) 0 '() '() #f 1)) + ((dynamic-require 'racket/pretty 'pretty-write) (syntax->datum ans)) + (exit)) + ans)))) (define popular-chaperone-key-table (make-hash (list #,@(for/list ([id (in-list popular-key-ids)] @@ -403,13 +420,13 @@ (mk-call)])))) (build-populars popular-chaperone-key-table) -(define (lookup-popular-chaperone-key regular-arg-count +(define (lookup-popular-chaperone-key regular-arg-any/c-or-not?s optional-arg-count mandatory-kwds optional-kwds rest rngs) - (define key (list regular-arg-count + (define key (list regular-arg-any/c-or-not?s optional-arg-count mandatory-kwds optional-kwds @@ -899,7 +916,7 @@ (define max-arity (if rest-contract #f (+ min-arity optionals))) (define build-chaperone-constructor - (or (lookup-popular-chaperone-key min-arity + (or (lookup-popular-chaperone-key (for/list ([i (in-range min-arity)]) #f) optionals mandatory-keywords optional-keywords @@ -1241,7 +1258,7 @@ (define ->void-contract (let-syntax ([get-chaperone-constructor (λ (_) - (define desired-key '(0 0 () () #f 1)) + (define desired-key '(() 0 () () #f 1)) (define expected-index 0) (unless (equal? desired-key (list-ref popular-keys expected-index)) (error '->void-contract "expected the 0th key to be ~s" desired-key))