From d794d33b5e9690c774a5b4c4a3450fb947473976 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Fri, 29 Jul 2011 12:23:54 -0400 Subject: [PATCH] Go back to previous expansion strategy. 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 96eee2b317f433923ea1f5637e28de5375de76af. This reverts commit 19ce4d44a5ead66896b2edd6533180e4bf0d45d1. This reverts commit 58fbd8ba75a3a68a119c99ee2547e3a01a7ccc0f. This reverts commit b305ea9c627de59f5422f74386833bbdea8781df. This reverts commit 860feb30ae8e6baedb15ef46d6f51956ce29bc4b. --- .../typed-scheme/optimizer/tool/display.rkt | 2 +- .../optimizer/tool/report-sig.rkt | 3 - .../optimizer/tool/report-structs.rkt | 18 ---- .../typed-scheme/optimizer/tool/report.rkt | 95 +++++++--------- collects/typed-scheme/optimizer/tool/tool.rkt | 102 ++++++++---------- 5 files changed, 84 insertions(+), 136 deletions(-) delete mode 100644 collects/typed-scheme/optimizer/tool/report-sig.rkt delete mode 100644 collects/typed-scheme/optimizer/tool/report-structs.rkt diff --git a/collects/typed-scheme/optimizer/tool/display.rkt b/collects/typed-scheme/optimizer/tool/display.rkt index 598f165c35..f63f387070 100644 --- a/collects/typed-scheme/optimizer/tool/display.rkt +++ b/collects/typed-scheme/optimizer/tool/display.rkt @@ -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) diff --git a/collects/typed-scheme/optimizer/tool/report-sig.rkt b/collects/typed-scheme/optimizer/tool/report-sig.rkt deleted file mode 100644 index e5302f8895..0000000000 --- a/collects/typed-scheme/optimizer/tool/report-sig.rkt +++ /dev/null @@ -1,3 +0,0 @@ -#lang racket/signature - -generate-report diff --git a/collects/typed-scheme/optimizer/tool/report-structs.rkt b/collects/typed-scheme/optimizer/tool/report-structs.rkt deleted file mode 100644 index 09216f94c9..0000000000 --- a/collects/typed-scheme/optimizer/tool/report-structs.rkt +++ /dev/null @@ -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)) diff --git a/collects/typed-scheme/optimizer/tool/report.rkt b/collects/typed-scheme/optimizer/tool/report.rkt index 5a60e4eba4..706664c55d 100644 --- a/collects/typed-scheme/optimizer/tool/report.rkt +++ b/collects/typed-scheme/optimizer/tool/report.rkt @@ -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 diff --git a/collects/typed-scheme/optimizer/tool/tool.rkt b/collects/typed-scheme/optimizer/tool/tool.rkt index bab56adbeb..2647346faf 100644 --- a/collects/typed-scheme/optimizer/tool/tool.rkt +++ b/collects/typed-scheme/optimizer/tool/tool.rkt @@ -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