suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Added logging to typed Scheme's optimizer.

Browse Source
This commit is contained in:
Vincent St-Amour 2010-05-19 10:36:27 -04:00
parent 7adedacf2b
commit 3e757d0fb1
1 changed files with 36 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
collects/typed-scheme/private/optimize.rkt
View File

@ -38,21 +38,38 @@
(pattern e:opt-expr* (pattern e:opt-expr*
#:with opt (syntax-recertify #'e.opt this-syntax (current-code-inspector) #f))) #:with opt (syntax-recertify #'e.opt this-syntax (current-code-inspector) #f)))
(define *log-optimizations?* #f)
(define *log-optimizatons-to-log-file?* #f)
(define *optimization-log-file* "opt-log")
(define (log-optimization kind stx)
(if *log-optimizations?*
(printf "~a line ~a col ~a - ~a\n"
(syntax-source stx) (syntax-line stx) (syntax-column stx)
kind)
#t))
(define-syntax-class opt-expr* (define-syntax-class opt-expr*
#:literal-sets (kernel-literals) #:literal-sets (kernel-literals)
#:local-conventions ([#px"^e" opt-expr] #:local-conventions ([#px"^e" opt-expr]
[#px"^f\\d*s?$" float-opt-expr] [#px"^f\\d*s?$" float-opt-expr]
[#px"^p\\d*s?$" pair-opt-expr]) [#px"^p\\d*s?$" pair-opt-expr])
;; interesting cases, where something is optimized
(pattern (#%plain-app op:float-unary-op f) (pattern (#%plain-app op:float-unary-op f)
#:with opt #'(op.unsafe f.opt)) #:with opt
(begin (log-optimization "unary float" #'op)
#'(op.unsafe f.opt)))
;; unlike their safe counterparts, unsafe binary operators can only take 2 arguments ;; unlike their safe counterparts, unsafe binary operators can only take 2 arguments
(pattern (#%plain-app op:float-binary-op f fs ...) (pattern (#%plain-app op:float-binary-op f fs ...)
#:with opt #:with opt
(for/fold ([o #'f.opt]) (begin (log-optimization "binary float" #'op)
([e (syntax->list #'(fs.opt ...))]) (for/fold ([o #'f.opt])
#`(op.unsafe #,o #,e))) ([e (syntax->list #'(fs.opt ...))])
#`(op.unsafe #,o #,e))))
(pattern (#%plain-app op:pair-unary-op p) (pattern (#%plain-app op:pair-unary-op p)
#:with opt #'(op.unsafe p.opt)) #:with opt
(begin (log-optimization "unary pair" #'op)
#'(op.unsafe p.opt)))
;; boring cases, just recur down ;; boring cases, just recur down
(pattern (#%plain-lambda formals e ...) (pattern (#%plain-lambda formals e ...)
@ -76,6 +93,17 @@
#:with opt #'other)) #:with opt #'other))
(define (optimize stx) (define (optimize stx)
(syntax-parse stx #:literal-sets (kernel-literals) (let ((port (if (and *log-optimizations?*
[e:opt-expr *log-optimizatons-to-log-file?*)
(syntax/loc stx e.opt)])) (open-output-file *optimization-log-file*
#:exists 'append)
(current-output-port))))
(begin0
(parameterize ([current-output-port port])
(syntax-parse stx #:literal-sets (kernel-literals)
[e:opt-expr
(syntax/loc stx e.opt)]))
(if (and *log-optimizations?*
*log-optimizatons-to-log-file?*)
(close-output-port port)
#t))))