Add missing instrumentation to misc.rkt.

pkgs/racket-test/tests/racket/contract/prof.rkt

@@ -286,4 +286,74 @@
      3)
    3)
 
+  (test/spec-passed/result
+   'contract-marks32
+   '(car (contract (listof pos-blame?) (list 3) 'pos 'neg))
+   3)
+
+  (test/spec-passed/result
+   'contract-marks33
+   '((car (contract (listof (-> neg-blame? pos-blame?)) (list (lambda (x) 3)) 'pos 'neg)) 2)
+   3)
+
+  (test/spec-passed/result
+   'contract-marks34
+   '(begin
+      (require racket/promise)
+      (force (contract (promise/c pos-blame?) (delay 3) 'pos 'neg)))
+   3)
+
+  (test/spec-passed/result
+   'contract-marks35
+   '(let ()
+      (define/contract tag
+        (prompt-tag/c (-> (λ _ (named-blame? 'top-level))
+                          (λ _ (named-blame? 'top-level))))
+        (make-continuation-prompt-tag))
+      (call-with-continuation-prompt
+       (lambda ()
+         (number->string
+          (call-with-composable-continuation
+           (lambda (k)
+            (abort-current-continuation tag k)))))
+       tag
+       (lambda (k) 3)))
+   3)
+
+  (test/spec-passed/result
+   'contract-marks36
+   '(let ()
+      (define/contract mark-key
+        (continuation-mark-key/c (-> (λ _ (named-blame? 'top-level))
+                                     (λ _ (named-blame? 'top-level))))
+        (make-continuation-mark-key))
+      (with-continuation-mark
+       mark-key
+       (lambda (s) (append s '(truffle fudge ganache)))
+       (let ([mark-value (continuation-mark-set-first
+                          (current-continuation-marks) mark-key)])
+         (mark-value '(chocolate-bar)))))
+   '(chocolate-bar truffle fudge ganache))
+
+  (test/spec-passed/result
+   'contract-marks37
+   '(let ()
+      (define/contract my-evt
+        (evt/c (λ _ (named-blame? 'top-level)))
+        always-evt)
+      (sync my-evt)
+      3)
+   3)
+
+  (test/spec-passed/result
+   'contract-marks38
+   '(let ()
+      (define/contract chan
+        (channel/c (λ _ (named-blame? 'top-level)))
+        (make-channel))
+      (thread (λ () (channel-get chan)))
+      (channel-put chan 'not-a-string)
+      3)
+   3)
+
   )

racket/collects/racket/contract/private/misc.rkt

@@ -1283,7 +1283,10 @@
              (c/i-procedure
               proc
               (λ (promise)
-                (values (λ (val) (p-app val neg-party)) promise)))))
+                (values (λ (val) (with-contract-continuation-mark
+                                  (cons blame neg-party)
+                                  (p-app val neg-party)))
+                        promise)))))
           (raise-blame-error
            blame #:missing-party neg-party
            val
@@ -1520,11 +1523,14 @@
     (define cc-neg-projs (for/list ([proj (in-list call/cc-projs)]) (proj swapped)))
     (define cc-pos-projs (for/list ([proj (in-list call/cc-projs)]) (proj blame)))
     (define (make-proj projs neg-party)
+      (define blame+neg-party (cons blame neg-party))
       (λ vs
-        (apply values
+        (with-contract-continuation-mark
-               (for/list ([proj (in-list projs)]
+         blame+neg-party
-                          [v (in-list vs)])
+         (apply values
-                 (proj v neg-party)))))
+                (for/list ([proj (in-list projs)]
+                           [v (in-list vs)])
+                  (proj v neg-party))))))
     (λ (val neg-party)
       ;; now do the actual wrapping
       (cond
@@ -1604,11 +1610,16 @@
     (define proj1 (ho-proj blame))
     (define proj2 (ho-proj (blame-swap blame)))
     (λ (val neg-party)
+      (define blame+neg-party (cons blame neg-party))
       (cond
         [(continuation-mark-key? val)
          (proxy val 
-                (λ (v) (proj1 v neg-party))
+                (λ (v) (with-contract-continuation-mark
-                (λ (v) (proj2 v neg-party))
+                        blame+neg-party
+                        (proj1 v neg-party)))
+                (λ (v) (with-contract-continuation-mark
+                        blame+neg-party
+                        (proj2 v neg-party)))
                 impersonator-prop:contracted ctc
                 impersonator-prop:blame blame)]
         [else 
@@ -1665,21 +1676,23 @@
   (define ctcs (chaperone-evt/c-ctcs evt-ctc))
   (define projs (map contract-projection ctcs))
   (λ (blame)
-    (define ((checker val) . args)
+    (define ((checker val blame+neg-party) . args)
-      (define expected-num (length ctcs))
+      (with-contract-continuation-mark
-      (unless (= (length args) expected-num)
+       blame+neg-party
-        (raise-blame-error
+       (define expected-num (length ctcs))
-         blame val
+       (unless (= (length args) expected-num)
-         `(expected: "event that produces ~a values"
+         (raise-blame-error
-           given: "event that produces ~a values")
+          blame val
-         expected-num
+          `(expected: "event that produces ~a values"
-         (length args)))
+            given: "event that produces ~a values")
-      (apply
+          expected-num
-       values
+          (length args)))
-       (for/list ([proj projs] [val args])
+       (apply
-         ((proj blame) val))))
+        values
-    (define (generator evt)
+        (for/list ([proj projs] [val args])
-      (values evt (checker evt)))
+          ((proj blame) val)))))
+    (define ((generator blame+neg-party) evt)
+      (values evt (checker evt blame+neg-party)))
     (λ (val neg-party)
       (unless (contract-first-order-passes? evt-ctc val)
         (raise-blame-error
@@ -1687,7 +1700,7 @@
          '(expected: "~s" given: "~e")
          (contract-name evt-ctc)
          val))
-      (chaperone-evt val generator))))
+      (chaperone-evt val (generator (cons blame neg-party))))))
 
 ;; evt/c-first-order : Contract -> Any -> Boolean
 ;; First order check for evt/c
@@ -1733,8 +1746,19 @@
   (λ (blame)
     (define pos-proj (ho-proj blame))
     (define neg-proj (ho-proj (blame-swap blame)))
-    (define (proj1 neg-party) (λ (ch) (values ch (λ (v) (pos-proj v neg-party)))))
+    (define (proj1 neg-party)
-    (define (proj2 neg-party) (λ (ch v) (neg-proj v neg-party)))
+      (define blame+neg-party (cons blame neg-party))
+      (λ (ch)
+        (values ch (λ (v)
+                     (with-contract-continuation-mark
+                      blame+neg-party
+                      (pos-proj v neg-party))))))
+    (define (proj2 neg-party)
+      (define blame+neg-party (cons blame neg-party))
+      (λ (ch v)
+        (with-contract-continuation-mark
+         blame+neg-party
+         (neg-proj v neg-party))))
     (λ (val neg-party)
       (cond
         [(channel? val)