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

When we know that the procedure getting a contract is "simple enough",

Browse Source 
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 2016-01-20 17:19:11 -06:00
parent 126c090579
commit bea67c0a39
3 changed files with 59 additions and 33 deletions
racket/collects/racket/contract/private
arrow-higher-order.rktarrow-val-first.rktarrow.rkt

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

@ -177,15 +177,19 @@
[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 assume-result-values?) (define (wrap-call-with-values-and-range-checking stx assume-result-values? do-tail-check?)
(if rngs (if rngs
(if assume-result-values? (if assume-result-values?
(if do-tail-check?
#`(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)
(let () (let ()
post ... post ...
(values (rng-late-neg-projs rng-x neg-party) ...)))) (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 #`(call-with-values
(λ () #,stx) (λ () #,stx)
#,rng-checker)) #,rng-checker))
@ -276,9 +280,11 @@
inner-stx-gen inner-stx-gen
#'(cons blame neg-party)) #'(cons blame neg-party))
(inner-stx-gen #'())))] (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 () (let ()
(define (inner-stx-gen stuff assume-result-values?) (define (inner-stx-gen stuff assume-result-values? do-tail-check?)
(define arg-checking-expressions (define arg-checking-expressions
(if need-apply? (if need-apply?
#'(this-param ... dom-projd-args ... opt+rest-uses) #'(this-param ... dom-projd-args ... opt+rest-uses)
@ -301,27 +307,32 @@
#`(apply val tmps ...) #`(apply val tmps ...)
#`(val tmps ...))))])) #`(val tmps ...))))]))
(define the-call (define the-call
(if do-tail-check?
#`(with-continuation-mark arrow:tail-contract-key #`(with-continuation-mark arrow:tail-contract-key
(list* neg-party blame-party-info #,rng-ctcs) (list* neg-party blame-party-info #,rng-ctcs)
#,the-call/no-tail-mark)) #,the-call/no-tail-mark)
the-call/no-tail-mark))
(cond (cond
[(null? (syntax-e stuff)) ;; surely there must a better way [(null? (syntax-e stuff)) ;; surely there must a better way
the-call/no-tail-mark] the-call/no-tail-mark]
[else [else
(wrap-call-with-values-and-range-checking (wrap-call-with-values-and-range-checking
the-call the-call
assume-result-values?)])) assume-result-values?
(define (mk-return assume-result-values?) do-tail-check?)]))
(define (mk-return assume-result-values? do-tail-check?)
(if do-tail-check?
(if rngs (if rngs
(arrow:check-tail-contract (arrow:check-tail-contract
rng-ctcs rng-ctcs
blame-party-info blame-party-info
neg-party neg-party
#'not-a-null #'not-a-null
(λ (x) (inner-stx-gen x assume-result-values?)) (λ (x) (inner-stx-gen x assume-result-values? do-tail-check?))
#'(cons blame neg-party)) #'(cons blame neg-party))
(inner-stx-gen #'() assume-result-values?))) (inner-stx-gen #'() assume-result-values? do-tail-check?))
(list (mk-return #f) (mk-return #t)))] (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 [kwd-return
(let* ([inner-stx-gen (let* ([inner-stx-gen
(if need-apply? (if need-apply?
@ -373,6 +384,10 @@
#'(λ basic-params #'(λ basic-params
(let () (let ()
pre ... basic-unsafe-return/result-values-assumed))] 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-name (gen-id 'kwd-lambda)]
[kwd-lambda #`(λ kwd-lam-params [kwd-lambda #`(λ kwd-lam-params
(with-contract-continuation-mark (with-contract-continuation-mark
@ -386,6 +401,7 @@
basic-lambda basic-lambda
basic-unsafe-lambda basic-unsafe-lambda
basic-unsafe-lambda/result-values-assumed basic-unsafe-lambda/result-values-assumed
basic-unsafe-lambda/result-values-assumed/no-tail
#,(and rngs (length rngs)) #,(and rngs (length rngs))
void void
#,min-method-arity #,min-method-arity
@ -397,7 +413,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 #f #f void #t #f #f #f
kwd-lambda kwd-lambda
#,min-method-arity #,min-method-arity
#,max-method-arity #,max-method-arity
@ -408,7 +424,7 @@
[else [else
#`(arrow:arity-checking-wrapper val #`(arrow:arity-checking-wrapper val
blame neg-party blame neg-party
basic-lambda #t #f #f basic-lambda #t #f #f #f
kwd-lambda kwd-lambda
#,min-method-arity #,min-method-arity
#,max-method-arity #,max-method-arity

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

@ -90,7 +90,7 @@
post post/desc) post post/desc)
(define regular-args/no-any/c (define regular-args/no-any/c
(for/list ([stx (in-list regular-args)]) (for/list ([stx (in-list regular-args)])
(syntax-case stx () (syntax-case stx (any/c)
[any/c #f] [any/c #f]
[else stx]))) [else stx])))
(define key (and (not pre) (not pre/desc) (define key (and (not pre) (not pre/desc)
@ -980,7 +980,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 #f #f interposition-proc #f interposition-proc #f #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)

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

@ -406,7 +406,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 #f #f basic-lambda-name #f #f #f #f
void void
#,min-method-arity #,min-method-arity
#,max-method-arity #,max-method-arity
@ -418,7 +418,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 #f #f void #f #f #f #f
kwd-lambda-name kwd-lambda-name
#,min-method-arity #,min-method-arity
#,max-method-arity #,max-method-arity
@ -431,7 +431,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 #f #f basic-lambda-name #f #f #f #f
kwd-lambda-name kwd-lambda-name
#,min-method-arity #,min-method-arity
#,max-method-arity #,max-method-arity
@ -449,7 +449,9 @@
;; 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 (define (arity-checking-wrapper val blame neg-party basic-lambda
basic-unsafe-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 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)
@ -462,7 +464,9 @@
basic-unsafe-lambda/result-values-assumed basic-unsafe-lambda/result-values-assumed
(equal? contract-result-val-count (equal? contract-result-val-count
(procedure-result-arity val))) (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 [basic-unsafe-lambda
(values basic-unsafe-lambda #t)] (values basic-unsafe-lambda #t)]
[else basic-lambda]) [else basic-lambda])
@ -528,6 +532,12 @@
(values proc #f) (values proc #f)
proc)])) 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 (define (raise-wrong-number-of-args-error
blame #:missing-party [missing-party #f] val blame #:missing-party [missing-party #f] val
args-len max-arity min-method-arity max-method-arity) args-len max-arity min-method-arity max-method-arity)