From cd71c77da93ca790df39fe8a1e9edadf3b4e154d Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Thu, 30 May 2013 16:31:30 -0400
Subject: [PATCH] Add a module graph view that shows contract costs per
 boundary.

---
 collects/profile/contract-profile.rkt | 73 ++++++++++++++++++++++++++-
 1 file changed, 71 insertions(+), 2 deletions(-)

diff --git a/collects/profile/contract-profile.rkt b/collects/profile/contract-profile.rkt
index ab668626d4..e4e80ff4f2 100644
--- a/collects/profile/contract-profile.rkt
+++ b/collects/profile/contract-profile.rkt
@@ -1,6 +1,6 @@
 #lang racket/base
 
-(require racket/list unstable/list racket/match
+(require racket/list unstable/list racket/match racket/set
          racket/contract
          (only-in racket/contract/private/guts contract-continuation-mark-key)
          "sampler.rkt")
@@ -30,9 +30,14 @@
 
 (define (analyze-contract-samples contract-samples samples*)
   (define correlated (correlate-contract-samples contract-samples samples*))
-  (print-breakdown correlated))
+  (print-breakdown correlated)
+  (module-graph-view correlated))
 
 
+;;---------------------------------------------------------------------------
+;; Break down contract checking time by contract, then by callee and by chain
+;; of callers.
+
 (define (print-breakdown correlated)
   (match-define (contract-profile total-time n-samples n-contract-samples
                                   live-contract-samples all-blames)
@@ -97,6 +102,70 @@
   (list* blame thread-id timestamp new-stack-trace))
 
 
+;;---------------------------------------------------------------------------
+;; Show graph of modules, with contract boundaries and contract costs for each
+;; boundary.
+;; Typed modules are in green, untyped modules are in red.
+
+(define (module-graph-view correlated)
+  (match-define (contract-profile total-time n-samples n-contract-samples
+                                  live-contract-samples all-blames)
+    correlated)
+
+  ;; first, enumerate all the relevant modules
+  (define-values (nodes edge-samples)
+    (for/fold ([nodes (set)] ; set of modules
+               ;; maps pos-neg edges (pairs) to lists of samples
+               [edge-samples (hash)])
+        ([s (in-list live-contract-samples)])
+      (match-define (list blame thread-id timestamp stack-trace ...) s)
+      (define pos (blame-positive blame))
+      (define neg (blame-negative blame))
+      (values (set-add (set-add nodes pos) neg) ; add all new modules
+              (hash-update edge-samples (cons pos neg)
+                           (lambda (ss) (cons s ss))
+                           '()))))
+
+  (define nodes->typed?
+    (for/hash ([n nodes])
+      ;; typed modules have a #%type-decl submodule
+      (define submodule? (not (path? n)))
+      (define filename (if submodule? (car n) n))
+      (define typed?
+        (with-handlers
+            ([(lambda (e)
+                (and (exn:fail:contract? e)
+                     (regexp-match "^dynamic-require: unknown module"
+                                   (exn-message e))))
+              (lambda _ #f)])
+          (dynamic-require
+           (append (list 'submod (list 'file (path->string filename)))
+                   (if submodule? (cdr n) '())
+                   '(#%type-decl))
+           #f)
+          #t))
+      (values n typed?)))
+
+  ;; graphviz output
+  (printf "digraph {\n")
+  (define nodes->names (for/hash ([n nodes]) (values n (gensym))))
+  (for ([n nodes])
+    (printf "~a[label=\"~a\"][color=\"~a\"]\n"
+            (hash-ref nodes->names n)
+            n
+            (if (hash-ref nodes->typed? n) "green" "red")))
+  (for ([(k v) (in-hash edge-samples)])
+    (match-define (cons pos neg) k)
+    (printf "~a -> ~a[label=\"~a\"]\n"
+            (hash-ref nodes->names neg)
+            (hash-ref nodes->names pos)
+            (length v)))
+  (printf "}\n"))
+
+
+;;---------------------------------------------------------------------------
+;; Entry point
+
 (provide (rename-out [contract-profile/user contract-profile]))
 
 ;; TODO have kw args for profiler, etc.