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

Go back to previous expansion strategy.

Browse Source 
The DrRacket expansion functions don't offer anything more than plain
expand + a sandbox, and using them made the code less readable.

This reverts commit 96eee2b317.
This reverts commit 19ce4d44a5.
This reverts commit 58fbd8ba75.
This reverts commit b305ea9c62.
This reverts commit 860feb30ae.
This commit is contained in:
Vincent St-Amour 2011-07-29 12:23:54 -04:00
parent 5b22dfb6b0
commit d794d33b5e
5 changed files with 84 additions and 136 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/typed-scheme/optimizer/tool/display.rkt
View File

@ -2,7 +2,7 @@
(require racket/string racket/class racket/gui/base racket/match racket/port
framework syntax/to-string
"report-structs.rkt"
"report.rkt"
unstable/sequence unstable/pretty)
(provide popup-callback make-color-table)

3
collects/typed-scheme/optimizer/tool/report-sig.rkt
View File

@ -1,3 +0,0 @@
#lang racket/signature
generate-report

18
collects/typed-scheme/optimizer/tool/report-structs.rkt
View File

@ -1,18 +0,0 @@
#lang racket/base
(provide (struct-out report-entry)
(struct-out sub-report-entry)
(struct-out opt-report-entry)
(struct-out missed-opt-report-entry))
;; Similar to the log-entry family of structs, but geared towards GUI display.
;; Also designed to contain info for multiple overlapping log entries.
;; - subs is a list of sub-report-entry, corresponding to all the entries
;; between start and end
;; - badness is 0 for a report-entry containing only optimizations
;; otherwise, it's the sum for all the subs
(struct report-entry (subs start end badness))
;; multiple of these can be contained in a report-entry
(struct sub-report-entry (stx msg))
(struct opt-report-entry sub-report-entry ())
(struct missed-opt-report-entry sub-report-entry (badness irritants))

95
collects/typed-scheme/optimizer/tool/report.rkt
View File

