From a2204a074022d8c0afffb6dbd085808ee9517b65 Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Thu, 9 Jan 2014 13:40:10 -0500
Subject: [PATCH] Expose missing blame parties to the contract profiler.

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.
---
 pkgs/contract-profile/main.rkt                       | 12 ++++++++++--
 .../racket/contract/private/arrow-higher-order.rkt   |  9 ++++++---
 racket/collects/racket/contract/private/vector.rkt   | 12 ++++++++----
 3 files changed, 24 insertions(+), 9 deletions(-)

diff --git a/pkgs/contract-profile/main.rkt b/pkgs/contract-profile/main.rkt
index 6204c09d08..77050a773a 100644
--- a/pkgs/contract-profile/main.rkt
+++ b/pkgs/contract-profile/main.rkt
@@ -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
diff --git a/racket/collects/racket/contract/private/arrow-higher-order.rkt b/racket/collects/racket/contract/private/arrow-higher-order.rkt
index de5531b4ff..10fc81a8f3 100644
--- a/racket/collects/racket/contract/private/arrow-higher-order.rkt
+++ b/racket/collects/racket/contract/private/arrow-higher-order.rkt
@@ -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))])
diff --git a/racket/collects/racket/contract/private/vector.rkt b/racket/collects/racket/contract/private/vector.rkt
index 120165d093..8a21e7d445 100644
--- a/racket/collects/racket/contract/private/vector.rkt
+++ b/racket/collects/racket/contract/private/vector.rkt
@@ -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