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
#`(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))))))

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

@ -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)))])

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

@ -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

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

@ -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)]

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

@ -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)))

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

@ -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)))

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

@ -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)

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

@ -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) ...)))

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

@ -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))))))))