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

Expose missing blame parties to the contract profiler.

Browse Source 
Done by pairing up incomplete blame objects with the missing blame party
before attaching it to the continuation mark. Other approaches were
explored (having a separate mark for each, imperatively updating blame
objects to add missing blame parties, etc.), but pairing had the least
overhead.
This commit is contained in:
Vincent St-Amour 2014-01-09 13:40:10 -05:00
parent 11732128b3
commit a2204a0740
3 changed files with 24 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
pkgs/contract-profile/main.rkt
View File

@ -1,18 +1,26 @@
#lang racket/base
(require racket/list unstable/list racket/match racket/set racket/format
racket/contract
racket/contract racket/contract/private/blame
profile/sampler profile/utils profile/analyzer
"dot.rkt" "utils.rkt" "boundary-view.rkt")
;; (listof (U blame? #f)) profile-samples -> contract-profile struct
(define (correlate-contract-samples contract-samples samples*)
(define (correlate-contract-samples contract-samples* samples*)
;; car of samples* is total time, car of each sample is thread id
;; for now, we just assume a single thread. fix this eventually.
(define total-time (car samples*))
;; reverse is there to sort samples in forward time, which get-times
;; needs.
(define samples (get-times (map cdr (reverse (cdr samples*)))))
(define contract-samples
(for/list ([c-s (in-list contract-samples*)])
;; In some cases, blame information is missing a party, in which.
;; case the contract system provides a pair of the incomplete blame
;; and the missing party. We combine the two here.
(if (pair? c-s)
(blame-add-missing-party (car c-s) (cdr c-s))
c-s)))
;; combine blame info and stack trace info. samples should line up
(define aug-contract-samples
;; If the sampler was stopped after recording a contract sample, but

9
racket/collects/racket/contract/private/arrow-higher-order.rkt
View File

@ -111,7 +111,8 @@
#'(case-lambda
[(rng-x ...)
(with-continuation-mark
contract-continuation-mark-key blame
contract-continuation-mark-key
(cons blame neg-party)
(let ()
post ...
rng-results))]
@ -232,13 +233,15 @@
;; noticeable in my measurements so far.
;; - stamourv
(with-continuation-mark
contract-continuation-mark-key blame
contract-continuation-mark-key
(cons blame neg-party)
(let ()
pre ... basic-return)))]
[kwd-lambda-name (gensym 'kwd-lambda)]
[kwd-lambda #`(λ kwd-lam-params
(with-continuation-mark
contract-continuation-mark-key blame
contract-continuation-mark-key
(cons blame neg-party)
(let ()
pre ... kwd-return)))])
(with-syntax ([(basic-checker-name) (generate-temporaries '(basic-checker))])

12
racket/collects/racket/contract/private/vector.rkt
View File

@ -106,12 +106,16 @@
(define elem-neg-proj ((get/build-val-first-projection elem-ctc) neg-blame))
(define checked-ref (λ (neg-party)
(λ (vec i val)
(with-continuation-mark contract-continuation-mark-key pos-blame
((elem-pos-proj val) neg-party)))))
(with-continuation-mark
contract-continuation-mark-key
(cons pos-blame neg-party)
((elem-pos-proj val) neg-party)))))
(define checked-set (λ (neg-party)
(λ (vec i val)
(with-continuation-mark contract-continuation-mark-key neg-blame
((elem-neg-proj val) neg-party)))))
(with-continuation-mark
contract-continuation-mark-key
(cons neg-blame neg-party)
((elem-neg-proj val) neg-party)))))
(λ (val)
(let/ec k