From 5dc368585f6dd2e17628156279b5198006f6243f Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Tue, 26 Jan 2016 16:08:34 -0600 Subject: [PATCH] Lift some blame and neg-party consing. To avoid doing it every time the contract is checked. --- .../contract/private/arrow-higher-order.rkt | 22 +++++++------ .../contract/private/arrow-val-first.rkt | 3 +- .../racket/contract/private/arrow.rkt | 32 +++++++++++-------- 3 files changed, 32 insertions(+), 25 deletions(-) diff --git a/racket/collects/racket/contract/private/arrow-higher-order.rkt b/racket/collects/racket/contract/private/arrow-higher-order.rkt index 9cbd404757..2ad27bc647 100644 --- a/racket/collects/racket/contract/private/arrow-higher-order.rkt +++ b/racket/collects/racket/contract/private/arrow-higher-order.rkt @@ -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 diff --git a/racket/collects/racket/contract/private/arrow-val-first.rkt b/racket/collects/racket/contract/private/arrow-val-first.rkt index bf0d4d5957..30a4832de9 100644 --- a/racket/collects/racket/contract/private/arrow-val-first.rkt +++ b/racket/collects/racket/contract/private/arrow-val-first.rkt @@ -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 diff --git a/racket/collects/racket/contract/private/arrow.rkt b/racket/collects/racket/contract/private/arrow.rkt index c4dd6bafbe..0b5fe8b124 100644 --- a/racket/collects/racket/contract/private/arrow.rkt +++ b/racket/collects/racket/contract/private/arrow.rkt @@ -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)]