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 ... mandatory-dom-kwd-proj ...
optional-dom-kwd-proj ... optional-dom-kwd-proj ...
rng-proj ...) rng-proj ...)
(define blame+neg-party (cons blame neg-party))
#,(create-chaperone #,(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 this-args
(for/list ([id (in-list (syntax->list #'(mandatory-dom-proj ...)))] (for/list ([id (in-list (syntax->list #'(mandatory-dom-proj ...)))]
[mandatory-dom-proj (in-list mandatory-dom-projs)]) [mandatory-dom-proj (in-list mandatory-dom-projs)])
@ -124,7 +125,7 @@
(if pre? "pre" "post") (if pre? "pre" "post")
condition-result)])) 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 val rng-ctcs
this-args this-args
doms opt-doms doms opt-doms
@ -134,6 +135,7 @@
rngs rngs
post post/desc) post post/desc)
(with-syntax ([blame blame] (with-syntax ([blame blame]
[blame+neg-party blame+neg-party]
[val val]) [val val])
(with-syntax ([(pre ...) (with-syntax ([(pre ...)
(cond (cond
@ -170,7 +172,7 @@
#'(case-lambda #'(case-lambda
[(rng-x ...) [(rng-x ...)
(with-contract-continuation-mark (with-contract-continuation-mark
(cons blame neg-party) blame+neg-party
(let () (let ()
post ... post ...
rng-results))] rng-results))]
@ -182,7 +184,7 @@
(if assume-result-values? (if assume-result-values?
#`(let-values ([(rng-x ...) #,stx]) #`(let-values ([(rng-x ...) #,stx])
(with-contract-continuation-mark (with-contract-continuation-mark
(cons blame neg-party) 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) ...))))
@ -297,7 +299,7 @@
arg-checking-expressions)]) arg-checking-expressions)])
#`(let-values ([(tmps ...) #`(let-values ([(tmps ...)
(with-contract-continuation-mark (with-contract-continuation-mark
(cons blame neg-party) blame+neg-party
(values #,@arg-checking-expressions))]) (values #,@arg-checking-expressions))])
#,(if need-apply? #,(if need-apply?
#`(apply val tmps ...) #`(apply val tmps ...)
@ -368,7 +370,7 @@
;; - stamourv ;; - stamourv
(with-syntax ([basic-lambda #'(λ basic-params (with-syntax ([basic-lambda #'(λ basic-params
(with-contract-continuation-mark (with-contract-continuation-mark
(cons blame neg-party) blame+neg-party
(let () (let ()
pre ... basic-return)))] pre ... basic-return)))]
[basic-unsafe-lambda [basic-unsafe-lambda
@ -386,13 +388,13 @@
[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
(cons blame neg-party) blame+neg-party
(let () (let ()
pre ... kwd-return)))]) pre ... kwd-return)))])
(cond (cond
[(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 blame+neg-party
basic-lambda basic-lambda
basic-unsafe-lambda basic-unsafe-lambda
basic-unsafe-lambda/result-values-assumed basic-unsafe-lambda/result-values-assumed
@ -407,7 +409,7 @@
'(opt-kwd ...))] '(opt-kwd ...))]
[(pair? req-keywords) [(pair? req-keywords)
#`(arrow:arity-checking-wrapper val #`(arrow:arity-checking-wrapper val
blame neg-party blame neg-party blame+neg-party
void #t #f #f #f void #t #f #f #f
kwd-lambda kwd-lambda
#,min-method-arity #,min-method-arity
@ -418,7 +420,7 @@
'(opt-kwd ...))] '(opt-kwd ...))]
[else [else
#`(arrow:arity-checking-wrapper val #`(arrow:arity-checking-wrapper val
blame neg-party blame neg-party blame+neg-party
basic-lambda #t #f #f #f basic-lambda #t #f #f #f
kwd-lambda kwd-lambda
#,min-method-arity #,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))] (for/list ([kwd (in-list (append mandatory-keywords optional-keywords))]
[kwd-proj (in-list (append mandatory-dom-kwd-projs optional-dom-kwd-projs))]) [kwd-proj (in-list (append mandatory-dom-kwd-projs optional-dom-kwd-projs))])
(cons kwd kwd-proj)))) (cons kwd kwd-proj))))
(define blame+neg-party (cons blame neg-party))
(define interposition-proc (define interposition-proc
(make-keyword-procedure (make-keyword-procedure
@ -1029,7 +1030,7 @@
(cons result-checker args-dealt-with) (cons result-checker args-dealt-with)
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 interposition-proc #f interposition-proc #f #f #f
min-arity max-arity min-arity max-arity
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))] (loop (cdr accepted) req-kwds (cdr opt-kwds))]
[else #f]))]))) [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 doms opt-doms dom-rest req-kwds opt-kwds
rngs rng-ctc-id) rngs rng-ctc-id)
(with-syntax ([blame blame] (with-syntax ([blame blame]
[neg-party neg-party] [neg-party neg-party]
[blame+neg-party blame+neg-party]
[val val]) [val val])
(with-syntax ([(pre ...) (with-syntax ([(pre ...)
(if pre (if pre
@ -281,7 +282,7 @@
#'(case-lambda #'(case-lambda
[(rng-x ...) [(rng-x ...)
(with-contract-continuation-mark (with-contract-continuation-mark
(cons blame neg-party) blame+neg-party
(let () (let ()
post ... post ...
rng-results))] rng-results))]
@ -391,13 +392,13 @@
;; noticeable in my measurements so far. ;; noticeable in my measurements so far.
;; - stamourv ;; - stamourv
(with-contract-continuation-mark (with-contract-continuation-mark
(cons blame neg-party) blame+neg-party
(let () (let ()
pre ... basic-return)))] pre ... basic-return)))]
[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
(cons blame neg-party) blame+neg-party
(let () (let ()
pre ... kwd-return)))]) pre ... kwd-return)))])
(with-syntax ([(basic-checker-name) (generate-temporaries '(basic-checker))]) (with-syntax ([(basic-checker-name) (generate-temporaries '(basic-checker))])
@ -405,7 +406,7 @@
[(and (null? req-keywords) (null? opt-keywords)) [(and (null? req-keywords) (null? opt-keywords))
#`(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 blame+neg-party
basic-lambda-name #f #f #f #f basic-lambda-name #f #f #f #f
void void
#,min-method-arity #,min-method-arity
@ -417,7 +418,7 @@
[(pair? req-keywords) [(pair? req-keywords)
#`(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 blame+neg-party
void #f #f #f #f void #f #f #f #f
kwd-lambda-name kwd-lambda-name
#,min-method-arity #,min-method-arity
@ -430,7 +431,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]
[kwd-lambda-name kwd-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 basic-lambda-name #f #f #f #f
kwd-lambda-name kwd-lambda-name
#,min-method-arity #,min-method-arity
@ -447,7 +448,7 @@
;; basic-unsafe-lambda or not; note that basic-unsafe-lambda might ;; basic-unsafe-lambda or not; note that basic-unsafe-lambda might
;; also be #t, 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 (define (arity-checking-wrapper val blame neg-party blame+neg-party 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 basic-unsafe-lambda/result-values-assumed/no-tail
@ -490,7 +491,7 @@
(raise-no-keywords-arg blame #:missing-party neg-party val kwds)) (raise-no-keywords-arg blame #:missing-party neg-party val kwds))
(λ (kwds kwd-args . args) (λ (kwds kwd-args . args)
(with-contract-continuation-mark (with-contract-continuation-mark
(cons blame neg-party) blame+neg-party
(let () (let ()
(define args-len (length args)) (define args-len (length args))
(unless (valid-number-of-args? args) (unless (valid-number-of-args? args)
@ -516,7 +517,7 @@
(if (null? req-kwd) (if (null? req-kwd)
(λ args (λ args
(with-contract-continuation-mark (with-contract-continuation-mark
(cons blame neg-party) blame+neg-party
(let () (let ()
(unless (valid-number-of-args? args) (unless (valid-number-of-args? args)
(define args-len (length args)) (define args-len (length args))
@ -895,8 +896,9 @@
[outer-lambda [outer-lambda
#`(lambda (blame neg-party blame-party-info val rng-ctc-x #`(lambda (blame neg-party blame-party-info val rng-ctc-x
dom-names ... kwd-names ... rng-names ...) dom-names ... kwd-names ... rng-names ...)
(define blame+neg-party (cons blame neg-party))
#,(create-chaperone #,(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 #'(this-params ...))
(syntax->list #'(dom-names ...)) null #f (syntax->list #'(dom-names ...)) null #f
(map list (syntax->list #'(kwds ...)) (map list (syntax->list #'(kwds ...))
@ -1086,8 +1088,9 @@
mandatory-dom-kwd-proj ... mandatory-dom-kwd-proj ...
optional-dom-kwd-proj ... optional-dom-kwd-proj ...
rng-proj ...) rng-proj ...)
(define blame+neg-party (cons blame neg-party))
#,(create-chaperone #,(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 #'(this-parameter ...))
(syntax->list #'(mandatory-dom-proj ...)) (syntax->list #'(mandatory-dom-proj ...))
(syntax->list #'(optional-dom-proj ...)) (syntax->list #'(optional-dom-proj ...))
@ -1370,6 +1373,7 @@
(define dom-blame (blame-add-context blame "the domain of" #:swap? #t)) (define dom-blame (blame-add-context blame "the domain of" #:swap? #t))
(define rng-blame (blame-add-range-context blame)) (define rng-blame (blame-add-range-context blame))
(λ (val neg-party) (λ (val neg-party)
(define blame+neg-party (cons blame neg-party))
(if (base-->d-rest-ctc ->d-stct) (if (base-->d-rest-ctc ->d-stct)
(check-procedure/more val (check-procedure/more val
(base-->d-mtd? ->d-stct) (base-->d-mtd? ->d-stct)
@ -1391,7 +1395,7 @@
(make-keyword-procedure (make-keyword-procedure
(λ (kwd-args kwd-arg-vals . raw-orig-args) (λ (kwd-args kwd-arg-vals . raw-orig-args)
(with-contract-continuation-mark (with-contract-continuation-mark
(cons blame neg-party) blame+neg-party
(let* ([orig-args (if (base-->d-mtd? ->d-stct) (let* ([orig-args (if (base-->d-mtd? ->d-stct)
(cdr raw-orig-args) (cdr raw-orig-args)
raw-orig-args)] raw-orig-args)]
@ -1421,7 +1425,7 @@
(if rng (if rng
(list (λ orig-results (list (λ orig-results
(with-contract-continuation-mark (with-contract-continuation-mark
(cons blame neg-party) blame+neg-party
(let* ([range-count (length rng)] (let* ([range-count (length rng)]
[post-args (append orig-results raw-orig-args)] [post-args (append orig-results raw-orig-args)]
[post-non-kwd-arg-count (+ non-kwd-ctc-count range-count)] [post-non-kwd-arg-count (+ non-kwd-ctc-count range-count)]