From 451ef1d37ef284c06b5046179c509946f3cecfda Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Wed, 13 Jan 2016 11:11:07 -0600 Subject: [PATCH] Add instrumentation for tail-marks-match?. --- .../tests/racket/contract/prof.rkt | 21 +++++++ .../contract/private/arrow-higher-order.rkt | 9 ++- .../racket/contract/private/arrow.rkt | 62 +++++++++++-------- .../racket/contract/private/case-arrow.rkt | 6 +- 4 files changed, 66 insertions(+), 32 deletions(-) diff --git a/pkgs/racket-test/tests/racket/contract/prof.rkt b/pkgs/racket-test/tests/racket/contract/prof.rkt index e990c32388..33ac45faa4 100644 --- a/pkgs/racket-test/tests/racket/contract/prof.rkt +++ b/pkgs/racket-test/tests/racket/contract/prof.rkt @@ -562,4 +562,25 @@ (eval '(require racket/stream)) (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) + ) diff --git a/racket/collects/racket/contract/private/arrow-higher-order.rkt b/racket/collects/racket/contract/private/arrow-higher-order.rkt index b46187c505..9d08118eb9 100644 --- a/racket/collects/racket/contract/private/arrow-higher-order.rkt +++ b/racket/collects/racket/contract/private/arrow-higher-order.rkt @@ -263,7 +263,8 @@ blame-party-info neg-party (list rng-checker) - inner-stx-gen) + inner-stx-gen + #'(cons blame neg-party)) (inner-stx-gen #'())))] [(basic-unsafe-return basic-unsafe-return/result-values-assumed) (let () @@ -300,7 +301,8 @@ blame-party-info neg-party #'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?))) (list (mk-return #f) (mk-return #t)))] [kwd-return @@ -328,7 +330,8 @@ blame-party-info neg-party (list rng-checker) - outer-stx-gen) + outer-stx-gen + #'(cons blame neg-party)) (outer-stx-gen #'()))))]) ;; Arrow contract domain checking is instrumented diff --git a/racket/collects/racket/contract/private/arrow.rkt b/racket/collects/racket/contract/private/arrow.rkt index 26b4a872da..44e5c0a13b 100644 --- a/racket/collects/racket/contract/private/arrow.rkt +++ b/racket/collects/racket/contract/private/arrow.rkt @@ -52,7 +52,7 @@ (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) (raise-argument-error 'check-tail-contract "identifier?" @@ -61,7 +61,7 @@ #`(call-with-immediate-continuation-mark tail-contract-key (λ (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 rng-checkers))))) @@ -69,25 +69,28 @@ ;; rng-ctc : (or/c #f (listof ctc)) ;; blame-party-info : (list/c pos-party boolean?[blame-swapped?]) ;; neg-party : neg-party -(define (tail-marks-match? m rng-ctcs blame-party-info neg-party) - (and m - rng-ctcs - (eq? (car m) neg-party) - (let ([mark-blame-part-info (cadr m)]) - (and (eq? (car mark-blame-part-info) (car blame-party-info)) - (eq? (cadr mark-blame-part-info) (cadr blame-party-info)))) - (let loop ([m (cddr m)] - [rng-ctcs rng-ctcs]) - (cond - [(null? m) (null? rng-ctcs)] - [(null? rng-ctcs) (null? m)] - [else - (define m1 (car m)) - (define rng-ctc1 (car rng-ctcs)) - (cond - [(eq? m1 rng-ctc1) (loop (cdr m) (cdr rng-ctcs))] - [(contract-struct-stronger? m1 rng-ctc1) (loop (cdr m) (cdr rng-ctcs))] - [else #f])])))) +;; 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 + rng-ctcs + (eq? (car m) neg-party) + (let ([mark-blame-part-info (cadr m)]) + (and (eq? (car mark-blame-part-info) (car blame-party-info)) + (eq? (cadr mark-blame-part-info) (cadr blame-party-info)))) + (let loop ([m (cddr m)] + [rng-ctcs rng-ctcs]) + (cond + [(null? m) (null? rng-ctcs)] + [(null? rng-ctcs) (null? m)] + [else + (define m1 (car m)) + (define rng-ctc1 (car rng-ctcs)) + (cond + [(eq? m1 rng-ctc1) (loop (cdr m) (cdr rng-ctcs))] + [(contract-struct-stronger? m1 rng-ctc1) (loop (cdr m) (cdr rng-ctcs))] + [else #f])]))))) ;; used as part of the information in the continuation mark ;; that records what is to be checked for a pending contract @@ -115,27 +118,30 @@ (λ (val neg-party) (check-is-a-procedure orig-blame neg-party val) (define (res-checker res-x ...) (values/drop (p-app-x res-x neg-party) ...)) + (define blame+neg-party (cons orig-blame neg-party)) (wrapper val (make-keyword-procedure (λ (kwds kwd-vals . args) (with-contract-continuation-mark - (cons orig-blame neg-party) + blame+neg-party #,(check-tail-contract #'rngs-list #'blame-party-info #'neg-party (list #'res-checker) - (λ (s) #`(apply values #,@s kwd-vals args))))) + (λ (s) #`(apply values #,@s kwd-vals args)) + #'blame+neg-party))) (λ args (with-contract-continuation-mark - (cons orig-blame neg-party) + blame+neg-party #,(check-tail-contract #'rngs-list #'blame-party-info #'neg-party (list #'res-checker) - (λ (s) #`(apply values #,@s args)))))) + (λ (s) #`(apply values #,@s args)) + #'blame+neg-party)))) impersonator-prop:contracted ctc impersonator-prop:application-mark (cons tail-contract-key (list neg-party blame-party-info rngs-x ...)))))))) @@ -346,7 +352,8 @@ blame-party-info #'neg-party #'(rng-checker-name ...) - inner-stx-gen)))] + inner-stx-gen + #'(cons blame neg-party))))] [kwd-return (let* ([inner-stx-gen (if need-apply-values? @@ -370,7 +377,8 @@ blame-party-info #'neg-party #'(rng-checker-name ...) - outer-stx-gen))))]) + outer-stx-gen + #'(cons blame neg-party)))))]) (with-syntax ([basic-lambda-name (gen-id 'basic-lambda)] [basic-lambda #'(λ basic-params ;; Arrow contract domain checking is instrumented diff --git a/racket/collects/racket/contract/private/case-arrow.rkt b/racket/collects/racket/contract/private/case-arrow.rkt index b644cf10a9..5e43e69e28 100644 --- a/racket/collects/racket/contract/private/case-arrow.rkt +++ b/racket/collects/racket/contract/private/case-arrow.rkt @@ -91,12 +91,14 @@ (λ (rng-checks) #`(apply values #,@rng-checks this-parameter ... (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 #'rng-ctcs-x blame-party-info neg-party rng-checkers (λ (rng-checks) #`(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 #`(apply values this-parameter ... (dom-proj-x dom-formals neg-party) ...