diff --git a/collects/racket/contract/private/arr-i.rkt b/collects/racket/contract/private/arr-i.rkt index 7d7b908552..e7e76bcff9 100644 --- a/collects/racket/contract/private/arr-i.rkt +++ b/collects/racket/contract/private/arr-i.rkt @@ -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 diff --git a/collects/racket/contract/private/arrow.rkt b/collects/racket/contract/private/arrow.rkt index 5600e6f94b..96e4a98f03 100644 --- a/collects/racket/contract/private/arrow.rkt +++ b/collects/racket/contract/private/arrow.rkt @@ -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) diff --git a/collects/racket/contract/private/guts.rkt b/collects/racket/contract/private/guts.rkt index a544a5b374..3a6ede091e 100644 --- a/collects/racket/contract/private/guts.rkt +++ b/collects/racket/contract/private/guts.rkt @@ -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)) diff --git a/collects/racket/contract/private/struct-dc.rkt b/collects/racket/contract/private/struct-dc.rkt index 405e764139..a66ab28c0b 100644 --- a/collects/racket/contract/private/struct-dc.rkt +++ b/collects/racket/contract/private/struct-dc.rkt @@ -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 diff --git a/collects/racket/contract/private/vector.rkt b/collects/racket/contract/private/vector.rkt index 649461b7a9..ba8c78b287 100644 --- a/collects/racket/contract/private/vector.rkt +++ b/collects/racket/contract/private/vector.rkt @@ -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) ()