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

Add instrumentation for tail-marks-match?.

Browse Source
This commit is contained in:
Vincent St-Amour 2016-01-13 11:11:07 -06:00
parent b8af007d94
commit 451ef1d37e
4 changed files with 66 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
pkgs/racket-test/tests/racket/contract/prof.rkt
View File

@ -562,4 +562,25 @@
(eval '(require racket/stream)) (eval '(require racket/stream))
(eval '(stream-first (contract (stream/c pos-blame?) (in-range 3) 'pos 'neg))))) (eval '(stream-first (contract (stream/c pos-blame?) (in-range 3) 'pos 'neg)))))
(test/spec-passed/result
'contract-marks62
'(let ()
(define marked? #f) ; check that we measure the cost of contract-stronger?
(define (make/c) ; the two have to not be eq?, otherwise contract-stronger? is not called
(make-contract #:late-neg-projection
(lambda (b)
(lambda (val neg-party)
(pos-blame? 'dummy)))
#:stronger
(lambda (c1 c2)
(when (pos-blame? 'dummy)
(set! marked? #t)
#t))))
((contract (-> pos-blame? (make/c))
(contract (-> pos-blame? (make/c)) values 'pos 'neg)
'pos 'neg)
3)
marked?)
#t)
) )

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

@ -263,7 +263,8 @@
blame-party-info blame-party-info
neg-party neg-party
(list rng-checker) (list rng-checker)
inner-stx-gen) inner-stx-gen
#'(cons blame neg-party))
(inner-stx-gen #'())))] (inner-stx-gen #'())))]
[(basic-unsafe-return basic-unsafe-return/result-values-assumed) [(basic-unsafe-return basic-unsafe-return/result-values-assumed)
(let () (let ()
@ -300,7 +301,8 @@
blame-party-info blame-party-info
neg-party neg-party
#'not-a-null #'not-a-null
(λ (x) (inner-stx-gen x assume-result-values?))) (λ (x) (inner-stx-gen x assume-result-values?))
#'(cons blame neg-party))
(inner-stx-gen #'() assume-result-values?))) (inner-stx-gen #'() assume-result-values?)))
(list (mk-return #f) (mk-return #t)))] (list (mk-return #f) (mk-return #t)))]
[kwd-return [kwd-return
@ -328,7 +330,8 @@
blame-party-info blame-party-info
neg-party neg-party
(list rng-checker) (list rng-checker)
outer-stx-gen) outer-stx-gen
#'(cons blame neg-party))
(outer-stx-gen #'()))))]) (outer-stx-gen #'()))))])
;; Arrow contract domain checking is instrumented ;; Arrow contract domain checking is instrumented

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

@ -52,7 +52,7 @@
(define tail-contract-key (gensym 'tail-contract-key)) (define tail-contract-key (gensym 'tail-contract-key))
(define-for-syntax (check-tail-contract rng-ctcs blame-party-info neg-party rng-checkers call-gen) (define-for-syntax (check-tail-contract rng-ctcs blame-party-info neg-party rng-checkers call-gen blame+neg-party)
(unless (identifier? rng-ctcs) (unless (identifier? rng-ctcs)
(raise-argument-error 'check-tail-contract (raise-argument-error 'check-tail-contract
"identifier?" "identifier?"
@ -61,7 +61,7 @@
#`(call-with-immediate-continuation-mark #`(call-with-immediate-continuation-mark
tail-contract-key tail-contract-key
(λ (m) (λ (m)
(if (tail-marks-match? m #,rng-ctcs #,blame-party-info #,neg-party) (if (tail-marks-match? m #,rng-ctcs #,blame-party-info #,neg-party #,blame+neg-party)
#,(call-gen #'()) #,(call-gen #'())
#,(call-gen rng-checkers))))) #,(call-gen rng-checkers)))))
@ -69,7 +69,10 @@
;; rng-ctc : (or/c #f (listof ctc)) ;; rng-ctc : (or/c #f (listof ctc))
;; blame-party-info : (list/c pos-party boolean?[blame-swapped?]) ;; blame-party-info : (list/c pos-party boolean?[blame-swapped?])
;; neg-party : neg-party ;; neg-party : neg-party
(define (tail-marks-match? m rng-ctcs blame-party-info neg-party) ;; blame+neg-party : (cons/c blame? neg-party)
(define (tail-marks-match? m rng-ctcs blame-party-info neg-party blame+neg-party)
(with-contract-continuation-mark
blame+neg-party
(and m (and m
rng-ctcs rng-ctcs
(eq? (car m) neg-party) (eq? (car m) neg-party)
@ -87,7 +90,7 @@
(cond (cond
[(eq? m1 rng-ctc1) (loop (cdr m) (cdr rng-ctcs))] [(eq? m1 rng-ctc1) (loop (cdr m) (cdr rng-ctcs))]
[(contract-struct-stronger? m1 rng-ctc1) (loop (cdr m) (cdr rng-ctcs))] [(contract-struct-stronger? m1 rng-ctc1) (loop (cdr m) (cdr rng-ctcs))]
[else #f])])))) [else #f])])))))
;; used as part of the information in the continuation mark ;; used as part of the information in the continuation mark
;; that records what is to be checked for a pending contract ;; that records what is to be checked for a pending contract
@ -115,27 +118,30 @@
(λ (val neg-party) (λ (val neg-party)
(check-is-a-procedure orig-blame neg-party val) (check-is-a-procedure orig-blame neg-party val)
(define (res-checker res-x ...) (values/drop (p-app-x res-x neg-party) ...)) (define (res-checker res-x ...) (values/drop (p-app-x res-x neg-party) ...))
(define blame+neg-party (cons orig-blame neg-party))
(wrapper (wrapper
val val
(make-keyword-procedure (make-keyword-procedure
(λ (kwds kwd-vals . args) (λ (kwds kwd-vals . args)
(with-contract-continuation-mark (with-contract-continuation-mark
(cons orig-blame neg-party) blame+neg-party
#,(check-tail-contract #,(check-tail-contract
#'rngs-list #'rngs-list
#'blame-party-info #'blame-party-info
#'neg-party #'neg-party
(list #'res-checker) (list #'res-checker)
(λ (s) #`(apply values #,@s kwd-vals args))))) (λ (s) #`(apply values #,@s kwd-vals args))
#'blame+neg-party)))
(λ args (λ args
(with-contract-continuation-mark (with-contract-continuation-mark
(cons orig-blame neg-party) blame+neg-party
#,(check-tail-contract #,(check-tail-contract
#'rngs-list #'rngs-list
#'blame-party-info #'blame-party-info
#'neg-party #'neg-party
(list #'res-checker) (list #'res-checker)
(λ (s) #`(apply values #,@s args)))))) (λ (s) #`(apply values #,@s args))
#'blame+neg-party))))
impersonator-prop:contracted ctc impersonator-prop:contracted ctc
impersonator-prop:application-mark impersonator-prop:application-mark
(cons tail-contract-key (list neg-party blame-party-info rngs-x ...)))))))) (cons tail-contract-key (list neg-party blame-party-info rngs-x ...))))))))
@ -346,7 +352,8 @@
blame-party-info blame-party-info
#'neg-party #'neg-party
#'(rng-checker-name ...) #'(rng-checker-name ...)
inner-stx-gen)))] inner-stx-gen
#'(cons blame neg-party))))]
[kwd-return [kwd-return
(let* ([inner-stx-gen (let* ([inner-stx-gen
(if need-apply-values? (if need-apply-values?
@ -370,7 +377,8 @@
blame-party-info blame-party-info
#'neg-party #'neg-party
#'(rng-checker-name ...) #'(rng-checker-name ...)
outer-stx-gen))))]) outer-stx-gen
#'(cons blame neg-party)))))])
(with-syntax ([basic-lambda-name (gen-id 'basic-lambda)] (with-syntax ([basic-lambda-name (gen-id 'basic-lambda)]
[basic-lambda #'(λ basic-params [basic-lambda #'(λ basic-params
;; Arrow contract domain checking is instrumented ;; Arrow contract domain checking is instrumented

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

@ -91,12 +91,14 @@
(λ (rng-checks) (λ (rng-checks)
#`(apply values #,@rng-checks this-parameter ... #`(apply values #,@rng-checks this-parameter ...
(dom-proj-x dom-formals neg-party) ... (dom-proj-x dom-formals neg-party) ...
(rst-proj-x rst-formal neg-party)))) (rst-proj-x rst-formal neg-party)))
#'(cons blame neg-party))
(check-tail-contract (check-tail-contract
#'rng-ctcs-x blame-party-info neg-party rng-checkers #'rng-ctcs-x blame-party-info neg-party rng-checkers
(λ (rng-checks) (λ (rng-checks)
#`(values/drop #,@rng-checks this-parameter ... #`(values/drop #,@rng-checks this-parameter ...
(dom-proj-x dom-formals neg-party) ...)))))] (dom-proj-x dom-formals neg-party) ...))
#'(cons blame neg-party))))]
[rst-ctc-expr [rst-ctc-expr
#`(apply values this-parameter ... #`(apply values this-parameter ...
(dom-proj-x dom-formals neg-party) ... (dom-proj-x dom-formals neg-party) ...