Cleanup hidden cost optimizations.

original commit: 64064f69d7accbc68e17593dddf3e2f8f79d92cb
This commit is contained in:
Eric Dobson 2013-09-04 21:45:50 -07:00
parent a1163a700f
commit f789607929

View File

@ -1,6 +1,6 @@
#lang racket/base
(require syntax/parse syntax/stx
(require syntax/parse syntax/stx unstable/sequence
(for-template racket/base)
"../utils/utils.rkt"
(optimizer utils logging)
@ -8,12 +8,9 @@
(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))))
;; not an exhaustive list
(define-literal-syntax-class hidden-port-parameter-function
(display displayln newline write write-byte print printf))
;; This syntax class does not perform optimization.
;; It only logs operations with hidden costs, for use by Optimization Coach.
@ -21,19 +18,17 @@
#: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 #,@(stx-map (optimize) #'(args ...)))))
(pattern (#%plain-app op:hidden-port-parameter-function args:opt-expr ...)
;; 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 (for/and ([arg (in-syntax #'(args ...))])
(not (subtypeof? arg -Output-Port)))
#:do [(log-optimization-info "hidden parameter" #'op)]
#:with opt #'(op args.opt ...))
;; Log calls to struct constructors, so that OC can report those used in
;; hot loops.
(pattern (#%plain-app op:id args ...)
#:when (struct-constructor? #'op)
#:with opt
(begin (log-optimization-info "struct constructor" #'op)
#`(op #,@(stx-map (optimize) #'(args ...))))))
(pattern (#%plain-app op:id args:opt-expr ...)
#:when (struct-constructor? #'op)
#:do [(log-optimization-info "struct constructor" #'op)]
#:with opt #'(op args.opt ...)))