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

Have log entries carry pseudo-syntax instead of syntax.

Browse Source 
Unlike syntax, pseudo-syntax is serializable, and it only carries the
information that Performance Report needs. Serializability is
necessary to be able to expand the program inside a sandbox and get
log entries out.

original commit: ea1ae29e0f5b780355918622fac3cd4802813d19
This commit is contained in:
Vincent St-Amour 2011-07-29 17:00:52 -04:00
parent ed0cd8f898
commit 0c964fcda8
1 changed files with 36 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
collects/typed-scheme/optimizer/logging.rkt
View File

@ -1,7 +1,7 @@
#lang racket/base
(require racket/set racket/string racket/match racket/list
unstable/syntax unstable/logging
(require racket/set racket/string racket/match racket/list racket/serialize
unstable/syntax unstable/logging syntax/to-string
"../utils/tc-utils.rkt")
(provide log-optimization log-missed-optimization
@ -10,7 +10,8 @@
with-intercepted-tr-logging 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 pseudo-syntax))
;;--------------------------------------------------------------------
@ -26,11 +27,29 @@
(define log-so-far '())
;; msg is for consumption by the DrRacket tool
(struct log-entry (kind msg stx located-stx pos) #:prefab)
;; mutability is there only to replace syntax with pseudo-syntax before
;; printing at the end
(struct log-entry (kind msg (stx #:mutable) (located-stx #:mutable) pos)
#:prefab)
;; for optimizations only (not missed optimizations, those are below)
(struct opt-log-entry log-entry () #:prefab)
;; syntax objects are not serializable.
;; this is a prefab struct that holds the information we need from syntax
;; objects while still being serializable
;; rep : string (result of syntax->string)
(struct pseudo-syntax (rep line column position span
source-directory source-file-name)
#:prefab)
(define (syntax->pseudo-syntax stx)
(pseudo-syntax (syntax->string #`(#,stx)) ; takes a list of stxs
(syntax-line stx) (syntax-column stx)
(syntax-position stx) (syntax-span stx)
(serialize (syntax-source-directory stx))
(serialize (syntax-source-file-name stx))))
(define (log-optimization kind msg stx)
(let ([new-entry
(opt-log-entry kind msg
@ -53,7 +72,7 @@
;; that got merged into this miss. we need to keep them around to detect
;; future potential merges.
(struct missed-opt-log-entry log-entry
(irritants merged-irritants badness)
((irritants #:mutable) (merged-irritants #:mutable) badness)
#:prefab)
(define missed-optimizations-log '())
@ -214,8 +233,18 @@
(define logger (current-logger))
(add-missed-opts-to-log)
(for ([x (sort-log)])
(log-message logger 'warning
(format-log-entry x)
(define out (format-log-entry x))
(set-log-entry-stx! x (syntax->pseudo-syntax (log-entry-stx x)))
(set-log-entry-located-stx! x (syntax->pseudo-syntax
(log-entry-located-stx x)))
(when (missed-opt-log-entry? x)
(set-missed-opt-log-entry-irritants!
x (map syntax->pseudo-syntax
(missed-opt-log-entry-irritants x)))
(set-missed-opt-log-entry-merged-irritants!
x (map syntax->pseudo-syntax
(missed-opt-log-entry-merged-irritants x))))
(log-message logger 'warning out
(cons optimization-log-key x))))
(define (clear-log)