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

Abstract contract instrumentation.

Browse Source
This commit is contained in:
Vincent St-Amour 2015-12-15 13:37:44 -06:00
parent b4afecab97
commit d0d6d719af
9 changed files with 107 additions and 128 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
racket/collects/racket/contract/private/arr-i.rkt
View File

@ -784,8 +784,8 @@ evaluted left-to-right.)
(list (list
#`(case-lambda #`(case-lambda
[#,(vector->list wrapper-ress) [#,(vector->list wrapper-ress)
(with-continuation-mark (with-contract-continuation-mark
contract-continuation-mark-key blame blame
#,(add-wrapper-let #,(add-wrapper-let
(add-post-cond an-istx indy-arg-vars ordered-args indy-res-vars ordered-ress (add-post-cond an-istx indy-arg-vars ordered-args indy-res-vars ordered-ress
#`(values #,@(vector->list wrapper-ress))) #`(values #,@(vector->list wrapper-ress)))
@ -886,13 +886,11 @@ evaluted left-to-right.)
#,wrapper-body)]) #,wrapper-body)])
(make-keyword-procedure (make-keyword-procedure
(λ (kwds kwd-args . args) (λ (kwds kwd-args . args)
(with-continuation-mark (with-contract-continuation-mark
contract-continuation-mark-key blame blame (keyword-apply arg-checker kwds kwd-args args)))
(keyword-apply arg-checker kwds kwd-args args)))
(λ args (λ args
(with-continuation-mark (with-contract-continuation-mark
contract-continuation-mark-key blame blame (apply arg-checker args)))))
(apply arg-checker args)))))
impersonator-prop:contracted ctc impersonator-prop:contracted ctc
impersonator-prop:blame blame)))))) impersonator-prop:blame blame))))))

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