@ -1,51 +1,38 @@
#lang racket/unit
#lang racket/base
(require racket/class racket/gui/base racket/match
unstable/syntax drracket/tool
unstable/logging)
unstable/syntax)
(require typed-scheme/optimizer/logging
"report-sig.rkt" "report-structs.rkt")
(require (prefix-in tr: typed-scheme/typed-reader)
typed-scheme/optimizer/logging)
(import drracket:tool^)
(export report^)
(provide (struct-out report-entry)
(struct-out sub-report-entry)
(struct-out opt-report-entry)
(struct-out missed-opt-report-entry)
generate-report)
;; Similar to the log-entry family of structs, but geared towards GUI display.
;; Also designed to contain info for multiple overlapping log entries.
;; - subs is a list of sub-report-entry, corresponding to all the entries
;; between start and end
;; - badness is 0 for a report-entry containing only optimizations
;; otherwise, it's the sum for all the subs
(struct report-entry (subs start end badness))
;; multiple of these can be contained in a report-entry
(struct sub-report-entry (stx msg))
(struct opt-report-entry sub-report-entry ())
(struct missed-opt-report-entry sub-report-entry (badness irritants))
(define (generate-report this)
(collapse-report (log->report (generate-log this))))
(define (generate-log this)
;; expand and capture log messages
(define log '())
(define listener #f)
(define exception #f)
(define done-chan (make-channel))
(drracket:eval:expand-program
(drracket:language:make-text/pos
this 0 (send this last-position))
(send this get-next-settings) #t
(lambda () ; init
(uncaught-exception-handler
(lambda (e)
(set! exception e) ; something went wrong, save exception and die
(channel-put done-chan 'done) ; let the rest of the program carry on
(custodian-shutdown-all (current-custodian)))) ; kill ourselves
(set! listener (start-recording #:level 'warning)))
(lambda () ; kill
(channel-put done-chan 'done))
(lambda (term k)
(if (eof-object? term)
(begin (set! log (stop-recording listener)) ; done, stash the log
(channel-put done-chan 'done))
(k)))) ; not done, keep going
(channel-get done-chan) ; wait for expansion to finish
(when exception ; something went wrong, will be caught upstream
(raise exception))
(define portname (send this get-port-name))
(define input (open-input-text-editor this))
(port-count-lines! input)
(define log '())
(define unsaved-file?
(and (symbol? portname)
(regexp-match #rx"^unsaved-editor" (symbol->string portname))))
@ -64,26 +51,22 @@
(not f)]
[else ; different file
#f]))
(define (post-process-log-entry l)
;; make sure the message is indeed from the optimizer
(cond [(log-message-from-tr-opt? l)
(define log-entry-data (cdr (vector-ref l 2))) ; log-entry struct
(define stx (log-entry-stx log-entry-data))
(define path (if (and (syntax-source-directory stx)
(syntax-source-file-name stx))
(build-path (syntax-source-directory stx)
(syntax-source-file-name stx))
#f))
;; it also needs to come from the right file
(if (right-file? path)
log-entry-data ; payload
#f)]
[else #f])) ; drop it
(for/list ([l (in-list (map post-process-log-entry log))]
#:when l)
l))
(with-intercepted-tr-logging
(lambda (l)
(define log-entry-data (cdr (vector-ref l 2))) ; log-entry struct
(define stx (log-entry-stx log-entry-data))
(define path (if (and (syntax-source-directory stx)
(syntax-source-file-name stx))
(build-path (syntax-source-directory stx)
(syntax-source-file-name stx))
#f))
(when (right-file? path)
(set! log (cons log-entry-data log))))
(lambda ()
(parameterize ([current-namespace (make-base-namespace)]
[read-accept-reader #t])
(expand (tr:read-syntax portname input)))))
log)
;; converts log-entry structs to report-entry structs for further
;; processing

102
collects/typed-scheme/optimizer/tool/tool.rkt
View File

@ -3,7 +3,7 @@
(require racket/class racket/port racket/list racket/match
racket/gui/base racket/unit drracket/tool)
(require "display.rkt" "report-sig.rkt" "report.rkt" "report-structs.rkt")
(require "report.rkt" "display.rkt")
(provide performance-report-drracket-button
tool@)
@ -17,73 +17,59 @@
;; performance-report-callback : drracket:unit:frame<%> -> void
(define (performance-report-callback drr-frame)
(with-handlers
([exn?
;; typechecking failed, report in the interactions window
(lambda (e)
(define interactions (send drr-frame get-interactions-text))
(send interactions reset-console)
(send interactions run-in-evaluation-thread (lambda () (raise e))))])
(send (send drr-frame get-definitions-text) add-highlights)))
(send (send drr-frame get-definitions-text) add-highlights))
(define-unit pre-tool@
(import drracket:tool^ report^)
(export drracket:tool-exports^)
(define highlights-mixin
(mixin ((class->interface text%)) ()
(inherit begin-edit-sequence
end-edit-sequence
insert
get-text)
(define (phase1) (void))
(define (phase2) (void))
(define highlights '())
(define color-table #f)
(define highlights-mixin
(mixin ((class->interface text%)) ()
(inherit begin-edit-sequence
end-edit-sequence
insert
get-text)
(define (highlight-entry l)
(match l
[(report-entry subs start end badness)
(let ([color (if (= badness 0)
"lightgreen"
(vector-ref color-table badness))])
(send this highlight-range start end color)
(send this set-clickback start end (popup-callback l))
;; record highlight to undo it later
(list start end color))]))
(define highlights '())
(define color-table #f)
(define/public (add-highlights)
(define report (generate-report this))
(define max-badness
(apply max (cons 0 (map report-entry-badness report))))
(unless (= max-badness 0) ; no missed opts, color table code would error
(set! color-table (make-color-table max-badness)))
(define new-highlights (map highlight-entry report))
(set! highlights (append new-highlights highlights)))
(define (highlight-entry l)
(match l
[(report-entry subs start end badness)
(let ([color (if (= badness 0)
"lightgreen"
(vector-ref color-table badness))])
(send this highlight-range start end color)
(send this set-clickback start end (popup-callback l))
;; record highlight to undo it later
(list start end color))]))
(define (clear-highlights)
(for ([h (in-list highlights)])
(match h
[`(,start ,end . ,rest )
(send this unhighlight-range . h)
(send this remove-clickback start end)]))
(set! highlights '()))
(define/public (add-highlights)
(define report (generate-report this))
(define max-badness
(apply max (cons 0 (map report-entry-badness report))))
(unless (= max-badness 0) ; no missed opts, color table code would error
(set! color-table (make-color-table max-badness)))
(define new-highlights (map highlight-entry report))
(set! highlights (append new-highlights highlights)))
(define/augment (after-insert start len)
(clear-highlights))
(define/augment (after-delete start len)
(clear-highlights))
(define (clear-highlights)
(for ([h (in-list highlights)])
(match h
[`(,start ,end . ,rest )
(send this unhighlight-range . h)
(send this remove-clickback start end)]))
(set! highlights '()))
(super-new)))
(define/augment (after-insert start len)
(clear-highlights))
(define/augment (after-delete start len)
(clear-highlights))
(super-new)))
(drracket:get/extend:extend-definitions-text highlights-mixin))
(define-compound-unit/infer tool@
(define-unit tool@
(import drracket:tool^)
(export drracket:tool-exports^)
(link pre-tool@ report@))
(define (phase1) (void))
(define (phase2) (void))
(drracket:get/extend:extend-definitions-text highlights-mixin))
(define performance-report-drracket-button
(list