From d0d6d719afeceacefff2666a9a6d76a47d56ede5 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Tue, 15 Dec 2015 13:37:44 -0600 Subject: [PATCH] Abstract contract instrumentation. --- .../racket/contract/private/arr-i.rkt | 14 ++-- .../contract/private/arrow-higher-order.rkt | 33 ++++----- .../contract/private/arrow-val-first.rkt | 8 +- .../racket/contract/private/arrow.rkt | 52 ++++++------- .../racket/contract/private/case-arrow.rkt | 8 +- .../collects/racket/contract/private/guts.rkt | 7 ++ .../collects/racket/contract/private/misc.rkt | 11 +-- .../racket/contract/private/struct-dc.rkt | 74 ++++++++----------- .../racket/contract/private/vector.rkt | 28 +++---- 9 files changed, 107 insertions(+), 128 deletions(-) diff --git a/racket/collects/racket/contract/private/arr-i.rkt b/racket/collects/racket/contract/private/arr-i.rkt index d2bf3b4715..5c4c7a547f 100644 --- a/racket/collects/racket/contract/private/arr-i.rkt +++ b/racket/collects/racket/contract/private/arr-i.rkt @@ -784,8 +784,8 @@ evaluted left-to-right.) (list #`(case-lambda [#,(vector->list wrapper-ress) - (with-continuation-mark - contract-continuation-mark-key blame + (with-contract-continuation-mark + blame #,(add-wrapper-let (add-post-cond an-istx indy-arg-vars ordered-args indy-res-vars ordered-ress #`(values #,@(vector->list wrapper-ress))) @@ -886,13 +886,11 @@ evaluted left-to-right.) #,wrapper-body)]) (make-keyword-procedure (λ (kwds kwd-args . args) - (with-continuation-mark - contract-continuation-mark-key blame - (keyword-apply arg-checker kwds kwd-args args))) + (with-contract-continuation-mark + blame (keyword-apply arg-checker kwds kwd-args args))) (λ args - (with-continuation-mark - contract-continuation-mark-key blame - (apply arg-checker args))))) + (with-contract-continuation-mark + blame (apply arg-checker args))))) impersonator-prop:contracted ctc impersonator-prop:blame blame)))))) diff --git a/racket/collects/racket/contract/private/arrow-higher-order.rkt b/racket/collects/racket/contract/private/arrow-higher-order.rkt index 8015f6c108..071b0667c9 100644 --- a/racket/collects/racket/contract/private/arrow-higher-order.rkt +++ b/racket/collects/racket/contract/private/arrow-higher-order.rkt @@ -59,20 +59,20 @@ (define (check-pre-cond pre blame neg-party val) - (with-continuation-mark contract-continuation-mark-key - (cons blame neg-party) - (unless (pre) - (raise-blame-error (blame-swap blame) - #:missing-party neg-party - val "#:pre condition")))) + (with-contract-continuation-mark + (cons blame neg-party) + (unless (pre) + (raise-blame-error (blame-swap blame) + #:missing-party neg-party + val "#:pre condition")))) (define (check-post-cond post blame neg-party val) - (with-continuation-mark contract-continuation-mark-key - (cons blame neg-party) - (unless (post) - (raise-blame-error blame - #:missing-party neg-party - val "#:post condition")))) + (with-contract-continuation-mark + (cons blame neg-party) + (unless (post) + (raise-blame-error blame + #:missing-party neg-party + val "#:post condition")))) (define (check-pre-cond/desc post blame neg-party val) (handle-pre-post/desc-string #t post blame neg-party val)) @@ -167,8 +167,7 @@ ...)]) #'(case-lambda [(rng-x ...) - (with-continuation-mark - contract-continuation-mark-key + (with-contract-continuation-mark (cons blame neg-party) (let () post ... @@ -290,15 +289,13 @@ ;; Overhead of double-wrapping has not been ;; noticeable in my measurements so far. ;; - stamourv - (with-continuation-mark - contract-continuation-mark-key + (with-contract-continuation-mark (cons blame neg-party) (let () pre ... basic-return)))] [kwd-lambda-name (gen-id 'kwd-lambda)] [kwd-lambda #`(λ kwd-lam-params - (with-continuation-mark - contract-continuation-mark-key + (with-contract-continuation-mark (cons blame neg-party) (let () pre ... kwd-return)))]) diff --git a/racket/collects/racket/contract/private/arrow-val-first.rkt b/racket/collects/racket/contract/private/arrow-val-first.rkt index 1345678b5d..046750d58b 100644 --- a/racket/collects/racket/contract/private/arrow-val-first.rkt +++ b/racket/collects/racket/contract/private/arrow-val-first.rkt @@ -251,9 +251,9 @@ '()))) (define let-values-clause #`[#,(reverse args-vars) - (with-continuation-mark contract-continuation-mark-key - blame+neg-party - (values #,@(reverse args-expressions)))]) + (with-contract-continuation-mark + blame+neg-party + (values #,@(reverse args-expressions)))]) (define the-clause (if rngs @@ -270,7 +270,7 @@ [args (values args #,@(map (λ (x) #'#f) (syntax->list #'(res-x ...))))]))) - (with-continuation-mark contract-continuation-mark-key + (with-contract-continuation-mark blame+neg-party (cond [failed diff --git a/racket/collects/racket/contract/private/arrow.rkt b/racket/collects/racket/contract/private/arrow.rkt index ba27288f4e..38215e750f 100644 --- a/racket/collects/racket/contract/private/arrow.rkt +++ b/racket/collects/racket/contract/private/arrow.rkt @@ -100,19 +100,19 @@ val (make-keyword-procedure (λ (kwds kwd-vals . args) - (with-continuation-mark - contract-continuation-mark-key (cons orig-blame neg-party) - #,(check-tail-contract - #'(p-app-x ...) - (list #'res-checker) - (λ (s) #`(apply values #,@s kwd-vals args))))) + (with-contract-continuation-mark + (cons orig-blame neg-party) + #,(check-tail-contract + #'(p-app-x ...) + (list #'res-checker) + (λ (s) #`(apply values #,@s kwd-vals args))))) (λ args - (with-continuation-mark - contract-continuation-mark-key (cons orig-blame neg-party) - #,(check-tail-contract - #'(p-app-x ...) - (list #'res-checker) - (λ (s) #`(apply values #,@s args)))))) + (with-contract-continuation-mark + (cons orig-blame neg-party) + #,(check-tail-contract + #'(p-app-x ...) + (list #'res-checker) + (λ (s) #`(apply values #,@s args)))))) impersonator-prop:contracted ctc impersonator-prop:application-mark (cons contract-key (list p-app-x ...)))))))) @@ -251,8 +251,8 @@ #'(values/drop (rng-ctc rng-x neg-party) ...))]) #'(case-lambda [(rng-x ...) - (with-continuation-mark - contract-continuation-mark-key (cons blame neg-party) + (with-contract-continuation-mark + (cons blame neg-party) (let () post ... rng-results))] @@ -353,14 +353,14 @@ ;; Overhead of double-wrapping has not been ;; noticeable in my measurements so far. ;; - stamourv - (with-continuation-mark - contract-continuation-mark-key (cons blame neg-party) + (with-contract-continuation-mark + (cons blame neg-party) (let () pre ... basic-return)))] [kwd-lambda-name (gen-id 'kwd-lambda)] [kwd-lambda #`(λ kwd-lam-params - (with-continuation-mark - contract-continuation-mark-key (cons blame neg-party) + (with-contract-continuation-mark + (cons blame neg-party) (let () pre ... kwd-return)))]) (with-syntax ([(basic-checker-name) (generate-temporaries '(basic-checker))]) @@ -425,8 +425,8 @@ (λ (kwds kwd-args . args) (raise-no-keywords-arg blame #:missing-party neg-party val kwds)) (λ (kwds kwd-args . args) - (with-continuation-mark - contract-continuation-mark-key (cons blame neg-party) + (with-contract-continuation-mark + (cons blame neg-party) (let () (define args-len (length args)) (unless (valid-number-of-args? args) @@ -451,8 +451,8 @@ (define basic-checker-name (if (null? req-kwd) (λ args - (with-continuation-mark - contract-continuation-mark-key (cons blame neg-party) + (with-contract-continuation-mark + (cons blame neg-party) (let () (unless (valid-number-of-args? args) (define args-len (length args)) @@ -1309,8 +1309,8 @@ val (make-keyword-procedure (λ (kwd-args kwd-arg-vals . raw-orig-args) - (with-continuation-mark - contract-continuation-mark-key (cons blame neg-party) + (with-contract-continuation-mark + (cons blame neg-party) (let* ([orig-args (if (base-->d-mtd? ->d-stct) (cdr raw-orig-args) raw-orig-args)] @@ -1339,8 +1339,8 @@ [rng-underscore? (box? (base-->d-range ->d-stct))]) (if rng (list (λ orig-results - (with-continuation-mark - contract-continuation-mark-key (cons blame neg-party) + (with-contract-continuation-mark + (cons 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)] diff --git a/racket/collects/racket/contract/private/case-arrow.rkt b/racket/collects/racket/contract/private/case-arrow.rkt index 0097eb0305..0ba780525a 100644 --- a/racket/collects/racket/contract/private/case-arrow.rkt +++ b/racket/collects/racket/contract/private/case-arrow.rkt @@ -148,8 +148,7 @@ (make-keyword-procedure (raise-no-keywords-error f blame neg-party) (λ args - (with-continuation-mark contract-continuation-mark-key blame - (apply the-case-lam args))))) + (with-contract-continuation-mark blame (apply the-case-lam args))))) (define same-rngs (same-range-projections range-projections)) (if same-rngs (wrapper @@ -206,9 +205,8 @@ (cdr target) (let* ([p (f rng-blame)] [new (lambda args - (with-continuation-mark - contract-continuation-mark-key blame - (apply p args)))]) + (with-contract-continuation-mark + blame (apply p args)))]) (set! memo (cons (cons f new) memo)) new)))) rng-late-neg-ctcs))) diff --git a/racket/collects/racket/contract/private/guts.rkt b/racket/collects/racket/contract/private/guts.rkt index b98a86a782..cb2da0f3c7 100644 --- a/racket/collects/racket/contract/private/guts.rkt +++ b/racket/collects/racket/contract/private/guts.rkt @@ -49,6 +49,7 @@ char-in/c contract-continuation-mark-key + with-contract-continuation-mark (struct-out wrapped-extra-arg-arrow) contract-custom-write-property-proc @@ -603,3 +604,9 @@ ;; That information is consumed by the contract profiler. (define contract-continuation-mark-key (make-continuation-mark-key 'contract)) + +(define-syntax-rule (with-contract-continuation-mark payload code) + (begin + ;; (unless (or (pair? payload) (not (blame-missing-party? payload))) + ;; (error "internal error: missing blame party" payload)) + (with-continuation-mark contract-continuation-mark-key payload code))) diff --git a/racket/collects/racket/contract/private/misc.rkt b/racket/collects/racket/contract/private/misc.rkt index 0e48a68791..5d6bdc6726 100644 --- a/racket/collects/racket/contract/private/misc.rkt +++ b/racket/collects/racket/contract/private/misc.rkt @@ -1482,10 +1482,7 @@ (λ (blame) (define blame/c (blame-add-context blame "the parameter of")) (define (add-profiling f) - (λ (x) - (with-continuation-mark contract-continuation-mark-key - (cons blame #f) - (f x)))) + (λ (x) (with-contract-continuation-mark (cons blame #f) (f x)))) (define partial-neg-contract (add-profiling (in-proc (blame-swap blame/c)))) (define partial-pos-contract (add-profiling (out-proc blame/c))) (λ (val) @@ -1510,9 +1507,9 @@ [(parameter? val) (define (add-profiling f) (λ (x) - (with-continuation-mark contract-continuation-mark-key - (cons blame/c neg-party) - (f x neg-party)))) + (with-contract-continuation-mark + (cons blame/c neg-party) + (f x neg-party)))) (make-derived-parameter val (add-profiling in-proj) diff --git a/racket/collects/racket/contract/private/struct-dc.rkt b/racket/collects/racket/contract/private/struct-dc.rkt index 4d037705a8..6c13d96a31 100644 --- a/racket/collects/racket/contract/private/struct-dc.rkt +++ b/racket/collects/racket/contract/private/struct-dc.rkt @@ -343,18 +343,17 @@ (define-values (new-chaperone-args new-impersonate-args) (cond [(invariant? subcontract) - (unless (with-continuation-mark contract-continuation-mark-key - (cons blame neg-party) - (apply (invariant-dep-proc subcontract) dep-args)) + (unless (with-contract-continuation-mark + (cons blame neg-party) + (apply (invariant-dep-proc subcontract) dep-args)) (raise-invariant-blame-failure blame neg-party v (reverse dep-args) (reverse (invariant-fields subcontract)))) (values chaperone-args impersonate-args)] [(immutable? subcontract) - (define (chk fld v) (with-continuation-mark - contract-continuation-mark-key - (cons blame neg-party) - (proj v neg-party))) + (define (chk fld v) (with-contract-continuation-mark + (cons blame neg-party) + (proj v neg-party))) (chk #f (sel v)) ;; check the field contract immediately (values (if (flat-contract? (indep-ctc subcontract)) chaperone-args @@ -363,8 +362,7 @@ [(lazy-immutable? subcontract) (values (list* sel (cache-λ (fld v) - (with-continuation-mark - contract-continuation-mark-key + (with-contract-continuation-mark (cons blame neg-party) (proj v neg-party))) chaperone-args) @@ -374,27 +372,23 @@ (values chaperone-args (list* sel (λ (fld v) - (with-continuation-mark - contract-continuation-mark-key + (with-contract-continuation-mark (cons blame neg-party) (proj v neg-party))) (mutable-set subcontract) (λ (fld v) - (with-continuation-mark - contract-continuation-mark-key + (with-contract-continuation-mark (cons blame neg-party) (mut-proj v neg-party))) impersonate-args)) (values (list* sel (λ (fld v) - (with-continuation-mark - contract-continuation-mark-key + (with-contract-continuation-mark (cons blame neg-party) (proj v neg-party))) (mutable-set subcontract) (λ (fld v) - (with-continuation-mark - contract-continuation-mark-key + (with-contract-continuation-mark (cons blame neg-party) (mut-proj v neg-party))) chaperone-args) @@ -403,10 +397,9 @@ (define proj (dep-ctc-blame-proj blame)) (cond [(dep-immutable? subcontract) - (define (chk fld v) (with-continuation-mark - contract-continuation-mark-key - (cons blame neg-party) - (proj v neg-party))) + (define (chk fld v) (with-contract-continuation-mark + (cons blame neg-party) + (proj v neg-party))) (chk #f (sel v)) ;; check the field contract immediately (values (if (flat-contract? dep-ctc) chaperone-args @@ -415,8 +408,7 @@ [(dep-lazy-immutable? subcontract) (values (list* sel (cache-λ (fld v) - (with-continuation-mark - contract-continuation-mark-key + (with-contract-continuation-mark (cons blame neg-party) (proj v neg-party))) chaperone-args) @@ -426,14 +418,12 @@ (if (equal? (dep-type subcontract) '#:impersonator) (values (list* sel (λ (fld v) - (with-continuation-mark - contract-continuation-mark-key + (with-contract-continuation-mark (cons blame neg-party) (proj v neg-party))) (dep-mutable-set subcontract) (λ (fld v) - (with-continuation-mark - contract-continuation-mark-key + (with-contract-continuation-mark (cons blame neg-party) (mut-proj v neg-party))) chaperone-args) @@ -441,14 +431,12 @@ (values chaperone-args (list* sel (λ (fld v) - (with-continuation-mark - contract-continuation-mark-key + (with-contract-continuation-mark (cons blame neg-party) (proj v neg-party))) (dep-mutable-set subcontract) (λ (fld v) - (with-continuation-mark - contract-continuation-mark-key + (with-contract-continuation-mark (cons blame neg-party) (mut-proj v neg-party))) impersonate-args)))] @@ -456,8 +444,7 @@ (proj (sel v) neg-party) (values (list* sel (λ (strct val) - (with-continuation-mark - contract-continuation-mark-key + (with-contract-continuation-mark (cons blame neg-party) (build-dep-on-state-proj (base-struct/dc-subcontracts ctc) subcontract strct @@ -467,18 +454,17 @@ [(dep-on-state-mutable? subcontract) (proj (sel v) neg-party) (define (get-chap-proc strct val) - (with-continuation-mark - contract-continuation-mark-key + (with-contract-continuation-mark (cons blame neg-party) (build-dep-on-state-proj (base-struct/dc-subcontracts ctc) subcontract strct orig-indy-projs orig-indy-blames blame neg-party val))) (define (set-chap-proc strct val) - (with-continuation-mark contract-continuation-mark-key - (cons blame neg-party) - (build-dep-on-state-proj - (base-struct/dc-subcontracts ctc) subcontract strct - orig-mut-indy-projs orig-mut-indy-blames mut-blame neg-party val))) + (with-contract-continuation-mark + (cons blame neg-party) + (build-dep-on-state-proj + (base-struct/dc-subcontracts ctc) subcontract strct + orig-mut-indy-projs orig-mut-indy-blames mut-blame neg-party val))) (if (eq? (dep-type subcontract) '#:impersonator) (values chaperone-args (list* sel @@ -1432,15 +1418,15 @@ #:exp ;; if this is #t, when we have to avoid putting the property on here. (if (null? s-chap-code) - #`(with-continuation-mark - contract-continuation-mark-key #,(opt/info-blame opt/info) + #`(with-contract-continuation-mark + #,(opt/info-blame opt/info) (if (pred? #,(opt/info-val opt/info)) (begin #,@s-fo-code #,(opt/info-val opt/info)) (struct/dc-error blame #,(opt/info-val opt/info) 'struct-name))) - #`(with-continuation-mark - contract-continuation-mark-key #,(opt/info-blame opt/info) + #`(with-contract-continuation-mark + #,(opt/info-blame opt/info) (if (and (stronger-prop-pred? #,(opt/info-val opt/info)) (let ([v (stronger-prop-get #,(opt/info-val opt/info))]) (and (eq? (vector-ref v index) free-var) ...))) diff --git a/racket/collects/racket/contract/private/vector.rkt b/racket/collects/racket/contract/private/vector.rkt index 4adadcab78..264775c635 100644 --- a/racket/collects/racket/contract/private/vector.rkt +++ b/racket/collects/racket/contract/private/vector.rkt @@ -165,12 +165,12 @@ (define elem-neg-proj (vfp neg-blame)) (define checked-ref (λ (neg-party) (λ (vec i val) - (with-continuation-mark contract-continuation-mark-key + (with-contract-continuation-mark (cons pos-blame neg-party) (elem-pos-proj val neg-party))))) (define checked-set (λ (neg-party) (λ (vec i val) - (with-continuation-mark contract-continuation-mark-key + (with-contract-continuation-mark (cons neg-blame neg-party) (elem-neg-proj val neg-party))))) (cond @@ -221,13 +221,11 @@ [elem-neg-proj ((contract-projection elem-ctc) (blame-add-element-of-context blame #:swap? #t))]) (define checked-ref (λ (vec i val) - (with-continuation-mark - contract-continuation-mark-key blame - (elem-pos-proj val)))) + (with-contract-continuation-mark + blame (elem-pos-proj val)))) (define checked-set (λ (vec i val) - (with-continuation-mark - contract-continuation-mark-key blame - (elem-neg-proj val)))) + (with-contract-continuation-mark + blame (elem-neg-proj val)))) (define raise-blame (λ (val . args) (apply raise-blame-error blame val args))) (λ (val) @@ -403,8 +401,8 @@ (λ (blame) (define blame+ctxt (blame-add-element-of-context blame)) (λ (val) - (with-continuation-mark - contract-continuation-mark-key blame + (with-contract-continuation-mark + blame (begin (check-vector/c ctc val blame) (for ([e (in-vector val)] @@ -438,13 +436,11 @@ (vector-wrapper val (λ (vec i val) - (with-continuation-mark - contract-continuation-mark-key blame - ((vector-ref elem-pos-projs i) val))) + (with-contract-continuation-mark + blame ((vector-ref elem-pos-projs i) val))) (λ (vec i val) - (with-continuation-mark - contract-continuation-mark-key blame - ((vector-ref elem-neg-projs i) val))) + (with-contract-continuation-mark + blame ((vector-ref elem-neg-projs i) val))) impersonator-prop:contracted ctc impersonator-prop:blame blame))))))))