Log operations with hidden costs from TR.

Currently only implicit parameter dereferences.

collects/typed-racket/optimizer/hidden-costs.rkt

@@ -0,0 +1,32 @@
+#lang racket/base
+
+(require syntax/parse unstable/syntax
+         (for-template racket/base)
+         "../utils/utils.rkt"
+         (optimizer utils logging)
+         (types abbrev))
+
+(provide hidden-cost-log-expr)
+
+(define-syntax-class hidden-port-parameter-function
+  #:commit
+  ;; not an exhaustive list
+  (pattern (~or (~literal display) (~literal displayln) (~literal newline)
+                (~literal write) (~literal write-byte) (~literal print)
+                (~literal printf))))
+
+;; This syntax class does not perform optimization.
+;; It only logs operations with hidden costs, for use by Optimization Coach.
+(define-syntax-class hidden-cost-log-expr
+  #:commit
+  ;; Log functions that access parameters implicitly (e.g. `display', which
+  ;; accesses `current-output-port').
+  (pattern (#%plain-app op:hidden-port-parameter-function args ...)
+           ;; The function is not getting its output port as argument.
+           ;; Since the port is first arg for some functions, second for
+           ;; others, we're conservative, and look for a port in any position.
+           #:when (andmap (lambda (a) (not (subtypeof? a -Output-Port)))
+                          (syntax->list #'(args ...)))
+           #:with opt
+           (begin (log-optimization-info "hidden parameter" #'op)
+                  #`(op #,@(syntax-map (optimize) #'(args ...))))))

collects/typed-racket/optimizer/logging.rkt

@@ -4,11 +4,12 @@
          unstable/syntax unstable/logging
          "../utils/tc-utils.rkt")
 
-(provide log-optimization log-missed-optimization
+(provide log-optimization log-missed-optimization log-optimization-info
          with-tr-logging-to-port
          (struct-out log-entry)
          (struct-out opt-log-entry)
-         (struct-out missed-opt-log-entry))
+         (struct-out missed-opt-log-entry)
+         (struct-out info-log-entry))
 
 ;;--------------------------------------------------------------------
 
@@ -67,6 +68,21 @@
 
 ;;--------------------------------------------------------------------
 
+;; Log information that is neither an optimization nor a missed optimization,
+;; but can come in handy, in combination with other information, to detect
+;; near misses.
+
+(struct info-log-entry log-entry () #:prefab)
+
+(define (log-optimization-info kind stx)
+  (when (anyone-listening?)
+    (emit-log-message
+     ;; no actual message, since it's not meant for user consumption
+     (info-log-entry kind "" stx (locate-stx stx) (syntax-position stx)
+                     'typed-racket))))
+
+;;--------------------------------------------------------------------
+
 (define (line+col->string stx)
   (let ([line (syntax-line stx)]
         [col  (syntax-column stx)])
@@ -108,7 +124,9 @@
                  (format-irritants (missed-opt-log-entry-irritants entry))
                  (if (> badness 1)
                      (format " (~a times)" badness)
-                     ""))]))
+                     ""))]
+        [(info-log-entry? entry)
+         (format "TR info: ~a" msg)]))
 
 ;;--------------------------------------------------------------------
 

collects/typed-racket/optimizer/optimizer.rkt

@@ -6,7 +6,8 @@
          "../utils/utils.rkt"
          (optimizer utils logging
                     number fixnum float float-complex vector string list pair
-                    sequence box struct dead-code apply unboxed-let))
+                    sequence box struct dead-code apply unboxed-let
+                    hidden-costs))
 
 (provide optimize-top)
 
@@ -44,6 +45,7 @@
   (pattern e:sequence-opt-expr        #:with opt #'e.opt)
   (pattern e:box-opt-expr             #:with opt #'e.opt)
   (pattern e:struct-opt-expr          #:with opt #'e.opt)
+  (pattern e:hidden-cost-log-expr     #:with opt #'e.opt)
 
   ;; boring cases, just recur down
   (pattern ((~and op (~or (~literal #%plain-lambda) (~literal define-values)))

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

@@ -76,6 +76,10 @@
 (define (log->report log)
   (define (log-entry->report-entry l)
     (match l
+      [(? info-log-entry? _)
+       ;; Info entries are only useful for log analysis, and should not be
+       ;; presented to users. Drop them.
+       #f]
       [(log-entry kind msg stx located-stx (? number? pos) provenance)
        (define start     (sub1 pos))
        (define end       (+ start (syntax-span stx)))
@@ -98,10 +102,10 @@
                ;; merge missed-opts hierarchically
                (for/fold ([res '()])
                    ([new (remove-duplicates log)])
-                 (cond [(opt-log-entry? new)
+                 (cond [(missed-opt-log-entry? new)
-                        (cons new res)] ; no merging for opts
+                        (maybe-merge-with-parent new res)]
-                       [(missed-opt-log-entry? new)
+                       [else
-                        (maybe-merge-with-parent new res)])))))
+                        (cons new res)]))))) ; no merging for opts and info
 
 ;;--------------------------------------------------------------------