From 2b7423a5e03ef9a9dec2e43f6aae52c24245c9c8 Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Fri, 31 Jan 2014 11:48:21 -0500
Subject: [PATCH] Instrument TR casts / asserts for feature-specific profiling.

original commit: 5502bf5b1ba8782badb8ef8a58d3e8ec947418ad
---
 .../typed-racket/base-env/extra-procs.rkt     | 28 +++++++++-----
 .../typed-racket/base-env/prims.rkt           | 37 +++++++++++--------
 2 files changed, 40 insertions(+), 25 deletions(-)

diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/extra-procs.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/extra-procs.rkt
index e28cd47c..19177ba0 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/extra-procs.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/extra-procs.rkt
@@ -1,15 +1,23 @@
 #lang racket/base
+(require (for-syntax racket/base))
 (provide assert defined?)
 
-(define-syntax assert
-  (syntax-rules ()
-    ((assert v)
-     (let ([val v])
-       (or val (error (format "Assertion failed on ~v" val)))))
-    ((assert v pred)
-     (let ((val v))
-       (if ((#%expression pred) val)
-           val
-           (error (format "Assertion ~a failed on ~v" pred val)))))))
+(define-syntax (assert stx)
+  (syntax-case stx ()
+    [(assert v)
+     #`(let ([val v])
+         #,(syntax-property
+            (syntax/loc stx
+              (or val (error (format "Assertion failed on ~v" val))))
+            'feature-profile:TR-dynamic-check #t))]
+    [(assert v p)
+     #`(let ([val  v]
+             [pred p])
+         #,(syntax-property
+            (quasisyntax/loc stx
+              (if (pred val)
+                  val
+                  (error (format "Assertion ~a failed on ~v" pred val))))
+            'feature-profile:TR-dynamic-check #t))]))
 
 (define (defined? v) #t)
diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt
index f20acd68..1b3357a9 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt
@@ -332,17 +332,20 @@ This file defines two sorts of primitives. All of them are provided into any mod
     [(_ v:expr ty:expr)
      (define (apply-contract ctc-expr)
        #`(#%expression
-           (ann
-             #,(ignore-some
-                 #`(let-values (((val) #,(with-type* #'v #'Any)))
-                     (contract
-                       #,ctc-expr
-                       val
-                       'cast
-                       'typed-world
-                       val
-                       (quote-syntax #,stx))))
-             ty)))
+          (ann
+           #,(ignore-some
+              #`(let-values (((val) #,(with-type* #'v #'Any)))
+                  #,(syntax-property
+                     (quasisyntax/loc stx
+                       (contract
+                        #,ctc-expr
+                        val
+                        'cast
+                        'typed-world
+                        val
+                        (quote-syntax #,stx)))
+                     'feature-profile:TR-dynamic-check #t)))
+           ty)))
 
      (cond [(not (unbox typed-context?)) ; no-check, don't check
             #'v]
@@ -1267,10 +1270,14 @@ This file defines two sorts of primitives. All of them are provided into any mod
                 (error "Assertion failed")])])
    (syntax-parse stx
      [(_ (c:with-asserts-clause ...) body:expr ...+)
-      (syntax/loc stx
-        (cond c.cond-clause
-              ...
-              [else body ...]))]))
+      (syntax-property
+       (quasisyntax/loc stx
+         (cond c.cond-clause
+               ...
+               [else #,(syntax-property
+                        #'(begin body ...)
+                        'feature-profile:TR-dynamic-check 'antimark)]))
+       'feature-profile:TR-dynamic-check #t)]))
 
 (define-syntax (typecheck-fail stx)
   (syntax-parse stx