Instrumentation for the function, vector and struct contracts.
Allows a profiler to detect when we're checking a contract.
This commit is contained in:
Vincent St-Amour
parent
6014c78a55
commit
2ca31dbd3c
|
|
@ -518,14 +518,16 @@
|
|||
(list
|
||||
#`(case-lambda
|
||||
[#,(vector->list wrapper-ress)
|
||||
#,(add-wrapper-let
|
||||
(add-post-cond an-istx arg/res-to-indy-var #`(values #,@(vector->list wrapper-ress)))
|
||||
#f
|
||||
ordered-ress res-indices
|
||||
res-proj-vars indy-res-proj-vars
|
||||
wrapper-ress indy-res-vars
|
||||
arg/res-to-indy-var
|
||||
blame-var-table)]
|
||||
(with-continuation-mark
|
||||
contract-continuation-mark-key blame
|
||||
#,(add-wrapper-let
|
||||
(add-post-cond an-istx arg/res-to-indy-var #`(values #,@(vector->list wrapper-ress)))
|
||||
#f
|
||||
ordered-ress res-indices
|
||||
res-proj-vars indy-res-proj-vars
|
||||
wrapper-ress indy-res-vars
|
||||
arg/res-to-indy-var
|
||||
blame-var-table))]
|
||||
[args
|
||||
(bad-number-of-results blame val
|
||||
#,(vector-length wrapper-ress)
|
||||
|
|
@ -694,8 +696,13 @@
|
|||
val
|
||||
(make-keyword-procedure
|
||||
(λ (kwds kwd-args . args)
|
||||
(keyword-apply arg-checker kwds kwd-args args))
|
||||
(λ args (apply arg-checker args)))
|
||||
(with-continuation-mark
|
||||
contract-continuation-mark-key blame
|
||||
(keyword-apply arg-checker kwds kwd-args args)))
|
||||
(λ args
|
||||
(with-continuation-mark
|
||||
contract-continuation-mark-key blame
|
||||
(apply arg-checker args))))
|
||||
impersonator-prop:contracted ctc))))))
|
||||
|
||||
(begin-encourage-inline
|
||||
|
|
|
|||
|
|
@ -118,15 +118,19 @@ v4 todo:
|
|||
val
|
||||
(make-keyword-procedure
|
||||
(λ (kwds kwd-vals . args)
|
||||
#,(check-tail-contract
|
||||
#'(p-app-x ...)
|
||||
(list #'res-checker)
|
||||
(λ (s) #`(apply values #,@s kwd-vals args))))
|
||||
(with-continuation-mark
|
||||
contract-continuation-mark-key orig-blame
|
||||
#,(check-tail-contract
|
||||
#'(p-app-x ...)
|
||||
(list #'res-checker)
|
||||
(λ (s) #`(apply values #,@s kwd-vals args)))))
|
||||
(λ args
|
||||
#,(check-tail-contract
|
||||
#'(p-app-x ...)
|
||||
(list #'res-checker)
|
||||
(λ (s) #`(apply values #,@s args)))))
|
||||
(with-continuation-mark
|
||||
contract-continuation-mark-key orig-blame
|
||||
#,(check-tail-contract
|
||||
#'(p-app-x ...)
|
||||
(list #'res-checker)
|
||||
(λ (s) #`(apply values #,@s args))))))
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:application-mark (cons contract-key (list p-app-x ...))))))))
|
||||
(define ctc
|
||||
|
|
@ -244,8 +248,11 @@ v4 todo:
|
|||
#'(values/drop (rng-ctc rng-x) ...))])
|
||||
#'(case-lambda
|
||||
[(rng-x ...)
|
||||
post ...
|
||||
rng-results]
|
||||
(with-continuation-mark
|
||||
contract-continuation-mark-key blame
|
||||
(let ()
|
||||
post ...
|
||||
rng-results))]
|
||||
[args
|
||||
(bad-number-of-results blame val rng-len args)]))))
|
||||
null)])
|
||||
|
|
@ -321,9 +328,26 @@ v4 todo:
|
|||
(outer-stx-gen #'())
|
||||
(check-tail-contract #'(rng-ctc ...) #'(rng-checker-name ...) outer-stx-gen))))])
|
||||
(with-syntax ([basic-lambda-name (gensym 'basic-lambda)]
|
||||
[basic-lambda #'(λ basic-params pre ... basic-return)]
|
||||
[basic-lambda #'(λ basic-params
|
||||
;; Arrow contract domain checking is instrumented
|
||||
;; both here, and in `arity-checking-wrapper'.
|
||||
;; We need to instrument here, because sometimes
|
||||
;; a-c-w doesn't wrap, and just returns us.
|
||||
;; We need to instrument in a-c-w to count arity
|
||||
;; checking time.
|
||||
;; Overhead of double-wrapping has not been
|
||||
;; noticeable in my measurements so far.
|
||||
;; - stamourv
|
||||
(with-continuation-mark
|
||||
contract-continuation-mark-key blame
|
||||
(let ()
|
||||
pre ... basic-return)))]
|
||||
[kwd-lambda-name (gensym 'kwd-lambda)]
|
||||
[kwd-lambda #`(λ kwd-lam-params pre ... kwd-return)])
|
||||
[kwd-lambda #`(λ kwd-lam-params
|
||||
(with-continuation-mark
|
||||
contract-continuation-mark-key blame
|
||||
(let ()
|
||||
pre ... kwd-return)))])
|
||||
(with-syntax ([(basic-checker-name) (generate-temporaries '(basic-checker))])
|
||||
(cond
|
||||
[(and (null? req-keywords) (null? opt-keywords))
|
||||
|
|
@ -391,6 +415,9 @@ v4 todo:
|
|||
(raise-blame-error (blame-swap blame) val
|
||||
'(expected: "no keywords")))
|
||||
(λ (kwds kwd-args . args)
|
||||
(with-continuation-mark
|
||||
contract-continuation-mark-key blame
|
||||
(let ()
|
||||
(define args-len (length args))
|
||||
(unless (valid-number-of-args? args)
|
||||
(raise-blame-error (blame-swap blame) val
|
||||
|
|
@ -409,16 +436,19 @@ v4 todo:
|
|||
(raise-blame-error (blame-swap blame) val
|
||||
"received unexpected keyword argument ~a"
|
||||
k)))
|
||||
(keyword-apply kwd-lambda kwds kwd-args args))))
|
||||
(keyword-apply kwd-lambda kwds kwd-args args))))))
|
||||
(define basic-checker-name
|
||||
(if (null? req-kwd)
|
||||
(λ args
|
||||
(with-continuation-mark
|
||||
contract-continuation-mark-key blame
|
||||
(let ()
|
||||
(unless (valid-number-of-args? args)
|
||||
(define args-len (length args))
|
||||
(raise-blame-error (blame-swap blame) val
|
||||
'("received ~a argument~a" expected: "~a")
|
||||
args-len (if (= args-len 1) "" "s") arity-string))
|
||||
(apply basic-lambda args))
|
||||
(apply basic-lambda args))))
|
||||
(λ args
|
||||
(raise-blame-error (blame-swap blame) val
|
||||
"expected required keyword ~a"
|
||||
|
|
@ -1226,7 +1256,9 @@ v4 todo:
|
|||
val
|
||||
(make-keyword-procedure
|
||||
(λ (kwd-args kwd-arg-vals . raw-orig-args)
|
||||
(let* ([orig-args (if (base-->d-mtd? ->d-stct)
|
||||
(with-continuation-mark
|
||||
contract-continuation-mark-key blame
|
||||
(let* ([orig-args (if (base-->d-mtd? ->d-stct)
|
||||
(cdr raw-orig-args)
|
||||
raw-orig-args)]
|
||||
[this (and (base-->d-mtd? ->d-stct) (car raw-orig-args))]
|
||||
|
|
@ -1254,7 +1286,9 @@ v4 todo:
|
|||
[rng-underscore? (box? (base-->d-range ->d-stct))])
|
||||
(if rng
|
||||
(list (λ orig-results
|
||||
(let* ([range-count (length rng)]
|
||||
(with-continuation-mark
|
||||
contract-continuation-mark-key blame
|
||||
(let* ([range-count (length rng)]
|
||||
[post-args (append orig-results raw-orig-args)]
|
||||
[post-non-kwd-arg-count (+ non-kwd-ctc-count range-count)]
|
||||
[dep-post-args (build-dep-ctc-args post-non-kwd-arg-count
|
||||
|
|
@ -1290,7 +1324,7 @@ v4 todo:
|
|||
(car results)
|
||||
blame
|
||||
#f)
|
||||
(loop (cdr results) (cdr result-contracts)))]))))))
|
||||
(loop (cdr results) (cdr result-contracts)))])))))))
|
||||
null))
|
||||
|
||||
;; contracted keyword arguments
|
||||
|
|
@ -1332,7 +1366,7 @@ v4 todo:
|
|||
(error 'shouldnt\ happen))]
|
||||
[else (cons (invoke-dep-ctc (car non-kwd-ctcs) dep-pre-args (car args) blame #t)
|
||||
(loop (cdr args)
|
||||
(cdr non-kwd-ctcs)))])))))))
|
||||
(cdr non-kwd-ctcs)))]))))))))
|
||||
impersonator-prop:contracted ->d-stct)))))
|
||||
|
||||
(define (build-values-string desc dep-pre-args)
|
||||
|
|
@ -1633,11 +1667,13 @@ v4 todo:
|
|||
(λ (kwds kwd-args . args)
|
||||
(raise-blame-error blame f "expected no keywords, got keyword ~a" (car kwds)))
|
||||
(λ args
|
||||
(apply #,(let ([case-lam (syntax/loc stx (case-lambda [formals body] ...))])
|
||||
(if name
|
||||
#`(let ([#,name #,case-lam]) #,name)
|
||||
case-lam))
|
||||
args)))]
|
||||
(with-continuation-mark
|
||||
contract-continuation-mark-key blame
|
||||
(apply #,(let ([case-lam (syntax/loc stx (case-lambda [formals body] ...))])
|
||||
(if name
|
||||
#`(let ([#,name #,case-lam]) #,name)
|
||||
case-lam))
|
||||
args))))]
|
||||
[same-rngs (same-range-projections (list (list rng-proj-x ...) ...))])
|
||||
(if same-rngs
|
||||
(wrapper
|
||||
|
|
@ -1676,7 +1712,13 @@ v4 todo:
|
|||
"the domain of"
|
||||
#:swap? #t)))
|
||||
dom-ctcs+case-nums)
|
||||
(map (λ (f) (f rng-blame)) rng-ctcs)))
|
||||
(map (λ (f)
|
||||
(define p (f rng-blame))
|
||||
(lambda args
|
||||
(with-continuation-mark
|
||||
contract-continuation-mark-key blame
|
||||
(apply p args))))
|
||||
rng-ctcs)))
|
||||
(define (chk val mtd?)
|
||||
(cond
|
||||
[(null? specs)
|
||||
|
|
|
|||
|
|
@ -42,7 +42,9 @@
|
|||
eq-contract?
|
||||
eq-contract-val
|
||||
equal-contract?
|
||||
equal-contract-val)
|
||||
equal-contract-val
|
||||
|
||||
contract-continuation-mark-key)
|
||||
|
||||
(define (has-contract? v)
|
||||
(or (has-prop:contracted? v)
|
||||
|
|
@ -346,3 +348,9 @@
|
|||
(define (check-flat-contract predicate) (coerce-flat-contract 'flat-contract predicate))
|
||||
(define (build-flat-contract name pred [generate (make-generate-ctc-fail)])
|
||||
(make-predicate-contract name pred generate))
|
||||
|
||||
|
||||
;; Key used by the continuation mark that holds blame information for the current contract.
|
||||
;; That information is consumed by the contract profiler.
|
||||
(define contract-continuation-mark-key
|
||||
(make-continuation-mark-key 'contract))
|
||||
|
|
|
|||
|
|
@ -252,7 +252,10 @@
|
|||
(define-values (new-chaperone-args new-impersonate-args)
|
||||
(cond
|
||||
[(immutable? subcontract)
|
||||
(define projd (proj (sel v)))
|
||||
(define projd
|
||||
(with-continuation-mark
|
||||
contract-continuation-mark-key blame
|
||||
(proj (sel v))))
|
||||
(values (if (flat-contract? (indep-ctc subcontract))
|
||||
chaperone-args
|
||||
(list* sel
|
||||
|
|
@ -261,21 +264,36 @@
|
|||
impersonate-args)]
|
||||
[(lazy-immutable? subcontract)
|
||||
(values (list* sel
|
||||
(cache-λ (fld v) (proj v))
|
||||
(cache-λ (fld v)
|
||||
(with-continuation-mark
|
||||
contract-continuation-mark-key blame
|
||||
(proj v)))
|
||||
chaperone-args)
|
||||
impersonate-args)]
|
||||
[(mutable? subcontract)
|
||||
(if (impersonator-contract? (indep-ctc subcontract))
|
||||
(values chaperone-args
|
||||
(list* sel
|
||||
(λ (fld v) (proj v))
|
||||
(λ (fld v)
|
||||
(with-continuation-mark
|
||||
contract-continuation-mark-key blame
|
||||
(proj v)))
|
||||
(mutable-set subcontract)
|
||||
(λ (fld v) (mut-proj v))
|
||||
(λ (fld v)
|
||||
(with-continuation-mark
|
||||
contract-continuation-mark-key blame
|
||||
(mut-proj v)))
|
||||
impersonate-args))
|
||||
(values (list* sel
|
||||
(λ (fld v) (proj v))
|
||||
(λ (fld v)
|
||||
(with-continuation-mark
|
||||
contract-continuation-mark-key blame
|
||||
(proj v)))
|
||||
(mutable-set subcontract)
|
||||
(λ (fld v) (mut-proj v))
|
||||
(λ (fld v)
|
||||
(with-continuation-mark
|
||||
contract-continuation-mark-key blame
|
||||
(mut-proj v)))
|
||||
chaperone-args)
|
||||
impersonate-args))]
|
||||
[else
|
||||
|
|
@ -286,44 +304,70 @@
|
|||
(values (if (flat-contract? dep-ctc)
|
||||
chaperone-args
|
||||
(list* sel
|
||||
(λ (fld v) projd)
|
||||
(λ (fld v)
|
||||
(with-continuation-mark
|
||||
contract-continuation-mark-key blame
|
||||
projd))
|
||||
chaperone-args))
|
||||
impersonate-args)]
|
||||
[(dep-lazy-immutable? subcontract)
|
||||
(values (list* sel
|
||||
(cache-λ (fld v) (proj v))
|
||||
(cache-λ (fld v)
|
||||
(with-continuation-mark
|
||||
contract-continuation-mark-key blame
|
||||
(proj v)))
|
||||
chaperone-args)
|
||||
impersonate-args)]
|
||||
[(dep-mutable? subcontract)
|
||||
(define mut-proj (dep-ctc-blame-proj mut-blame))
|
||||
(if (eq? (dep-type subcontract) '#:impersonator)
|
||||
(values (list* sel
|
||||
(λ (fld v) (proj v))
|
||||
(λ (fld v)
|
||||
(with-continuation-mark
|
||||
contract-continuation-mark-key blame
|
||||
(proj v)))
|
||||
(dep-mutable-set subcontract)
|
||||
(λ (fld v) (mut-proj v))
|
||||
(λ (fld v)
|
||||
(with-continuation-mark
|
||||
contract-continuation-mark-key blame
|
||||
(mut-proj v)))
|
||||
chaperone-args)
|
||||
impersonate-args)
|
||||
(values chaperone-args
|
||||
(list* sel
|
||||
(λ (fld v) (proj v))
|
||||
(λ (fld v)
|
||||
(with-continuation-mark
|
||||
contract-continuation-mark-key blame
|
||||
(proj v)))
|
||||
(dep-mutable-set subcontract)
|
||||
(λ (fld v) (mut-proj v))
|
||||
(λ (fld v)
|
||||
(with-continuation-mark
|
||||
contract-continuation-mark-key blame
|
||||
(mut-proj v)))
|
||||
impersonate-args)))]
|
||||
[(dep-on-state-immutable? subcontract)
|
||||
(proj (sel v))
|
||||
(values (list* sel
|
||||
(λ (strct val) (build-dep-on-state-proj (base-struct/dc-subcontracts ctc) subcontract strct
|
||||
orig-indy-projs orig-indy-blames blame val))
|
||||
(λ (strct val)
|
||||
(with-continuation-mark
|
||||
contract-continuation-mark-key blame
|
||||
(build-dep-on-state-proj
|
||||
(base-struct/dc-subcontracts ctc) subcontract strct
|
||||
orig-indy-projs orig-indy-blames blame val)))
|
||||
chaperone-args)
|
||||
impersonate-args)]
|
||||
[(dep-on-state-mutable? subcontract)
|
||||
(proj (sel v))
|
||||
(define (get-chap-proc strct val)
|
||||
(build-dep-on-state-proj (base-struct/dc-subcontracts ctc) subcontract strct
|
||||
orig-indy-projs orig-indy-blames blame val))
|
||||
(with-continuation-mark
|
||||
contract-continuation-mark-key blame
|
||||
(build-dep-on-state-proj (base-struct/dc-subcontracts ctc) subcontract strct
|
||||
orig-indy-projs orig-indy-blames blame val)))
|
||||
(define (set-chap-proc strct val)
|
||||
(build-dep-on-state-proj (base-struct/dc-subcontracts ctc) subcontract strct
|
||||
orig-mut-indy-projs orig-mut-indy-blames mut-blame val))
|
||||
(with-continuation-mark
|
||||
contract-continuation-mark-key blame
|
||||
(build-dep-on-state-proj (base-struct/dc-subcontracts ctc) subcontract strct
|
||||
orig-mut-indy-projs orig-mut-indy-blames mut-blame val)))
|
||||
(if (eq? (dep-type subcontract) '#:impersonator)
|
||||
(values chaperone-args
|
||||
(list* sel
|
||||
|
|
|
|||
|
|
@ -101,8 +101,14 @@
|
|||
(λ (blame)
|
||||
(let ([elem-pos-proj ((contract-projection elem-ctc) (blame-add-context blame "an element of"))]
|
||||
[elem-neg-proj ((contract-projection elem-ctc) (blame-add-context blame "an element of" #:swap? #t))])
|
||||
(define checked-ref (λ (vec i val) (elem-pos-proj val)))
|
||||
(define checked-set (λ (vec i val) (elem-neg-proj val)))
|
||||
(define checked-ref (λ (vec i val)
|
||||
(with-continuation-mark
|
||||
contract-continuation-mark-key blame
|
||||
(elem-pos-proj val))))
|
||||
(define checked-set (λ (vec i val)
|
||||
(with-continuation-mark
|
||||
contract-continuation-mark-key blame
|
||||
(elem-neg-proj val))))
|
||||
(define raise-blame (λ (val . args)
|
||||
(apply raise-blame-error blame val args)))
|
||||
(λ (val)
|
||||
|
|
@ -211,9 +217,9 @@
|
|||
(λ (val)
|
||||
(and (vector? val)
|
||||
(cond
|
||||
[(eq? immutable #t) (immutable? val)]
|
||||
[(eq? immutable #f) (not (immutable? val))]
|
||||
[else #t])
|
||||
[(eq? immutable #t) (immutable? val)]
|
||||
[(eq? immutable #f) (not (immutable? val))]
|
||||
[else #t])
|
||||
(= (vector-length val) (length elem-ctcs))
|
||||
(for/and ([e (in-vector val)]
|
||||
[c (in-list elem-ctcs)])
|
||||
|
|
@ -229,11 +235,14 @@
|
|||
(λ (blame)
|
||||
(define blame+ctxt (blame-add-context blame "an element of"))
|
||||
(λ (val)
|
||||
(check-vector/c ctc val blame)
|
||||
(for ([e (in-vector val)]
|
||||
[c (in-list (base-vector/c-elems ctc))])
|
||||
(((contract-projection c) blame+ctxt) e))
|
||||
val)))))
|
||||
(with-continuation-mark
|
||||
contract-continuation-mark-key blame
|
||||
(begin
|
||||
(check-vector/c ctc val blame)
|
||||
(for ([e (in-vector val)]
|
||||
[c (in-list (base-vector/c-elems ctc))])
|
||||
(((contract-projection c) blame+ctxt) e))
|
||||
val)))))))
|
||||
|
||||
(define (vector/c-ho-projection vector-wrapper)
|
||||
(λ (ctc)
|
||||
|
|
@ -260,9 +269,13 @@
|
|||
(vector-wrapper
|
||||
val
|
||||
(λ (vec i val)
|
||||
((vector-ref elem-pos-projs i) val))
|
||||
(with-continuation-mark
|
||||
contract-continuation-mark-key blame
|
||||
((vector-ref elem-pos-projs i) val)))
|
||||
(λ (vec i val)
|
||||
((vector-ref elem-neg-projs i) val))
|
||||
(with-continuation-mark
|
||||
contract-continuation-mark-key blame
|
||||
((vector-ref elem-neg-projs i) val)))
|
||||
impersonator-prop:contracted ctc))))))))
|
||||
|
||||
(define-struct (chaperone-vector/c base-vector/c) ()
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user