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

Add instrumentation to contract system entry points.

Browse Source 
To catch checking that does not happen inside chaperones.
This commit is contained in:
Vincent St-Amour 2016-01-04 13:40:52 -06:00
parent 66d6de6394
commit 379a3dd110
3 changed files with 35 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
racket/collects/racket/contract/private/base.rkt
View File

@ -74,8 +74,12 @@
(if clnp #f neg) (if clnp #f neg)
#t)) #t))
(cond (cond
[clnp ((clnp blame) v neg)] [clnp (with-contract-continuation-mark
[else (((contract-projection c) blame) v)]))) (cons blame neg)
((clnp blame) v neg))]
[else (with-contract-continuation-mark
blame
(((contract-projection c) blame) v))])))
(define-syntax (invariant-assertion stx) (define-syntax (invariant-assertion stx)
(syntax-case stx () (syntax-case stx ()

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

@ -772,11 +772,24 @@
(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) ;; Instrumentation strategy:
;; - add instrumentation at entry points to the contract system:
;; - `contract` (`apply-contract`, really)
;; - `contract-out` (`do-partial-app`, really)
;; - all others go through one of the above
;; that instrumentation picks up "top-level" flat contracts (i.e., not part of
;; some higher-order contract) and the "eager" parts of higher-order contracts
;; - add instrumentation inside chaperones/impersonators created by projections
;; that instrumentation picks up the deferred work of higher-order contracts
;; - add instrumentation to `plus-one-arity-functions`
;; those perform checking, but don't rely on chaperones
;; they exist for -> and ->*, and are partially implemented for ->i
;; TODO once they're fully implemented for ->i, will need to instrument them
(define-syntax-rule (with-contract-continuation-mark payload code ...)
(begin (begin
;; ;; When debugging a missing blame party error, turn this on, then run ;; ;; When debugging a missing blame party error, turn this on, then run
;; ;; the contract test suite. It should find the problematic combinator. ;; ;; the contract test suite. It should find the problematic combinator.
;; (unless (or (pair? payload) (not (blame-missing-party? payload))) ;; (unless (or (pair? payload) (not (blame-missing-party? payload)))
;; (error "internal error: missing blame party" payload)) ;; (error "internal error: missing blame party" payload))
(with-continuation-mark contract-continuation-mark-key payload code))) (with-continuation-mark contract-continuation-mark-key payload
(let () code ...))))

17
racket/collects/racket/contract/private/provide.rkt
View File

@ -388,14 +388,19 @@
(λ () (contract-name ctc)) (λ () (contract-name ctc))
pos-module-source pos-module-source
#f #t)) #f #t))
(define neg-accepter ((p blme) val)) (with-contract-continuation-mark
(cons blme 'no-negative-party) ; we don't know the negative party yet
;; computing neg-accepter may involve some front-loaded checking. instrument
(define neg-accepter ((p blme) val))
;; we don't have the negative blame here, but we ;; check as much as we can while knowing only the
;; expect only positive failures from this; do the ;; contracted value (e.g., function arity)
;; check and then toss the results. ;; we don't have the negative blame here, but we
(neg-accepter 'incomplete-blame-from-provide.rkt) ;; expect only positive failures from this; do the
;; check and then toss the results.
(neg-accepter 'incomplete-blame-from-provide.rkt)
neg-accepter) neg-accepter))
(define-for-syntax (true-provide/contract provide-stx just-check-errors? who) (define-for-syntax (true-provide/contract provide-stx just-check-errors? who)
(syntax-case provide-stx () (syntax-case provide-stx ()