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

Add contract profiling instrumentation to combinators defined by TR.

Browse Source
This commit is contained in:
Vincent St-Amour 2016-01-26 11:20:43 -06:00
parent 2e7a045012
commit 32d0a97058
3 changed files with 66 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
typed-racket-lib/typed-racket/utils/any-wrap.rkt
View File

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

21
typed-racket-lib/typed-racket/utils/opaque-object.rkt
View File

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

33
typed-racket-lib/typed-racket/utils/sealing-contract.rkt
View File

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