From 32d0a97058b797a8efe794336dde069156b98630 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Tue, 26 Jan 2016 11:20:43 -0600 Subject: [PATCH] Add contract profiling instrumentation to combinators defined by TR. --- .../typed-racket/utils/any-wrap.rkt | 43 +++++++++++++++---- .../typed-racket/utils/opaque-object.rkt | 21 +++++---- .../typed-racket/utils/sealing-contract.rkt | 33 ++++++++------ 3 files changed, 66 insertions(+), 31 deletions(-) diff --git a/typed-racket-lib/typed-racket/utils/any-wrap.rkt b/typed-racket-lib/typed-racket/utils/any-wrap.rkt index a59ae9d4..2e006690 100644 --- a/typed-racket-lib/typed-racket/utils/any-wrap.rkt +++ b/typed-racket-lib/typed-racket/utils/any-wrap.rkt @@ -69,6 +69,7 @@ "Attempted to use a higher-order value passed as `Any` in untyped code: ~v" v)) (define (wrap-struct neg-party s) + (define blame+neg-party (cons b neg-party)) (define (extract-functions struct-type) (define-values (sym init auto ref set! imms par skip?) (struct-type-info struct-type)) @@ -80,13 +81,17 @@ ;; field is immutable (values (list* (make-struct-field-accessor ref n) - (lambda (s v) (any-wrap/traverse v neg-party)) + (lambda (s v) (with-contract-continuation-mark + blame+neg-party + (any-wrap/traverse v neg-party))) res) (cdr imms)) ;; field is mutable (values (list* (make-struct-field-accessor ref n) - (lambda (s v) (any-wrap/traverse v neg-party)) + (lambda (s v) (with-contract-continuation-mark + blame+neg-party + (any-wrap/traverse v neg-party))) (make-struct-field-mutator set! n) (lambda (s v) (fail neg-party s)) res) @@ -99,6 +104,7 @@ (apply chaperone-struct s (extract-functions type))) (define (any-wrap/traverse v neg-party) + (define blame+neg-party (cons b neg-party)) (match v [(? base-val?) v] @@ -112,7 +118,10 @@ ([i (in-vector v)]) (any-wrap/traverse i neg-party)))] [(? box? (? immutable?)) (box-immutable (any-wrap/traverse (unbox v) neg-party))] [(? box?) (chaperone-box v - (lambda (v e) (any-wrap/traverse e neg-party)) + (lambda (v e) + (with-contract-continuation-mark + blame+neg-party + (any-wrap/traverse e neg-party))) (lambda (v e) (fail neg-party v)))] ;; fixme -- handling keys properly makes it not a chaperone ;; [(? hasheq? (? immutable?)) @@ -126,18 +135,30 @@ (for/hash ([(k v) (in-hash v)]) (values (any-wrap/traverse k neg-party) (any-wrap/traverse v neg-party)))] [(? vector?) (chaperone-vector v - (lambda (v i e) (any-wrap/traverse e neg-party)) + (lambda (v i e) + (with-contract-continuation-mark + blame+neg-party + (any-wrap/traverse e neg-party))) (lambda (v i e) (fail neg-party v)))] [(? hash?) (chaperone-hash v (lambda (h k) - (values k (lambda (h k v) (any-wrap/traverse v neg-party)))) ;; ref + (values k (lambda (h k v) + (with-contract-continuation-mark + blame+neg-party + (any-wrap/traverse v neg-party))))) ;; ref (lambda (h k n) (if (immutable? v) (values k n) (fail neg-party v))) ;; set (lambda (h v) v) ;; remove - (lambda (h k) (any-wrap/traverse k neg-party)))] ;; key - [(? evt?) (chaperone-evt v (lambda (e) (values e (λ (v) (any-wrap/traverse v neg-party)))))] + (lambda (h k) + (with-contract-continuation-mark + blame+neg-party + (any-wrap/traverse k neg-party))))] ;; key + [(? evt?) (chaperone-evt v (lambda (e) (values e (λ (v) + (with-contract-continuation-mark + blame+neg-party + (any-wrap/traverse v neg-party))))))] [(? set?) (for/set ([i (in-set v)]) (any-wrap/traverse i neg-party))] ;; could do something with generic sets here if they had @@ -153,12 +174,16 @@ (chaperone-procedure proc (λ (promise) - (values (λ (val) (any-wrap/traverse val neg-party)) + (values (λ (val) (with-contract-continuation-mark + blame+neg-party + (any-wrap/traverse val neg-party))) promise)))))] [(? channel?) ;;bg; Should be able to take `Any` from the channel, but can't put anything in (chaperone-channel v - (lambda (e) (values v (any-wrap/traverse v neg-party))) + (lambda (e) (with-contract-continuation-mark + blame+neg-party + (values v (any-wrap/traverse v neg-party)))) (lambda (e) (fail neg-party v)))] [_ (chaperone-struct v)])) any-wrap/traverse) diff --git a/typed-racket-lib/typed-racket/utils/opaque-object.rkt b/typed-racket-lib/typed-racket/utils/opaque-object.rkt index a5977303..911c7dc7 100644 --- a/typed-racket-lib/typed-racket/utils/opaque-object.rkt +++ b/typed-racket-lib/typed-racket/utils/opaque-object.rkt @@ -108,18 +108,23 @@ ;; method is typed (assuming that the caller is untyped or the receiving ;; object went through untyped code) (define (((restrict-typed->-late-neg-projection ctc) blame) val neg-party) + (define blame+neg-party (cons blame neg-party)) (chaperone-procedure val (make-keyword-procedure (λ (_ kw-args . rst) - (when (typed-method? val) - (raise-blame-error (blame-swap blame) val #:missing-party neg-party - "cannot call uncontracted typed method")) - (apply values kw-args rst)) + (with-contract-continuation-mark + blame+neg-party + (when (typed-method? val) + (raise-blame-error (blame-swap blame) val #:missing-party neg-party + "cannot call uncontracted typed method")) + (apply values kw-args rst))) (λ args - (when (typed-method? val) - (raise-blame-error (blame-swap blame) val #:missing-party neg-party - "cannot call uncontracted typed method")) - (apply values args))))) + (with-contract-continuation-mark + blame+neg-party + (when (typed-method? val) + (raise-blame-error (blame-swap blame) val #:missing-party neg-party + "cannot call uncontracted typed method")) + (apply values args)))))) (struct restrict-typed->/c () #:property prop:chaperone-contract diff --git a/typed-racket-lib/typed-racket/utils/sealing-contract.rkt b/typed-racket-lib/typed-racket/utils/sealing-contract.rkt index 65ac3caf..1733dffd 100644 --- a/typed-racket-lib/typed-racket/utils/sealing-contract.rkt +++ b/typed-racket-lib/typed-racket/utils/sealing-contract.rkt @@ -69,11 +69,14 @@ (raise-blame-error blame #:missing-party neg-party val '(expected "a procedure" given: "~e") val)) + (define blame+neg-party (cons blame neg-party)) ;; ok to return an unrelated function since this ;; is an impersonator contract (make-keyword-procedure (λ (kws kw-args . rst) - (keyword-apply (make-seal-function val neg-party) - kws kw-args rst)))))))) + (with-contract-continuation-mark + blame+neg-party + (keyword-apply (make-seal-function val neg-party) + kws kw-args rst))))))))) ;; represents a contract for each polymorphic seal/unseal corresponding ;; to a variable @@ -95,18 +98,20 @@ (define unsealed (seal/unseal-unsealed ctc)) (λ (blame) (λ (val neg-party) - (unless (class? val) - (raise-blame-error - blame #:missing-party neg-party val - '(expected: "a class" given: "~e") val)) - (match-define (list init field method) unsealed) - (if (equal? (blame-original? blame) - (seal/unseal-positive? ctc)) - (class-seal val sealing-key init field method - (inst-err val blame neg-party) - (subclass-err val blame neg-party)) - (class-unseal val sealing-key - (unseal-err val blame neg-party)))))))) + (with-contract-continuation-mark + (cons blame neg-party) + (unless (class? val) + (raise-blame-error + blame #:missing-party neg-party val + '(expected: "a class" given: "~e") val)) + (match-define (list init field method) unsealed) + (if (equal? (blame-original? blame) + (seal/unseal-positive? ctc)) + (class-seal val sealing-key init field method + (inst-err val blame neg-party) + (subclass-err val blame neg-party)) + (class-unseal val sealing-key + (unseal-err val blame neg-party))))))))) ;; error functions for use with class-seal, class-unseal (define ((inst-err val blame neg-party) cls)