diff --git a/collects/typed-racket/optimizer/hidden-costs.rkt b/collects/typed-racket/optimizer/hidden-costs.rkt new file mode 100644 index 0000000000..70110acb89 --- /dev/null +++ b/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 ...)))))) diff --git a/collects/typed-racket/optimizer/logging.rkt b/collects/typed-racket/optimizer/logging.rkt index 8b12929bbc..ee614ee2c9 100644 --- a/collects/typed-racket/optimizer/logging.rkt +++ b/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)])) ;;-------------------------------------------------------------------- diff --git a/collects/typed-racket/optimizer/optimizer.rkt b/collects/typed-racket/optimizer/optimizer.rkt index 17f5bfa530..970b23faaa 100644 --- a/collects/typed-racket/optimizer/optimizer.rkt +++ b/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))) diff --git a/collects/typed-racket/optimizer/tool/report.rkt b/collects/typed-racket/optimizer/tool/report.rkt index c0799bd155..e06de62370 100644 --- a/collects/typed-racket/optimizer/tool/report.rkt +++ b/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) - (cons new res)] ; no merging for opts - [(missed-opt-log-entry? new) - (maybe-merge-with-parent new res)]))))) + (cond [(missed-opt-log-entry? new) + (maybe-merge-with-parent new res)] + [else + (cons new res)]))))) ; no merging for opts and info ;;--------------------------------------------------------------------