When we know that the procedure getting a contract is "simple enough",
drop the tail call fanciness
"simple enough", for now, means that it is a struct selector, predicate,
constructor, or mutator. Perhaps we will learn more about such simple
procedures where this is safe some other way.
This commit speeds up this program:
#lang racket/base
(require racket/contract/base)
(struct s (x))
(define f (contract (-> any/c integer?) s-x 'pos 'neg))
(define an-s (s 1))
(time
(for ([x (in-range 10000000)])
(f an-s)))
by about 1.9x
This commit is contained in:
Robby Findler
parent
126c090579
commit
bea67c0a39
|
|
@ -177,15 +177,19 @@
|
|||
[args
|
||||
(arrow:bad-number-of-results blame val rng-len args
|
||||
#:missing-party neg-party)]))))
|
||||
(define (wrap-call-with-values-and-range-checking stx assume-result-values?)
|
||||
(define (wrap-call-with-values-and-range-checking stx assume-result-values? do-tail-check?)
|
||||
(if rngs
|
||||
(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) ...))))
|
||||
(if do-tail-check?
|
||||
#`(let-values ([(rng-x ...) #,stx])
|
||||
(with-contract-continuation-mark
|
||||
(cons blame neg-party)
|
||||
(let ()
|
||||
post ...
|
||||
(values (rng-late-neg-projs rng-x neg-party) ...))))
|
||||
|
||||
#`(let-values ([(rng-x ...) #,stx])
|
||||
(values (rng-late-neg-projs rng-x neg-party) ...)))
|
||||
#`(call-with-values
|
||||
(λ () #,stx)
|
||||
#,rng-checker))
|
||||
|
|
@ -276,9 +280,11 @@
|
|||
inner-stx-gen
|
||||
#'(cons blame neg-party))
|
||||
(inner-stx-gen #'())))]
|
||||
[(basic-unsafe-return basic-unsafe-return/result-values-assumed)
|
||||
[(basic-unsafe-return
|
||||
basic-unsafe-return/result-values-assumed
|
||||
basic-unsafe-return/result-values-assumed/no-tail)
|
||||
(let ()
|
||||
(define (inner-stx-gen stuff assume-result-values?)
|
||||
(define (inner-stx-gen stuff assume-result-values? do-tail-check?)
|
||||
(define arg-checking-expressions
|
||||
(if need-apply?
|
||||
#'(this-param ... dom-projd-args ... opt+rest-uses)
|
||||
|
|
@ -301,27 +307,32 @@
|
|||
#`(apply val tmps ...)
|
||||
#`(val tmps ...))))]))
|
||||
(define the-call
|
||||
#`(with-continuation-mark arrow:tail-contract-key
|
||||
(list* neg-party blame-party-info #,rng-ctcs)
|
||||
#,the-call/no-tail-mark))
|
||||
(if do-tail-check?
|
||||
#`(with-continuation-mark arrow:tail-contract-key
|
||||
(list* neg-party blame-party-info #,rng-ctcs)
|
||||
#,the-call/no-tail-mark)
|
||||
the-call/no-tail-mark))
|
||||
(cond
|
||||
[(null? (syntax-e stuff)) ;; surely there must a better way
|
||||
the-call/no-tail-mark]
|
||||
[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?))
|
||||
#'(cons blame neg-party))
|
||||
(inner-stx-gen #'() assume-result-values?)))
|
||||
(list (mk-return #f) (mk-return #t)))]
|
||||
assume-result-values?
|
||||
do-tail-check?)]))
|
||||
(define (mk-return assume-result-values? do-tail-check?)
|
||||
(if do-tail-check?
|
||||
(if rngs
|
||||
(arrow:check-tail-contract
|
||||
rng-ctcs
|
||||
blame-party-info
|
||||
neg-party
|
||||
#'not-a-null
|
||||
(λ (x) (inner-stx-gen x assume-result-values? do-tail-check?))
|
||||
#'(cons blame neg-party))
|
||||
(inner-stx-gen #'() assume-result-values? do-tail-check?))
|
||||
(inner-stx-gen #'not-a-null assume-result-values? do-tail-check?)))
|
||||
(list (mk-return #f #t) (mk-return #t #t) (mk-return #t #f)))]
|
||||
[kwd-return
|
||||
(let* ([inner-stx-gen
|
||||
(if need-apply?
|
||||
|
|
@ -373,6 +384,10 @@
|
|||
#'(λ basic-params
|
||||
(let ()
|
||||
pre ... basic-unsafe-return/result-values-assumed))]
|
||||
[basic-unsafe-lambda/result-values-assumed/no-tail
|
||||
#'(λ basic-params
|
||||
(let ()
|
||||
pre ... basic-unsafe-return/result-values-assumed/no-tail))]
|
||||
[kwd-lambda-name (gen-id 'kwd-lambda)]
|
||||
[kwd-lambda #`(λ kwd-lam-params
|
||||
(with-contract-continuation-mark
|
||||
|
|
@ -386,6 +401,7 @@
|
|||
basic-lambda
|
||||
basic-unsafe-lambda
|
||||
basic-unsafe-lambda/result-values-assumed
|
||||
basic-unsafe-lambda/result-values-assumed/no-tail
|
||||
#,(and rngs (length rngs))
|
||||
void
|
||||
#,min-method-arity
|
||||
|
|
@ -397,7 +413,7 @@
|
|||
[(pair? req-keywords)
|
||||
#`(arrow:arity-checking-wrapper val
|
||||
blame neg-party
|
||||
void #t #f #f
|
||||
void #t #f #f #f
|
||||
kwd-lambda
|
||||
#,min-method-arity
|
||||
#,max-method-arity
|
||||
|
|
@ -408,7 +424,7 @@
|
|||
[else
|
||||
#`(arrow:arity-checking-wrapper val
|
||||
blame neg-party
|
||||
basic-lambda #t #f #f
|
||||
basic-lambda #t #f #f #f
|
||||
kwd-lambda
|
||||
#,min-method-arity
|
||||
#,max-method-arity
|
||||
|
|
|
|||
|
|
@ -90,7 +90,7 @@
|
|||
post post/desc)
|
||||
(define regular-args/no-any/c
|
||||
(for/list ([stx (in-list regular-args)])
|
||||
(syntax-case stx ()
|
||||
(syntax-case stx (any/c)
|
||||
[any/c #f]
|
||||
[else stx])))
|
||||
(define key (and (not pre) (not pre/desc)
|
||||
|
|
@ -980,7 +980,7 @@
|
|||
args-dealt-with)))))
|
||||
|
||||
(values (arrow:arity-checking-wrapper f blame neg-party
|
||||
interposition-proc #f interposition-proc #f #f
|
||||
interposition-proc #f interposition-proc #f #f #f
|
||||
min-arity max-arity
|
||||
min-arity max-arity
|
||||
mandatory-keywords optional-keywords)
|
||||
|
|
|
|||
|
|
@ -406,7 +406,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 #f #f
|
||||
basic-lambda-name #f #f #f #f
|
||||
void
|
||||
#,min-method-arity
|
||||
#,max-method-arity
|
||||
|
|
@ -418,7 +418,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 #f #f
|
||||
void #f #f #f #f
|
||||
kwd-lambda-name
|
||||
#,min-method-arity
|
||||
#,max-method-arity
|
||||
|
|
@ -431,7 +431,7 @@
|
|||
(let ([basic-lambda-name basic-lambda]
|
||||
[kwd-lambda-name kwd-lambda])
|
||||
(arity-checking-wrapper val blame neg-party
|
||||
basic-lambda-name #f #f #f
|
||||
basic-lambda-name #f #f #f #f
|
||||
kwd-lambda-name
|
||||
#,min-method-arity
|
||||
#,max-method-arity
|
||||
|
|
@ -449,7 +449,9 @@
|
|||
;; can't be chosen (because there are keywords involved)
|
||||
(define (arity-checking-wrapper val blame neg-party basic-lambda
|
||||
basic-unsafe-lambda
|
||||
basic-unsafe-lambda/result-values-assumed contract-result-val-count
|
||||
basic-unsafe-lambda/result-values-assumed
|
||||
basic-unsafe-lambda/result-values-assumed/no-tail
|
||||
contract-result-val-count
|
||||
kwd-lambda
|
||||
min-method-arity max-method-arity min-arity max-arity
|
||||
req-kwd opt-kwd)
|
||||
|
|
@ -462,7 +464,9 @@
|
|||
basic-unsafe-lambda/result-values-assumed
|
||||
(equal? contract-result-val-count
|
||||
(procedure-result-arity val)))
|
||||
(values basic-unsafe-lambda/result-values-assumed #t)]
|
||||
(if (simple-enough? val)
|
||||
(values basic-unsafe-lambda/result-values-assumed/no-tail #t)
|
||||
(values basic-unsafe-lambda/result-values-assumed #t))]
|
||||
[basic-unsafe-lambda
|
||||
(values basic-unsafe-lambda #t)]
|
||||
[else basic-lambda])
|
||||
|
|
@ -528,6 +532,12 @@
|
|||
(values proc #f)
|
||||
proc)]))
|
||||
|
||||
(define (simple-enough? f)
|
||||
(or (struct-accessor-procedure? f)
|
||||
(struct-constructor-procedure? f)
|
||||
(struct-predicate-procedure? f)
|
||||
(struct-mutator-procedure? f)))
|
||||
|
||||
(define (raise-wrong-number-of-args-error
|
||||
blame #:missing-party [missing-party #f] val
|
||||
args-len max-arity min-method-arity max-method-arity)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user