Show inlining and failed inlinings in Performance Report.
This commit is contained in:
parent
9424c843ef
commit
0e710c1618
67
collects/typed-racket/optimizer/tool/logging.rkt
Normal file
67
collects/typed-racket/optimizer/tool/logging.rkt
Normal file
|
@ -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
|
|
@ -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 data log)))
|
||||
(set! log (cons l 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
|
||||
|
|
34
collects/typed-racket/optimizer/tool/utilities.rkt
Normal file
34
collects/typed-racket/optimizer/tool/utilities.rkt
Normal file
|
@ -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
|
Loading…
Reference in New Issue
Block a user