Show inlining and failed inlinings in Performance Report.

collects/typed-racket/optimizer/tool/logging.rkt

@@ -0,0 +1,67 @@
+#lang racket/base
+
+(require "utilities.rkt"
+         typed-racket/optimizer/logging
+         unstable/logging unstable/syntax racket/match)
+
+(provide with-intercepted-opt-logging)
+
+;; Intercepts both TR optimizer logging and mzc optimizer logging.
+;; Interceptor accepts log-entry structs.
+(define (with-intercepted-opt-logging interceptor thunk)
+  (with-intercepted-logging #:level 'debug
+    (lambda (l)
+      (cond [(log-message-from-tr-opt? l)
+             ;; From TR, use the log-entry struct provided.
+             (interceptor (cdr (vector-ref l 2)))]
+            ;; We look at the message to tell if it's from mzc.
+            [(log-message-from-mzc-opt? (vector-ref l 1))
+             ;; From mzc, create a log-entry from the info.
+             (interceptor (mzc-opt-log-message->log-entry (vector-ref l 1)))]))
+    thunk))
+
+
+(define mzc-optimizer-regexp "^mzc optimizer: ")
+(define success-regexp (string-append mzc-optimizer-regexp "inlining: "))
+(define failure-regexp (string-append mzc-optimizer-regexp "no inlining: "))
+
+(define (log-message-from-mzc-opt? l)
+  (regexp-match mzc-optimizer-regexp l))
+
+;; String (message from the mzc optimizer) -> log-entry
+(define (mzc-opt-log-message->log-entry l)
+  (define forged-stx (inlining-event->forged-stx l))
+  (cond [(regexp-match success-regexp l)
+         (inlining-success->log-entry forged-stx)]
+        [(regexp-match failure-regexp l)
+         (inlining-failure->log-entry forged-stx)]
+        [else
+         (error "Unknown log message type" l)]))
+
+(define inlining-event-regexp
+  ;; Last bit is `generated?'. We don't care about that.
+  ;; The middle elements of the vector are numbers of #f.
+  "#\\(([^ ]+) #<path:(.+)> ([^ ]+) ([^ ]+) ([^ ]+) ([^ ]+) [^ ]+\\)")
+
+(define (inlining-event->forged-stx l)
+  (match (regexp-match inlining-event-regexp l)
+    [`(,all ,name ,path ,line ,col ,pos ,span)
+     (datum->syntax #'here (string->symbol name)
+                    (list path
+                          (string->number line)
+                          (string->number col)
+                          (string->number pos)
+                          (string->number span)))]
+    [_ (error "ill-formed inlining log entry" l)]))
+
+(define (inlining-success->log-entry forged-stx)
+  (opt-log-entry "Inlining" "Inlining"
+                 forged-stx ; stx
+                 forged-stx ; located-stx
+                 (syntax-position forged-stx)))
+(define (inlining-failure->log-entry forged-stx)
+  (missed-opt-log-entry "Failed Inlining" "Failed Inlining"
+                        forged-stx
+                        forged-stx
+                        (syntax-position forged-stx)
+                        '() '() 1)) ; irritants, merged-irritants badness

collects/typed-racket/optimizer/tool/report.rkt

@@ -3,7 +3,8 @@
 (require racket/class racket/gui/base racket/match racket/port racket/list
          unstable/syntax racket/sandbox
          typed-racket/optimizer/logging
-         (prefix-in tr: typed-racket/typed-reader))
+         (prefix-in tr: typed-racket/typed-reader)
+         "logging.rkt")
 
 (provide (struct-out report-entry)
          (struct-out sub-report-entry)
@@ -61,10 +62,9 @@
   (define log '())
   (call-with-trusted-sandbox-configuration
    (lambda ()
-     (with-intercepted-tr-logging
+     (with-intercepted-opt-logging
       (lambda (l)
-        (define data (cdr (vector-ref l 2))) ; get the log-entry part
+        (set! log (cons l log)))
-        (set! log (cons data log)))
       (lambda ()
         (define port-name (send this get-port-name))
         (parameterize
@@ -75,7 +75,7 @@
                     base)
                   (current-load-relative-directory))]
              [read-accept-reader #t])
-          (void (expand (tr:read-syntax portname input))))))))
+          (void (compile (tr:read-syntax portname input))))))))
   (filter right-file? (reverse log)))
 
 ;; converts log-entry structs to report-entry structs for further

collects/typed-racket/optimizer/tool/utilities.rkt

@@ -0,0 +1,34 @@
+#lang racket/base
+
+;; TODO all this stuff should make it into unstable/X
+
+(provide (all-defined-out))
+
+(define (regexp-filter r log)
+  (for/list ([l (in-list log)] #:when (regexp-match r l))
+    l))
+
+;; (x x -> bool) (listof x) -> (listof (listof x))
+;; groups together elements that are considered equal
+;; =? should be reflexive, transitive and commutative
+(define (group-by =? l)
+  (for/fold ([res '()]) ; list of lists
+      ([elt (in-list l)])
+    (let loop ([classes     res] ; "zipper" of the equivalence classes
+               [rev-classes '()])
+      (cond [(null? classes)
+             ;; did not find an equivalence class, create a new one
+             (cons (list elt) res)]
+            [(=? elt (car (car classes)))
+             ;; found the equivalence class
+             (append rev-classes ; we keep what we skipped
+                     ;; we extend the current class
+                     (list (cons elt (car classes)))
+                     (cdr classes))] ; and add the rest
+            [else ; keep going
+             (loop (cdr classes)
+                   (cons (car classes) rev-classes))]))))
+;; TODO add to unstable/list, and add tests. here's one
+;; -> (group-by = '(1 2 1 2 54 2 5 43 7 2 643 1 2 0))
+;; '((0) (2 2 2 2 2) (7) (43) (5) (54) (643) (1 1 1))
+;; TODO needs a #:key arg