suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

special case any/c when it appears syntactically in the argument to ->

Browse Source 
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)))
This commit is contained in:
Robby Findler 2016-01-20 15:49:49 -06:00
parent f130a5ea48
commit 126c090579
3 changed files with 101 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
pkgs/racket-test/tests/racket/contract/arrow.rkt
View File

@ -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

43
racket/collects/racket/contract/private/arrow-higher-order.rkt
View File

@ -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)

77
racket/collects/racket/contract/private/arrow-val-first.rkt
View File

@ -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))