@ -59,7 +59,7 @@
(define (check-pre-cond pre blame neg-party val) (define (check-pre-cond pre blame neg-party val)
(with-continuation-mark contract-continuation-mark-key (with-contract-continuation-mark
(cons blame neg-party) (cons blame neg-party)
(unless (pre) (unless (pre)
(raise-blame-error (blame-swap blame) (raise-blame-error (blame-swap blame)
@ -67,7 +67,7 @@
val "#:pre condition")))) val "#:pre condition"))))
(define (check-post-cond post blame neg-party val) (define (check-post-cond post blame neg-party val)
(with-continuation-mark contract-continuation-mark-key (with-contract-continuation-mark
(cons blame neg-party) (cons blame neg-party)
(unless (post) (unless (post)
(raise-blame-error blame (raise-blame-error blame
@ -167,8 +167,7 @@
...)]) ...)])
#'(case-lambda #'(case-lambda
[(rng-x ...) [(rng-x ...)
(with-continuation-mark (with-contract-continuation-mark
contract-continuation-mark-key
(cons blame neg-party) (cons blame neg-party)
(let () (let ()
post ... post ...
@ -290,15 +289,13 @@
;; Overhead of double-wrapping has not been ;; Overhead of double-wrapping has not been
;; noticeable in my measurements so far. ;; noticeable in my measurements so far.
;; - stamourv ;; - stamourv
(with-continuation-mark (with-contract-continuation-mark
contract-continuation-mark-key
(cons blame neg-party) (cons 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-continuation-mark (with-contract-continuation-mark
contract-continuation-mark-key
(cons blame neg-party) (cons blame neg-party)
(let () (let ()
pre ... kwd-return)))]) pre ... kwd-return)))])

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

@ -251,7 +251,7 @@
'()))) '())))
(define let-values-clause (define let-values-clause
#`[#,(reverse args-vars) #`[#,(reverse args-vars)
(with-continuation-mark contract-continuation-mark-key (with-contract-continuation-mark
blame+neg-party blame+neg-party
(values #,@(reverse args-expressions)))]) (values #,@(reverse args-expressions)))])
@ -270,7 +270,7 @@
[args [args
(values args #,@(map (λ (x) #'#f) (values args #,@(map (λ (x) #'#f)
(syntax->list #'(res-x ...))))]))) (syntax->list #'(res-x ...))))])))
(with-continuation-mark contract-continuation-mark-key (with-contract-continuation-mark
blame+neg-party blame+neg-party
(cond (cond
[failed [failed

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

@ -100,15 +100,15 @@
val val
(make-keyword-procedure (make-keyword-procedure
(λ (kwds kwd-vals . args) (λ (kwds kwd-vals . args)
(with-continuation-mark (with-contract-continuation-mark
contract-continuation-mark-key (cons orig-blame neg-party) (cons orig-blame neg-party)
#,(check-tail-contract #,(check-tail-contract
#'(p-app-x ...) #'(p-app-x ...)
(list #'res-checker) (list #'res-checker)
(λ (s) #`(apply values #,@s kwd-vals args))))) (λ (s) #`(apply values #,@s kwd-vals args)))))
(λ args (λ args
(with-continuation-mark (with-contract-continuation-mark
contract-continuation-mark-key (cons orig-blame neg-party) (cons orig-blame neg-party)
#,(check-tail-contract #,(check-tail-contract
#'(p-app-x ...) #'(p-app-x ...)
(list #'res-checker) (list #'res-checker)
@ -251,8 +251,8 @@
#'(values/drop (rng-ctc rng-x neg-party) ...))]) #'(values/drop (rng-ctc rng-x neg-party) ...))])
#'(case-lambda #'(case-lambda
[(rng-x ...) [(rng-x ...)
(with-continuation-mark (with-contract-continuation-mark
contract-continuation-mark-key (cons blame neg-party) (cons blame neg-party)
(let () (let ()
post ... post ...
rng-results))] rng-results))]
@ -353,14 +353,14 @@
;; Overhead of double-wrapping has not been ;; Overhead of double-wrapping has not been
;; noticeable in my measurements so far. ;; noticeable in my measurements so far.
;; - stamourv ;; - stamourv
(with-continuation-mark (with-contract-continuation-mark
contract-continuation-mark-key (cons blame neg-party) (cons 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-continuation-mark (with-contract-continuation-mark
contract-continuation-mark-key (cons blame neg-party) (cons 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))])
@ -425,8 +425,8 @@
(λ (kwds kwd-args . args) (λ (kwds kwd-args . args)
(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-continuation-mark (with-contract-continuation-mark
contract-continuation-mark-key (cons blame neg-party) (cons 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)
@ -451,8 +451,8 @@
(define basic-checker-name (define basic-checker-name
(if (null? req-kwd) (if (null? req-kwd)
(λ args (λ args
(with-continuation-mark (with-contract-continuation-mark
contract-continuation-mark-key (cons blame neg-party) (cons 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))
@ -1309,8 +1309,8 @@
val val
(make-keyword-procedure (make-keyword-procedure
(λ (kwd-args kwd-arg-vals . raw-orig-args) (λ (kwd-args kwd-arg-vals . raw-orig-args)
(with-continuation-mark (with-contract-continuation-mark
contract-continuation-mark-key (cons blame neg-party) (cons 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)]
@ -1339,8 +1339,8 @@
[rng-underscore? (box? (base-->d-range ->d-stct))]) [rng-underscore? (box? (base-->d-range ->d-stct))])
(if rng (if rng
(list (λ orig-results (list (λ orig-results
(with-continuation-mark (with-contract-continuation-mark
contract-continuation-mark-key (cons blame neg-party) (cons 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)]

8
racket/collects/racket/contract/private/case-arrow.rkt
View File

@ -148,8 +148,7 @@
(make-keyword-procedure (make-keyword-procedure
(raise-no-keywords-error f blame neg-party) (raise-no-keywords-error f blame neg-party)
(λ args (λ args
(with-continuation-mark contract-continuation-mark-key blame (with-contract-continuation-mark blame (apply the-case-lam args)))))
(apply the-case-lam args)))))
(define same-rngs (same-range-projections range-projections)) (define same-rngs (same-range-projections range-projections))
(if same-rngs (if same-rngs
(wrapper (wrapper
@ -206,9 +205,8 @@
(cdr target) (cdr target)
(let* ([p (f rng-blame)] (let* ([p (f rng-blame)]
[new (lambda args [new (lambda args
(with-continuation-mark (with-contract-continuation-mark
contract-continuation-mark-key blame blame (apply p args)))])
(apply p args)))])
(set! memo (cons (cons f new) memo)) (set! memo (cons (cons f new) memo))
new)))) new))))
rng-late-neg-ctcs))) rng-late-neg-ctcs)))

7
racket/collects/racket/contract/private/guts.rkt
View File

@ -49,6 +49,7 @@
char-in/c char-in/c
contract-continuation-mark-key contract-continuation-mark-key
with-contract-continuation-mark
(struct-out wrapped-extra-arg-arrow) (struct-out wrapped-extra-arg-arrow)
contract-custom-write-property-proc contract-custom-write-property-proc
@ -603,3 +604,9 @@
;; That information is consumed by the contract profiler. ;; That information is consumed by the contract profiler.
(define contract-continuation-mark-key (define contract-continuation-mark-key
(make-continuation-mark-key 'contract)) (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)))

7
racket/collects/racket/contract/private/misc.rkt
View File

@ -1482,10 +1482,7 @@
(λ (blame) (λ (blame)
(define blame/c (blame-add-context blame "the parameter of")) (define blame/c (blame-add-context blame "the parameter of"))
(define (add-profiling f) (define (add-profiling f)
(λ (x) (λ (x) (with-contract-continuation-mark (cons blame #f) (f x))))
(with-continuation-mark contract-continuation-mark-key
(cons blame #f)
(f x))))
(define partial-neg-contract (add-profiling (in-proc (blame-swap blame/c)))) (define partial-neg-contract (add-profiling (in-proc (blame-swap blame/c))))
(define partial-pos-contract (add-profiling (out-proc blame/c))) (define partial-pos-contract (add-profiling (out-proc blame/c)))
(λ (val) (λ (val)
@ -1510,7 +1507,7 @@
[(parameter? val) [(parameter? val)
(define (add-profiling f) (define (add-profiling f)
(λ (x) (λ (x)
(with-continuation-mark contract-continuation-mark-key (with-contract-continuation-mark
(cons blame/c neg-party) (cons blame/c neg-party)
(f x neg-party)))) (f x neg-party))))
(make-derived-parameter (make-derived-parameter

54
racket/collects/racket/contract/private/struct-dc.rkt
View File

@ -343,7 +343,7 @@
(define-values (new-chaperone-args new-impersonate-args) (define-values (new-chaperone-args new-impersonate-args)
(cond (cond
[(invariant? subcontract) [(invariant? subcontract)
(unless (with-continuation-mark contract-continuation-mark-key (unless (with-contract-continuation-mark
(cons blame neg-party) (cons blame neg-party)
(apply (invariant-dep-proc subcontract) dep-args)) (apply (invariant-dep-proc subcontract) dep-args))
(raise-invariant-blame-failure blame neg-party v (raise-invariant-blame-failure blame neg-party v
@ -351,8 +351,7 @@
(reverse (invariant-fields subcontract)))) (reverse (invariant-fields subcontract))))
(values chaperone-args impersonate-args)] (values chaperone-args impersonate-args)]
[(immutable? subcontract) [(immutable? subcontract)
(define (chk fld v) (with-continuation-mark (define (chk fld v) (with-contract-continuation-mark
contract-continuation-mark-key
(cons blame neg-party) (cons blame neg-party)
(proj v neg-party))) (proj v neg-party)))
(chk #f (sel v)) ;; check the field contract immediately (chk #f (sel v)) ;; check the field contract immediately
@ -363,8 +362,7 @@
[(lazy-immutable? subcontract) [(lazy-immutable? subcontract)
(values (list* sel (values (list* sel
(cache-λ (fld v) (cache-λ (fld v)
(with-continuation-mark (with-contract-continuation-mark
contract-continuation-mark-key
(cons blame neg-party) (cons blame neg-party)
(proj v neg-party))) (proj v neg-party)))
chaperone-args) chaperone-args)
@ -374,27 +372,23 @@
(values chaperone-args (values chaperone-args
(list* sel (list* sel
(λ (fld v) (λ (fld v)
(with-continuation-mark (with-contract-continuation-mark
contract-continuation-mark-key
(cons blame neg-party) (cons blame neg-party)
(proj v neg-party))) (proj v neg-party)))
(mutable-set subcontract) (mutable-set subcontract)
(λ (fld v) (λ (fld v)
(with-continuation-mark (with-contract-continuation-mark
contract-continuation-mark-key
(cons blame neg-party) (cons blame neg-party)
(mut-proj v neg-party))) (mut-proj v neg-party)))
impersonate-args)) impersonate-args))
(values (list* sel (values (list* sel
(λ (fld v) (λ (fld v)
(with-continuation-mark (with-contract-continuation-mark
contract-continuation-mark-key
(cons blame neg-party) (cons blame neg-party)
(proj v neg-party))) (proj v neg-party)))
(mutable-set subcontract) (mutable-set subcontract)
(λ (fld v) (λ (fld v)
(with-continuation-mark (with-contract-continuation-mark
contract-continuation-mark-key
(cons blame neg-party) (cons blame neg-party)
(mut-proj v neg-party))) (mut-proj v neg-party)))
chaperone-args) chaperone-args)
@ -403,8 +397,7 @@
(define proj (dep-ctc-blame-proj blame)) (define proj (dep-ctc-blame-proj blame))
(cond (cond
[(dep-immutable? subcontract) [(dep-immutable? subcontract)
(define (chk fld v) (with-continuation-mark (define (chk fld v) (with-contract-continuation-mark
contract-continuation-mark-key
(cons blame neg-party) (cons blame neg-party)
(proj v neg-party))) (proj v neg-party)))
(chk #f (sel v)) ;; check the field contract immediately (chk #f (sel v)) ;; check the field contract immediately
@ -415,8 +408,7 @@
[(dep-lazy-immutable? subcontract) [(dep-lazy-immutable? subcontract)
(values (list* sel (values (list* sel
(cache-λ (fld v) (cache-λ (fld v)
(with-continuation-mark (with-contract-continuation-mark
contract-continuation-mark-key
(cons blame neg-party) (cons blame neg-party)
(proj v neg-party))) (proj v neg-party)))
chaperone-args) chaperone-args)
@ -426,14 +418,12 @@
(if (equal? (dep-type subcontract) '#:impersonator) (if (equal? (dep-type subcontract) '#:impersonator)
(values (list* sel (values (list* sel
(λ (fld v) (λ (fld v)
(with-continuation-mark (with-contract-continuation-mark
contract-continuation-mark-key
(cons blame neg-party) (cons blame neg-party)
(proj v neg-party))) (proj v neg-party)))
(dep-mutable-set subcontract) (dep-mutable-set subcontract)
(λ (fld v) (λ (fld v)
(with-continuation-mark (with-contract-continuation-mark
contract-continuation-mark-key
(cons blame neg-party) (cons blame neg-party)
(mut-proj v neg-party))) (mut-proj v neg-party)))
chaperone-args) chaperone-args)
@ -441,14 +431,12 @@
(values chaperone-args (values chaperone-args
(list* sel (list* sel
(λ (fld v) (λ (fld v)
(with-continuation-mark (with-contract-continuation-mark
contract-continuation-mark-key
(cons blame neg-party) (cons blame neg-party)
(proj v neg-party))) (proj v neg-party)))
(dep-mutable-set subcontract) (dep-mutable-set subcontract)
(λ (fld v) (λ (fld v)
(with-continuation-mark (with-contract-continuation-mark
contract-continuation-mark-key
(cons blame neg-party) (cons blame neg-party)
(mut-proj v neg-party))) (mut-proj v neg-party)))
impersonate-args)))] impersonate-args)))]
@ -456,8 +444,7 @@
(proj (sel v) neg-party) (proj (sel v) neg-party)
(values (list* sel (values (list* sel
(λ (strct val) (λ (strct val)
(with-continuation-mark (with-contract-continuation-mark
contract-continuation-mark-key
(cons blame neg-party) (cons blame neg-party)
(build-dep-on-state-proj (build-dep-on-state-proj
(base-struct/dc-subcontracts ctc) subcontract strct (base-struct/dc-subcontracts ctc) subcontract strct
@ -467,14 +454,13 @@
[(dep-on-state-mutable? subcontract) [(dep-on-state-mutable? subcontract)
(proj (sel v) neg-party) (proj (sel v) neg-party)
(define (get-chap-proc strct val) (define (get-chap-proc strct val)
(with-continuation-mark (with-contract-continuation-mark
contract-continuation-mark-key
(cons blame neg-party) (cons blame neg-party)
(build-dep-on-state-proj (base-struct/dc-subcontracts ctc) subcontract strct (build-dep-on-state-proj (base-struct/dc-subcontracts ctc) subcontract strct
orig-indy-projs orig-indy-blames blame neg-party orig-indy-projs orig-indy-blames blame neg-party
val))) val)))
(define (set-chap-proc strct val) (define (set-chap-proc strct val)
(with-continuation-mark contract-continuation-mark-key (with-contract-continuation-mark
(cons blame neg-party) (cons blame neg-party)
(build-dep-on-state-proj (build-dep-on-state-proj
(base-struct/dc-subcontracts ctc) subcontract strct (base-struct/dc-subcontracts ctc) subcontract strct
@ -1432,15 +1418,15 @@
#:exp #:exp
;; if this is #t, when we have to avoid putting the property on here. ;; if this is #t, when we have to avoid putting the property on here.
(if (null? s-chap-code) (if (null? s-chap-code)
#`(with-continuation-mark #`(with-contract-continuation-mark
contract-continuation-mark-key #,(opt/info-blame opt/info) #,(opt/info-blame opt/info)
(if (pred? #,(opt/info-val opt/info)) (if (pred? #,(opt/info-val opt/info))
(begin (begin
#,@s-fo-code #,@s-fo-code
#,(opt/info-val opt/info)) #,(opt/info-val opt/info))
(struct/dc-error blame #,(opt/info-val opt/info) 'struct-name))) (struct/dc-error blame #,(opt/info-val opt/info) 'struct-name)))
#`(with-continuation-mark #`(with-contract-continuation-mark
contract-continuation-mark-key #,(opt/info-blame opt/info) #,(opt/info-blame opt/info)
(if (and (stronger-prop-pred? #,(opt/info-val opt/info)) (if (and (stronger-prop-pred? #,(opt/info-val opt/info))
(let ([v (stronger-prop-get #,(opt/info-val opt/info))]) (let ([v (stronger-prop-get #,(opt/info-val opt/info))])
(and (eq? (vector-ref v index) free-var) ...))) (and (eq? (vector-ref v index) free-var) ...)))

28
racket/collects/racket/contract/private/vector.rkt
View File

@ -165,12 +165,12 @@
(define elem-neg-proj (vfp neg-blame)) (define elem-neg-proj (vfp neg-blame))
(define checked-ref (λ (neg-party) (define checked-ref (λ (neg-party)
(λ (vec i val) (λ (vec i val)
(with-continuation-mark contract-continuation-mark-key (with-contract-continuation-mark
(cons pos-blame neg-party) (cons pos-blame neg-party)
(elem-pos-proj val neg-party))))) (elem-pos-proj val neg-party)))))
(define checked-set (λ (neg-party) (define checked-set (λ (neg-party)
(λ (vec i val) (λ (vec i val)
(with-continuation-mark contract-continuation-mark-key (with-contract-continuation-mark
(cons neg-blame neg-party) (cons neg-blame neg-party)
(elem-neg-proj val neg-party))))) (elem-neg-proj val neg-party)))))
(cond (cond
@ -221,13 +221,11 @@
[elem-neg-proj ((contract-projection elem-ctc) [elem-neg-proj ((contract-projection elem-ctc)
(blame-add-element-of-context blame #:swap? #t))]) (blame-add-element-of-context blame #:swap? #t))])
(define checked-ref (λ (vec i val) (define checked-ref (λ (vec i val)
(with-continuation-mark (with-contract-continuation-mark
contract-continuation-mark-key blame blame (elem-pos-proj val))))
(elem-pos-proj val))))
(define checked-set (λ (vec i val) (define checked-set (λ (vec i val)
(with-continuation-mark (with-contract-continuation-mark
contract-continuation-mark-key blame blame (elem-neg-proj val))))
(elem-neg-proj val))))
(define raise-blame (λ (val . args) (define raise-blame (λ (val . args)
(apply raise-blame-error blame val args))) (apply raise-blame-error blame val args)))
(λ (val) (λ (val)
@ -403,8 +401,8 @@
(λ (blame) (λ (blame)
(define blame+ctxt (blame-add-element-of-context blame)) (define blame+ctxt (blame-add-element-of-context blame))
(λ (val) (λ (val)
(with-continuation-mark (with-contract-continuation-mark
contract-continuation-mark-key blame blame
(begin (begin
(check-vector/c ctc val blame) (check-vector/c ctc val blame)
(for ([e (in-vector val)] (for ([e (in-vector val)]
@ -438,13 +436,11 @@
(vector-wrapper (vector-wrapper
val val
(λ (vec i val) (λ (vec i val)
(with-continuation-mark (with-contract-continuation-mark
contract-continuation-mark-key blame blame ((vector-ref elem-pos-projs i) val)))
((vector-ref elem-pos-projs i) val)))
(λ (vec i val) (λ (vec i val)
(with-continuation-mark (with-contract-continuation-mark
contract-continuation-mark-key blame blame ((vector-ref elem-neg-projs i) val)))
((vector-ref elem-neg-projs i) val)))
impersonator-prop:contracted ctc impersonator-prop:contracted ctc
impersonator-prop:blame blame)))))))) impersonator-prop:blame blame))))))))