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

Lift some blame and neg-party consing.

Browse Source 
To avoid doing it every time the contract is checked.
This commit is contained in:
Vincent St-Amour 2016-01-26 16:08:34 -06:00
parent 9419778b1e
commit 5dc368585f
3 changed files with 32 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -47,8 +47,9 @@
mandatory-dom-kwd-proj ...
optional-dom-kwd-proj ...
rng-proj ...)
(define blame+neg-party (cons blame neg-party))
#,(create-chaperone
#'blame #'neg-party #'blame-party-info #'f #'rng-ctcs
#'blame #'neg-party #'blame+neg-party #'blame-party-info #'f #'rng-ctcs
this-args
(for/list ([id (in-list (syntax->list #'(mandatory-dom-proj ...)))]
[mandatory-dom-proj (in-list mandatory-dom-projs)])
@ -124,7 +125,7 @@
(if pre? "pre" "post")
condition-result)]))
(define-for-syntax (create-chaperone blame neg-party blame-party-info
(define-for-syntax (create-chaperone blame neg-party blame+neg-party blame-party-info
val rng-ctcs
this-args
doms opt-doms
@ -134,6 +135,7 @@
rngs
post post/desc)
(with-syntax ([blame blame]
[blame+neg-party blame+neg-party]
[val val])
(with-syntax ([(pre ...)
(cond
@ -170,7 +172,7 @@
#'(case-lambda
[(rng-x ...)
(with-contract-continuation-mark
(cons blame neg-party)
blame+neg-party
(let ()
post ...
rng-results))]
@ -182,7 +184,7 @@
(if assume-result-values?
#`(let-values ([(rng-x ...) #,stx])
(with-contract-continuation-mark
(cons blame neg-party)
blame+neg-party
(let ()
post ...
(values (rng-late-neg-projs rng-x neg-party) ...))))
@ -297,7 +299,7 @@
arg-checking-expressions)])
#`(let-values ([(tmps ...)
(with-contract-continuation-mark
(cons blame neg-party)
blame+neg-party
(values #,@arg-checking-expressions))])
#,(if need-apply?
#`(apply val tmps ...)
@ -368,7 +370,7 @@
;; - stamourv
(with-syntax ([basic-lambda #'(λ basic-params
(with-contract-continuation-mark
(cons blame neg-party)
blame+neg-party
(let ()
pre ... basic-return)))]
[basic-unsafe-lambda
@ -386,13 +388,13 @@
[kwd-lambda-name (gen-id 'kwd-lambda)]
[kwd-lambda #`(λ kwd-lam-params
(with-contract-continuation-mark
(cons blame neg-party)
blame+neg-party
(let ()
pre ... kwd-return)))])
(cond
[(and (null? req-keywords) (null? opt-keywords))
#`(arrow:arity-checking-wrapper val
blame neg-party
blame neg-party blame+neg-party
basic-lambda
basic-unsafe-lambda
basic-unsafe-lambda/result-values-assumed
@ -407,7 +409,7 @@
'(opt-kwd ...))]
[(pair? req-keywords)
#`(arrow:arity-checking-wrapper val
blame neg-party
blame neg-party blame+neg-party
void #t #f #f #f
kwd-lambda
#,min-method-arity
@ -418,7 +420,7 @@
'(opt-kwd ...))]
[else
#`(arrow:arity-checking-wrapper val
blame neg-party
blame neg-party blame+neg-party
basic-lambda #t #f #f #f
kwd-lambda
#,min-method-arity

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

@ -988,6 +988,7 @@
(for/list ([kwd (in-list (append mandatory-keywords optional-keywords))]
[kwd-proj (in-list (append mandatory-dom-kwd-projs optional-dom-kwd-projs))])
(cons kwd kwd-proj))))
(define blame+neg-party (cons blame neg-party))
(define interposition-proc
(make-keyword-procedure
@ -1029,7 +1030,7 @@
(cons result-checker args-dealt-with)
args-dealt-with)))))
(values (arrow:arity-checking-wrapper f blame neg-party
(values (arrow:arity-checking-wrapper f blame neg-party blame+neg-party
interposition-proc #f interposition-proc #f #f #f
min-arity max-arity
min-arity max-arity

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

@ -230,11 +230,12 @@
(loop (cdr accepted) req-kwds (cdr opt-kwds))]
[else #f]))])))
(define-for-syntax (create-chaperone blame neg-party blame-party-info val pre post this-args
(define-for-syntax (create-chaperone blame neg-party blame+neg-party blame-party-info val pre post this-args
doms opt-doms dom-rest req-kwds opt-kwds
rngs rng-ctc-id)
(with-syntax ([blame blame]
[neg-party neg-party]
[blame+neg-party blame+neg-party]
[val val])
(with-syntax ([(pre ...)
(if pre
@ -281,7 +282,7 @@
#'(case-lambda
[(rng-x ...)
(with-contract-continuation-mark
(cons blame neg-party)
blame+neg-party
(let ()
post ...
rng-results))]
@ -391,13 +392,13 @@
;; noticeable in my measurements so far.
;; - stamourv
(with-contract-continuation-mark
(cons blame neg-party)
blame+neg-party
(let ()
pre ... basic-return)))]
[kwd-lambda-name (gen-id 'kwd-lambda)]
[kwd-lambda #`(λ kwd-lam-params
(with-contract-continuation-mark
(cons blame neg-party)
blame+neg-party
(let ()
pre ... kwd-return)))])
(with-syntax ([(basic-checker-name) (generate-temporaries '(basic-checker))])
@ -405,7 +406,7 @@
[(and (null? req-keywords) (null? opt-keywords))
#`(let-values ([(rng-checker-name ...) (values/drop rng-checker ...)])
(let ([basic-lambda-name basic-lambda])
(arity-checking-wrapper val blame neg-party
(arity-checking-wrapper val blame neg-party blame+neg-party
basic-lambda-name #f #f #f #f
void
#,min-method-arity
@ -417,7 +418,7 @@
[(pair? req-keywords)
#`(let-values ([(rng-checker-name ...) (values/drop rng-checker ...)])
(let ([kwd-lambda-name kwd-lambda])
(arity-checking-wrapper val blame neg-party
(arity-checking-wrapper val blame neg-party blame+neg-party
void #f #f #f #f
kwd-lambda-name
#,min-method-arity
@ -430,7 +431,7 @@
#`(let-values ([(rng-checker-name ...) (values/drop rng-checker ...)])
(let ([basic-lambda-name basic-lambda]
[kwd-lambda-name kwd-lambda])
(arity-checking-wrapper val blame neg-party
(arity-checking-wrapper val blame neg-party blame+neg-party
basic-lambda-name #f #f #f #f
kwd-lambda-name
#,min-method-arity
@ -447,7 +448,7 @@
;; basic-unsafe-lambda or not; note that basic-unsafe-lambda might
;; 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
(define (arity-checking-wrapper val blame neg-party blame+neg-party basic-lambda
basic-unsafe-lambda
basic-unsafe-lambda/result-values-assumed
basic-unsafe-lambda/result-values-assumed/no-tail
@ -490,7 +491,7 @@
(raise-no-keywords-arg blame #:missing-party neg-party val kwds))
(λ (kwds kwd-args . args)
(with-contract-continuation-mark
(cons blame neg-party)
blame+neg-party
(let ()
(define args-len (length args))
(unless (valid-number-of-args? args)
@ -516,7 +517,7 @@
(if (null? req-kwd)
(λ args
(with-contract-continuation-mark
(cons blame neg-party)
blame+neg-party
(let ()
(unless (valid-number-of-args? args)
(define args-len (length args))
@ -895,8 +896,9 @@
[outer-lambda
#`(lambda (blame neg-party blame-party-info val rng-ctc-x
dom-names ... kwd-names ... rng-names ...)
(define blame+neg-party (cons blame neg-party))
#,(create-chaperone
#'blame #'neg-party #'blame-party-info #'val #f #f
#'blame #'neg-party #'blame+neg-party #'blame-party-info #'val #f #f
(syntax->list #'(this-params ...))
(syntax->list #'(dom-names ...)) null #f
(map list (syntax->list #'(kwds ...))
@ -1086,8 +1088,9 @@
mandatory-dom-kwd-proj ...
optional-dom-kwd-proj ...
rng-proj ...)
(define blame+neg-party (cons blame neg-party))
#,(create-chaperone
#'blame #'neg-party #'blame-party-info #'f pre post
#'blame #'neg-party #'blame+neg-party #'blame-party-info #'f pre post
(syntax->list #'(this-parameter ...))
(syntax->list #'(mandatory-dom-proj ...))
(syntax->list #'(optional-dom-proj ...))
@ -1370,6 +1373,7 @@
(define dom-blame (blame-add-context blame "the domain of" #:swap? #t))
(define rng-blame (blame-add-range-context blame))
(λ (val neg-party)
(define blame+neg-party (cons blame neg-party))
(if (base-->d-rest-ctc ->d-stct)
(check-procedure/more val
(base-->d-mtd? ->d-stct)
@ -1391,7 +1395,7 @@
(make-keyword-procedure
(λ (kwd-args kwd-arg-vals . raw-orig-args)
(with-contract-continuation-mark
(cons blame neg-party)
blame+neg-party
(let* ([orig-args (if (base-->d-mtd? ->d-stct)
(cdr raw-orig-args)
raw-orig-args)]
@ -1421,7 +1425,7 @@
(if rng
(list (λ orig-results
(with-contract-continuation-mark
(cons blame neg-party)
blame+neg-party
(let* ([range-count (length rng)]
[post-args (append orig-results raw-orig-args)]
[post-non-kwd-arg-count (+ non-kwd-ctc-count range-count)]