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.
This commit is contained in:
Robby Findler
parent
e3abc6f5c7
commit
35ce47d97c
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))]
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user