commit 3baaab511f7f903654af0837c4a1862bfad835c7 parent 024f90b9715012e07c294fd3a78121700db1654d Author: Vincent St-Amour <stamourv@racket-lang.org> Date: Tue, 26 Jan 2016 15:28:41 -0600 Add contract profiling instrumentation. Diffstat:
| M | kw-utils/kw-hash/contract.rkt | | | 45 | ++++++++++++++++++++++++--------------------- |
1 file changed, 24 insertions(+), 21 deletions(-)
diff --git a/kw-utils/kw-hash/contract.rkt b/kw-utils/kw-hash/contract.rkt @@ -67,27 +67,30 @@ (chaperone-procedure f (keyword-lambda (kws kw-args . args) - (check-length blame f (length args) - (if rest-wrapper - (arity-at-least n) - n)) - (define args* - (map app arg-wrappers (take args n))) - (define rest* - (and rest-wrapper (rest-wrapper (drop args n)))) - (define args+rest* - (if rest-wrapper - (append args* rest*) - args*)) - (define kw-hash* - (kws-wrapper (keyword-app-make-kw-hash kws kw-args))) - ;; kw-args* has to be in the same order as kw-args - (define kw-args* - (map-hash-ref kw-hash* kws)) - (if (null? kw-args*) - ;; if no keywords were passed in, don't include them - (apply values args+rest*) - (apply values kw-args* args+rest*)))))) + (with-continuation-mark + contract-continuation-mark-key blame + (let () + (check-length blame f (length args) + (if rest-wrapper + (arity-at-least n) + n)) + (define args* + (map app arg-wrappers (take args n))) + (define rest* + (and rest-wrapper (rest-wrapper (drop args n)))) + (define args+rest* + (if rest-wrapper + (append args* rest*) + args*)) + (define kw-hash* + (kws-wrapper (keyword-app-make-kw-hash kws kw-args))) + ;; kw-args* has to be in the same order as kw-args + (define kw-args* + (map-hash-ref kw-hash* kws)) + (if (null? kw-args*) + ;; if no keywords were passed in, don't include them + (apply values args+rest*) + (apply values kw-args* args+rest*)))))))) ;; check-procedure : Blame Any -> Void (define (check-procedure blame f)