add some missing contract profiler wcm expressions and start a test suite for them

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

@@ -0,0 +1,102 @@
+#lang racket/base
+(require "test-util.rkt")
+
+(parameterize ([current-contract-namespace
+                (make-basic-contract-namespace 
+                 'racket/contract)])
+
+  (contract-eval
+   '(module prof-fun racket/base
+      (require (only-in racket/contract/private/guts
+                        contract-continuation-mark-key)
+               (only-in racket/contract/private/blame
+                        blame-positive
+                        blame-negative
+                        blame?))
+      (provide pos-blame? neg-blame? named-blame?)
+      (define (named-blame? who)
+        (define mark-info
+          (continuation-mark-set-first
+           (current-continuation-marks)
+           contract-continuation-mark-key))
+        (define (get-party selector)
+          (and mark-info
+               (or (selector (car mark-info))
+                   (cdr mark-info))))
+        (and mark-info
+             (let ([pos (get-party blame-positive)]
+                   [neg (get-party blame-negative)])
+               (or (equal? pos who)
+                   (equal? neg who)))))
+      (define (pos-blame? _) (named-blame? 'pos))
+      (define (neg-blame? _) (named-blame? 'neg))))
+
+  (contract-eval '(require 'prof-fun))
+
+  (test/spec-passed
+   'provide/contract1
+   '((contract (-> neg-blame? any/c) (λ (x) x) 'pos 'neg) 1))
+
+  (test/spec-passed
+   'provide/contract2
+   '((contract (-> any/c pos-blame?) (λ (x) x) 'pos 'neg) 1))
+
+  (test/spec-passed
+   'provide/contract3
+   '(contract (vector/c pos-blame?) (vector 1) 'pos 'neg))
+
+  (test/spec-passed
+   'provide/contract4
+   '((contract (parameter/c pos-blame?) (make-parameter #f) 'pos 'neg)))
+
+  (test/spec-passed
+   'provide/contract5
+   '(contract (unconstrained-domain-> pos-blame?) (λ () 1) 'pos 'neg))
+
+  (test/spec-passed
+   'provide/contract6
+   '(contract (->* () #:pre neg-blame? any) (λ () 1) 'pos 'neg))
+
+  (test/spec-passed
+   'provide/contract7
+   '(contract (->* () any/c #:post pos-blame?) (λ () 1) 'pos 'neg))
+
+  (test/spec-passed/result
+   'provide/contract8
+   '(let ()
+      (eval '(module prof1 racket/base
+               (require racket/contract 'prof-fun)
+               (define (f x) x)
+               (define a-contract (-> (λ _ (named-blame? 'prof1)) any/c))
+               (provide
+                (contract-out
+                 [f a-contract]))))
+      (eval '(require 'prof1))
+      (eval '(f 11)))
+   11)
+
+  (test/spec-passed/result
+   'provide/contract9
+   '(let ()
+      (eval '(module prof2 racket/base
+               (require racket/contract 'prof-fun)
+               (define (f x) x)
+               (provide
+                (contract-out
+                 [f (-> (λ _ (named-blame? 'prof2)) any/c)]))))
+      (eval '(require 'prof2))
+      (eval '(f 11)))
+   11)
+
+  (test/spec-passed/result
+   'provide/contract10
+   '(let ()
+      (eval '(module prof3 racket/base
+               (require racket/contract 'prof-fun)
+               (define (f #:x x) x)
+               (provide
+                (contract-out
+                 [f (-> #:x (λ _ (named-blame? 'prof3)) any/c)]))))
+      (eval '(require 'prof3))
+      (eval '(f #:x 11)))
+   11))

racket/collects/racket/contract/private/arrow-higher-order.rkt

@@ -59,16 +59,20 @@
 
 
 (define (check-pre-cond pre blame neg-party val)
+  (with-continuation-mark contract-continuation-mark-key
+    (cons blame neg-party)
     (unless (pre)
       (raise-blame-error (blame-swap blame)
                          #:missing-party neg-party
-                       val "#:pre condition")))
+                         val "#:pre condition"))))
 
 (define (check-post-cond post blame neg-party val)
+  (with-continuation-mark contract-continuation-mark-key
+    (cons blame neg-party)
     (unless (post)
       (raise-blame-error blame
                          #:missing-party neg-party
-                       val "#:post condition")))
+                         val "#:post condition"))))
 
 (define (check-pre-cond/desc post blame neg-party val)
   (handle-pre-post/desc-string #t post blame neg-party val))

racket/collects/racket/contract/private/arrow-val-first.rkt

@@ -180,18 +180,29 @@
                 [(res-x ...) (generate-temporaries (or rngs '()))]
                 [(kwd-arg-x ...) (generate-temporaries mandatory-kwds)])
 
+    (define base-arg-expressions (reverse (syntax->list #'(((regb arg-x) neg-party) ...))))
+    (define normal-arg-vars (generate-temporaries #'(arg-x ...)))
+    (define base-arg-vars normal-arg-vars)
+
     (with-syntax ([(formal-kwd-args ...)
                    (apply append (map list mandatory-kwds (syntax->list #'(kwd-arg-x ...))))]
                   [(kwd-arg-exps ...)
-                   (apply append (map (λ (kwd kwd-arg-x kb) 
+                   (apply
-                                        (list kwd #`((#,kb #,kwd-arg-x) neg-party)))
+                    append
+                    (map (λ (kwd kwd-arg-x kb)
+                           (set! base-arg-expressions
+                                 (cons #`((#,kb #,kwd-arg-x) neg-party)
+                                       base-arg-expressions))
+                           (set! base-arg-vars (cons (car (generate-temporaries (list kwd-arg-x)))
+                                                     base-arg-vars))
+                           (list kwd (car base-arg-vars)))
                          mandatory-kwds
                          (syntax->list #'(kwd-arg-x ...))
                          (syntax->list #'(kb ...))))]
                   [(letrec-bound-id) (generate-temporaries '(f))])
       
       (with-syntax ([(wrapper-args ...) #'(neg-party arg-x ... formal-kwd-args ...)]
-                    [(the-call ...) #'(f ((regb arg-x) neg-party) ... kwd-arg-exps ...)]
+                    [(the-call ...) #`(f #,@(reverse normal-arg-vars) kwd-arg-exps ...)]
                     [(pre-check ...)
                      (if pre 
                          (list #`(check-pre-cond #,pre blame neg-party f))
@@ -211,32 +222,55 @@
                (let loop ([optional-args (reverse optional-args)]
                           [ob (reverse (syntax->list #'(optb ...)))]
                           [first? #t])
+                 (define args-expressions base-arg-expressions)
+                 (define args-vars base-arg-vars)
                  (define no-rest-call
-                   #`(the-call ... #,@(for/list ([ob (in-list (reverse ob))]
+                   #`(the-call ...
+                      #,@(for/list ([ob (in-list (reverse ob))]
                                     [optional-arg (in-list (reverse optional-args))])
-                                        #`((#,ob #,optional-arg) neg-party))))
+                           (set! args-expressions
+                                 (cons #`((#,ob #,optional-arg) neg-party)
+                                       args-expressions))
+                           (set! args-vars
+                                 (cons (car (generate-temporaries (list optional-arg)))
+                                       args-vars))
+                           (car args-vars))))
                  (define full-call
-                   (if (and first? rest)
+                   (cond
-                       #`(apply #,@no-rest-call ((restb rest-arg) neg-party))
+                     [(and first? rest)
-                       no-rest-call))
+                      (set! args-expressions (cons #'((restb rest-arg) neg-party) args-expressions))
+                      (set! args-vars (cons (car (generate-temporaries '(rest-args-arrow-contract)))
+                                            args-vars))
+                      #`(apply #,@no-rest-call #,(car args-vars))]
+                     [else
+                      no-rest-call]))
                  (define the-args #`(wrapper-args ... 
                                      #,@(reverse optional-args)
                                      #,@(if (and first? rest)
                                             #'rest-arg
                                             '())))
+                 (define let-values-clause
+                   #`[#,(reverse args-vars)
+                      (with-continuation-mark contract-continuation-mark-key
+                        (cons blame neg-party)
+                        (values #,@(reverse args-expressions)))])
+                 
                  (define the-clause
                    (if rngs
                        #`[#,the-args
                           pre-check ...
                           (define-values (failed res-x ...)
                             (call-with-values
-                             (λ () #,full-call)
+                             (λ () (let-values (#,let-values-clause)
+                                     #,full-call))
                              (case-lambda
                                [(res-x ...)
                                 (values #f res-x ...)]
                                [args
                                 (values args #,@(map (λ (x) #'#f) 
                                                      (syntax->list #'(res-x ...))))])))
+                          (with-continuation-mark contract-continuation-mark-key
+                            (cons blame neg-party)
                             (cond
                               [failed
                                (wrong-number-of-results-blame
@@ -247,10 +281,11 @@
                                     #'(res-x ...))))]
                               [else
                                post-check ...
-                             (values ((rb res-x) neg-party) ...)])]
+                               (values ((rb res-x) neg-party) ...)]))]
                        #`[#,the-args
                           pre-check ...
-                          #,full-call]))
+                          (let-values (#,let-values-clause)
+                            #,full-call)]))
                  (cons the-clause
                        (cond
                          [(null? optional-args) '()]

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

@@ -1493,8 +1493,13 @@
              [out-proc (contract-projection (parameter/c-out ctc))])
         (λ (blame)
           (define blame/c (blame-add-context blame "the parameter of"))
-          (define partial-neg-contract (in-proc (blame-swap blame/c)))
+          (define (add-profiling f)
-          (define partial-pos-contract (out-proc blame/c))
+            (λ (x)
+              (with-continuation-mark contract-continuation-mark-key
+                (cons blame #f)
+                (f x))))
+          (define partial-neg-contract (add-profiling (in-proc (blame-swap blame/c))))
+          (define partial-pos-contract (add-profiling (out-proc blame/c)))
           (λ (val)
             (cond
               [(parameter? val)
@@ -1515,11 +1520,16 @@
          (cond
            [(parameter? val)
             (λ (neg-party)
+              (define (add-profiling f)
+                (λ (x)
+                  (with-continuation-mark contract-continuation-mark-key
+                    (cons blame neg-party)
+                    (f x))))
               (make-derived-parameter
                val
                ;; unfortunately expensive
-               (in-proc (blame-add-missing-party swapped neg-party))
+               (add-profiling (in-proc (blame-add-missing-party swapped neg-party)))
-               (out-proc (blame-add-missing-party blame/c neg-party))))]
+               (add-profiling (out-proc (blame-add-missing-party blame/c neg-party)))))]
            [else
             (λ (neg-party)
               (raise-blame-error blame #:missing-party neg-party