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

use procedure-result-arity in racket/contract

Browse Source 
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.
This commit is contained in:
Robby Findler 2016-01-15 23:44:12 -06:00
parent e3abc6f5c7
commit 35ce47d97c
3 changed files with 77 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -169,13 +169,9 @@
[args [args
(arrow:bad-number-of-results blame val rng-len args (arrow:bad-number-of-results blame val rng-len args
#:missing-party neg-party)])))) #: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 (if rngs
;; with this version, the unsafe-procedure-chaperone (if assume-result-values?
;; 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]) #`(let-values ([(rng-x ...) #,stx])
(with-contract-continuation-mark (with-contract-continuation-mark
(cons blame neg-party) (cons blame neg-party)
@ -184,7 +180,7 @@
(values (rng-late-neg-projs rng-x neg-party) ...)))) (values (rng-late-neg-projs rng-x neg-party) ...))))
#`(call-with-values #`(call-with-values
(λ () #,stx) (λ () #,stx)
#,rng-checker) #,rng-checker))
stx)) stx))
(let* ([min-method-arity (length doms)] (let* ([min-method-arity (length doms)]
@ -266,9 +262,9 @@
(list rng-checker) (list rng-checker)
inner-stx-gen) inner-stx-gen)
(inner-stx-gen #'())))] (inner-stx-gen #'())))]
[basic-unsafe-return [(basic-unsafe-return basic-unsafe-return/result-values-assumed)
(let ([inner-stx-gen (let ()
(λ (stuff) (define (inner-stx-gen stuff assume-result-values?)
(define the-call/no-marks (define the-call/no-marks
(if need-apply? (if need-apply?
#`(apply val #`(apply val
@ -283,14 +279,20 @@
(cond (cond
[(null? (syntax-e stuff)) ;; surely there must a better way [(null? (syntax-e stuff)) ;; surely there must a better way
the-call] the-call]
[else (wrap-call-with-values-and-range-checking the-call)]))]) [else
(wrap-call-with-values-and-range-checking
the-call
assume-result-values?)]))
(define (mk-return assume-result-values?)
(if rngs (if rngs
(arrow:check-tail-contract rng-ctcs (arrow:check-tail-contract
rng-ctcs
blame-party-info blame-party-info
neg-party neg-party
#'not-a-null #'not-a-null
inner-stx-gen) (λ (x) (inner-stx-gen x assume-result-values?)))
(inner-stx-gen #'())))] (inner-stx-gen #'() assume-result-values?)))
(list (mk-return #f) (mk-return #t)))]
[kwd-return [kwd-return
(let* ([inner-stx-gen (let* ([inner-stx-gen
(if need-apply? (if need-apply?
@ -333,11 +335,18 @@
(cons blame neg-party) (cons blame neg-party)
(let () (let ()
pre ... basic-return)))] pre ... basic-return)))]
[basic-unsafe-lambda #'(λ basic-params [basic-unsafe-lambda
#'(λ basic-params
(with-contract-continuation-mark (with-contract-continuation-mark
(cons blame neg-party) (cons blame neg-party)
(let () (let ()
pre ... basic-unsafe-return)))] 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-name (gen-id 'kwd-lambda)]
[kwd-lambda #`(λ kwd-lam-params [kwd-lambda #`(λ kwd-lam-params
(with-contract-continuation-mark (with-contract-continuation-mark
@ -348,7 +357,10 @@
[(and (null? req-keywords) (null? opt-keywords)) [(and (null? req-keywords) (null? opt-keywords))
#`(arrow:arity-checking-wrapper val #`(arrow:arity-checking-wrapper val
blame neg-party blame neg-party
basic-lambda basic-unsafe-lambda basic-lambda
basic-unsafe-lambda
basic-unsafe-lambda/result-values-assumed
#,(and rngs (length rngs))
void void
#,min-method-arity #,min-method-arity
#,max-method-arity #,max-method-arity
@ -359,7 +371,7 @@
[(pair? req-keywords) [(pair? req-keywords)
#`(arrow:arity-checking-wrapper val #`(arrow:arity-checking-wrapper val
blame neg-party blame neg-party
void #t void #t #f #f
kwd-lambda kwd-lambda
#,min-method-arity #,min-method-arity
#,max-method-arity #,max-method-arity
@ -370,7 +382,7 @@
[else [else
#`(arrow:arity-checking-wrapper val #`(arrow:arity-checking-wrapper val
blame neg-party blame neg-party
basic-lambda #t basic-lambda #t #f #f
kwd-lambda kwd-lambda
#,min-method-arity #,min-method-arity
#,max-method-arity #,max-method-arity

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

@ -963,7 +963,7 @@
args-dealt-with))))) args-dealt-with)))))
(values (arrow:arity-checking-wrapper f blame neg-party (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
min-arity max-arity min-arity max-arity
mandatory-keywords optional-keywords) mandatory-keywords optional-keywords)

24
racket/collects/racket/contract/private/arrow.rkt
View File

@ -398,7 +398,7 @@
#`(let-values ([(rng-checker-name ...) (values/drop rng-checker ...)]) #`(let-values ([(rng-checker-name ...) (values/drop rng-checker ...)])
(let ([basic-lambda-name basic-lambda]) (let ([basic-lambda-name basic-lambda])
(arity-checking-wrapper val blame neg-party (arity-checking-wrapper val blame neg-party
basic-lambda-name #f basic-lambda-name #f #f #f
void void
#,min-method-arity #,min-method-arity
#,max-method-arity #,max-method-arity
@ -410,7 +410,7 @@
#`(let-values ([(rng-checker-name ...) (values/drop rng-checker ...)]) #`(let-values ([(rng-checker-name ...) (values/drop rng-checker ...)])
(let ([kwd-lambda-name kwd-lambda]) (let ([kwd-lambda-name kwd-lambda])
(arity-checking-wrapper val blame neg-party (arity-checking-wrapper val blame neg-party
void #f void #f #f #f
kwd-lambda-name kwd-lambda-name
#,min-method-arity #,min-method-arity
#,max-method-arity #,max-method-arity
@ -423,7 +423,7 @@
(let ([basic-lambda-name basic-lambda] (let ([basic-lambda-name basic-lambda]
[kwd-lambda-name kwd-lambda]) [kwd-lambda-name kwd-lambda])
(arity-checking-wrapper val blame neg-party (arity-checking-wrapper val blame neg-party
basic-lambda-name #f basic-lambda-name #f #f #f
kwd-lambda-name kwd-lambda-name
#,min-method-arity #,min-method-arity
#,max-method-arity #,max-method-arity
@ -437,18 +437,26 @@
;; namely the chaperone wrapper. Otherwise, returns two values, ;; namely the chaperone wrapper. Otherwise, returns two values,
;; a procedure and a boolean indicating it the procedure is the ;; a procedure and a boolean indicating it the procedure is the
;; basic-unsafe-lambda or not; note that basic-unsafe-lambda might ;; 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) ;; 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 min-method-arity max-method-arity min-arity max-arity
req-kwd opt-kwd) req-kwd opt-kwd)
;; should not build this unless we are in the 'else' case (and maybe not at all) ;; should not build this unless we are in the 'else' case (and maybe not at all)
(cond (cond
[(matches-arity-exactly? val min-arity max-arity req-kwd opt-kwd) [(matches-arity-exactly? val min-arity max-arity req-kwd opt-kwd)
(if (and (null? req-kwd) (null? opt-kwd)) (if (and (null? req-kwd) (null? opt-kwd))
(if basic-unsafe-lambda (cond
(values basic-unsafe-lambda #t) [(and basic-unsafe-lambda/result-values-assumed
basic-lambda) (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 (if basic-unsafe-lambda
(values kwd-lambda #f) (values kwd-lambda #f)
kwd-lambda))] kwd-lambda))]