diff --git a/drracket-core-lib/drracket/drracket.rkt b/drracket-core-lib/drracket/drracket.rkt index bb2c621c4..6f3647f00 100644 --- a/drracket-core-lib/drracket/drracket.rkt +++ b/drracket-core-lib/drracket/drracket.rkt @@ -24,17 +24,15 @@ (flush-output)) (define (run-trace-thread) - (let ([evt (make-log-receiver (current-logger) 'info)]) - (void - (thread - (λ () - (let loop () - (define vec (sync evt)) - (define str (vector-ref vec 1)) - (when (regexp-match #rx"^cm: *compil(ing|ed)" str) - (display str) - (newline)) - (loop))))))) + (define evt (make-log-receiver (current-logger) 'info)) + (void (thread (λ () + (let loop () + (define vec (sync evt)) + (define str (vector-ref vec 1)) + (when (regexp-match #rx"^cm: *compil(ing|ed)" str) + (display str) + (newline)) + (loop)))))) (cond [debugging? @@ -57,14 +55,14 @@ (run-trace-thread)))] [install-cm? (flprintf "PLTDRCM: loading compilation manager\n") - (let ([make-compilation-manager-load/use-compiled-handler - (parameterize ([current-namespace (make-base-empty-namespace)]) - (dynamic-require 'compiler/cm 'make-compilation-manager-load/use-compiled-handler))]) - (flprintf "PLTDRCM: installing compilation manager\n") - (current-load/use-compiled (make-compilation-manager-load/use-compiled-handler)) - (when cm-trace? - (flprintf "PLTDRCM: enabling CM tracing\n") - (run-trace-thread)))] + (define make-compilation-manager-load/use-compiled-handler + (parameterize ([current-namespace (make-base-empty-namespace)]) + (dynamic-require 'compiler/cm 'make-compilation-manager-load/use-compiled-handler))) + (flprintf "PLTDRCM: installing compilation manager\n") + (current-load/use-compiled (make-compilation-manager-load/use-compiled-handler)) + (when cm-trace? + (flprintf "PLTDRCM: enabling CM tracing\n") + (run-trace-thread))] [first-parallel? (flprintf "PLTDRPAR: loading compilation manager\n") (define tools? (not (getenv "PLTNOTOOLS"))) @@ -90,19 +88,17 @@ (define (tool-files id) (apply append - (map - (λ (x) - (define proc (get-info/full x)) - (if proc - (map (λ (dirs) - (apply build-path - x - (if (list? dirs) - dirs - (list dirs)))) - (proc id (λ () '()))) - '())) - (find-relevant-directories (list id))))) + (for/list ([x (in-list (find-relevant-directories (list id)))]) + (define proc (get-info/full x)) + (if proc + (map (λ (dirs) + (apply build-path + x + (if (list? dirs) + dirs + (list dirs)))) + (proc id (λ () '()))) + '())))) (define make-compilation-manager-load/use-compiled-handler (parameterize ([current-namespace (make-base-empty-namespace)]) @@ -146,11 +142,11 @@ ;; it creates a new custodian and installs it, but the ;; original eventspace was created on the original custodian ;; and this code does not create a new eventspace. - (let ([orig-cust (current-custodian)] - [orig-eventspace (current-eventspace)] - [new-cust (make-custodian)]) - (current-custodian new-cust) - ((dynamic-require 'drracket/private/profile-drs 'start-profile) orig-cust))) + (define orig-cust (current-custodian)) + (current-eventspace) + (define new-cust (make-custodian)) + (current-custodian new-cust) + ((dynamic-require 'drracket/private/profile-drs 'start-profile) orig-cust)) (dynamic-require 'drracket/private/drracket-normal #f) diff --git a/drracket-core-lib/drracket/sprof.rkt b/drracket-core-lib/drracket/sprof.rkt index 0f5062686..9cfe9e625 100644 --- a/drracket-core-lib/drracket/sprof.rkt +++ b/drracket-core-lib/drracket/sprof.rkt @@ -14,44 +14,40 @@ (define traces-table (make-hash)) (let loop ([i 0]) (sleep pause-time) - (let ([new-traces - (map (λ (t) (continuation-mark-set->context (continuation-marks t))) - (get-threads))]) - (for-each - (λ (trace) - (for-each - (λ (line) - (hash-set! traces-table line (cons trace (hash-ref traces-table line '())))) - trace)) - new-traces) - (cond - [(zero? i) - (update-gui traces-table) - (loop update-frequency)] - [else - (loop (- i 1))])))))) + (define new-traces + (map (λ (t) (continuation-mark-set->context (continuation-marks t))) (get-threads))) + (for-each (λ (trace) + (for-each (λ (line) + (hash-set! traces-table + line + (cons trace (hash-ref traces-table line '())))) + trace)) + new-traces) + (cond + [(zero? i) + (update-gui traces-table) + (loop update-frequency)] + [else (loop (- i 1))]))))) (define (format-fn-name i) - (let ([id (car i)] - [src (cdr i)]) - (cond - [id (format "~a" id)] - [src - (format "~a:~a~a" - (cond - [(path? (srcloc-source src)) - (let-values ([(base name dir?) (split-path (srcloc-source src))]) - name)] - [else (srcloc-source src)]) - (if (srcloc-line src) - (format "~a:~a" - (srcloc-line src) - (srcloc-column src)) - (srcloc-position src)) - (if id - (format ": ~a" id) - ""))] - [else "???"]))) + (define id (car i)) + (define src (cdr i)) + (cond + [id (format "~a" id)] + [src + (format "~a:~a~a" + (cond + [(path? (srcloc-source src)) + (let-values ([(base name dir?) (split-path (srcloc-source src))]) + name)] + [else (srcloc-source src)]) + (if (srcloc-line src) + (format "~a:~a" (srcloc-line src) (srcloc-column src)) + (srcloc-position src)) + (if id + (format ": ~a" id) + ""))] + [else "???"])) (define (insert-long-fn-name t i) (send t begin-edit-sequence) @@ -76,8 +72,8 @@ (send t end-edit-sequence)) (define (format-percentage n) - (let ([trunc (floor (* n 100))]) - (format "~a%" (pad3 trunc)))) + (define trunc (floor (* n 100))) + (format "~a%" (pad3 trunc))) (define (pad3 n) (cond @@ -110,16 +106,16 @@ (define/override (on-event event) (cond [(send event button-up? 'left) - (let ([admin (get-admin)]) - (when admin - (let ([dc (send admin get-dc)]) - (let-values ([(x y) (dc-location-to-editor-location (send event get-x) - (send event get-y))]) - (let* ([loc (find-position x y)] - [para (position-paragraph loc)]) - (set! clicked-srcloc-pr (and (<= 0 para (last-paragraph)) - (car (list-ref gui-display-data para)))) - (update-gui-display))))))] + (define admin (get-admin)) + (when admin + (let ([dc (send admin get-dc)]) + (let-values ([(x y) (dc-location-to-editor-location (send event get-x) + (send event get-y))]) + (let* ([loc (find-position x y)] + [para (position-paragraph loc)]) + (set! clicked-srcloc-pr + (and (<= 0 para (last-paragraph)) (car (list-ref gui-display-data para)))) + (update-gui-display)))))] [else (void)])) (define/public (set-gui-display-data/refresh traces-table) @@ -140,42 +136,42 @@ (set! line-to-source (make-hasheq)) (clear-old-pr) (set! clear-old-pr void) - (let* ([denom-ht (make-hasheq)] - [filtered-gui-display-data - (map - (λ (pr) - (let ([id (car pr)] - [stacks (filter-stacks (cdr pr))]) - (for-each (λ (stack) (hash-set! denom-ht stack #t)) stacks) - (cons id stacks))) - gui-display-data)] - [denom-count (hash-count denom-ht)]) - (let loop ([prs filtered-gui-display-data] - [first? #t] - [i 0]) - (cond - [(null? prs) (void)] - [else - (let* ([pr (car prs)] - [fn (car pr)] - [count (length (cdr pr))]) - (cond - [(zero? count) - (loop (cdr prs) first? i)] - [else - (unless first? (insert "\n")) - (let ([before (last-position)]) - (hash-set! line-to-source i pr) - (insert (format-percentage (/ count denom-count))) - (insert (format " ~a" (format-fn-name fn))) - (let ([after (last-position)]) - (when (equal? (car pr) clicked-srcloc-pr) - (set! clear-old-pr (highlight-range before after "NavajoWhite"))))) - (loop (cdr prs) #f (+ i 1))]))])) - (lock #t) - (end-edit-sequence) - (update-info-editor clicked-srcloc-pr) - (send open-button enable (and clicked-srcloc-pr (path? (srcloc-source (cdr clicked-srcloc-pr))))))) + (define denom-ht (make-hasheq)) + (define filtered-gui-display-data + (map (λ (pr) + (let ([id (car pr)] + [stacks (filter-stacks (cdr pr))]) + (for-each (λ (stack) (hash-set! denom-ht stack #t)) stacks) + (cons id stacks))) + gui-display-data)) + (define denom-count (hash-count denom-ht)) + (let loop ([prs filtered-gui-display-data] + [first? #t] + [i 0]) + (cond + [(null? prs) (void)] + [else + (let* ([pr (car prs)] + [fn (car pr)] + [count (length (cdr pr))]) + (cond + [(zero? count) (loop (cdr prs) first? i)] + [else + (unless first? + (insert "\n")) + (let ([before (last-position)]) + (hash-set! line-to-source i pr) + (insert (format-percentage (/ count denom-count))) + (insert (format " ~a" (format-fn-name fn))) + (let ([after (last-position)]) + (when (equal? (car pr) clicked-srcloc-pr) + (set! clear-old-pr (highlight-range before after "NavajoWhite"))))) + (loop (cdr prs) #f (+ i 1))]))])) + (lock #t) + (end-edit-sequence) + (update-info-editor clicked-srcloc-pr) + (send open-button enable + (and clicked-srcloc-pr (path? (srcloc-source (cdr clicked-srcloc-pr)))))) (define/private (filter-stacks stacks) (cond @@ -187,11 +183,11 @@ (define/public (open-current-pr) (when clicked-srcloc-pr - (let ([src (cdr clicked-srcloc-pr)]) - (when (path? (srcloc-source src)) - (printf "open ~s\n" (srcloc-source src)) - (when (number? (srcloc-position src)) - (printf "go to ~s\n" (srcloc-position src))))))) + (define src (cdr clicked-srcloc-pr)) + (when (path? (srcloc-source src)) + (printf "open ~s\n" (srcloc-source src)) + (when (number? (srcloc-position src)) + (printf "go to ~s\n" (srcloc-position src)))))) (define/private (update-info-editor pr) (send vp change-children (λ (l) (if pr (list ec1 lp) (list ec1)))) @@ -295,17 +291,15 @@ (define show/hide-menu-item #f) (define/public (show/hide-sprof-panel show?) - (let ([main-children (send main-panel get-children)]) - (send show/hide-menu-item - set-label - (if show? sc-hide-sprof sc-show-sprof)) - (unless (or (and show? (= 2 (length main-children))) - (and (not show?) (= 1 (length main-children)))) - (send main-panel change-children - (λ (l) - (if show? - (list everything-else sprof-main-panel) - (list everything-else))))))) + (define main-children (send main-panel get-children)) + (send show/hide-menu-item set-label (if show? sc-hide-sprof sc-show-sprof)) + (unless (or (and show? (= 2 (length main-children))) + (and (not show?) (= 1 (length main-children)))) + (send main-panel change-children + (λ (l) + (if show? + (list everything-else sprof-main-panel) + (list everything-else)))))) (define/override (make-root-area-container cls parent) (set! main-panel (super make-root-area-container panel:horizontal-dragable% parent)) @@ -377,15 +371,14 @@ (mixin (drscheme:rep:text<%>) () (inherit get-user-custodian) (define/public (get-threads-to-profile) - (let ([thds '()]) - (let loop ([cust (get-user-custodian)]) - (for-each - (λ (obj) - (cond - [(custodian? obj) (loop obj)] - [(thread? obj) (set! thds (cons obj thds))])) - (custodian-managed-list cust system-custodian))) - thds)) + (define thds '()) + (let loop ([cust (get-user-custodian)]) + (for-each (λ (obj) + (cond + [(custodian? obj) (loop obj)] + [(thread? obj) (set! thds (cons obj thds))])) + (custodian-managed-list cust system-custodian))) + thds) ;; FIX ;; something needs to happen here so that the profiling gets shutdown when the repl dies. diff --git a/drracket/drracket/plt-installer-tool.rkt b/drracket/drracket/plt-installer-tool.rkt index 75ccd5279..e506344aa 100644 --- a/drracket/drracket/plt-installer-tool.rkt +++ b/drracket/drracket/plt-installer-tool.rkt @@ -77,15 +77,14 @@ ;; browse : -> void ;; gets the name of a file from the user and updates file-text-field (define (browse) - (let ([filename (parameterize ([finder:default-extension "plt"] - [finder:default-filters - (if (eq? (system-type) 'macosx) - (finder:default-filters) - '(("PLT Files" "*.plt") - ("Any" "*.*")))]) - (finder:get-file #f "" #f "" dialog))]) - (when filename - (send file-text-field set-value (path->string filename))))) + (define filename + (parameterize ([finder:default-extension "plt"] + [finder:default-filters (if (eq? (system-type) 'macosx) + (finder:default-filters) + '(("PLT Files" "*.plt") ("Any" "*.*")))]) + (finder:get-file #f "" #f "" dialog))) + (when filename + (send file-text-field set-value (path->string filename)))) ;; from-web? : -> boolean ;; returns #t if the user has selected a web address (define (from-web?) diff --git a/drracket/gui-debugger/debug-tool.rkt b/drracket/gui-debugger/debug-tool.rkt index cc54b8510..ce8e80c38 100644 --- a/drracket/gui-debugger/debug-tool.rkt +++ b/drracket/gui-debugger/debug-tool.rkt @@ -266,10 +266,10 @@ (cond [(not (unbox on-it?)) (values #f #f)] [else - (let ([snip (send editor find-snip pos 'after-or-none)]) - (if (and snip (is-a? snip editor-snip%)) - (loop (send snip get-editor)) - (values pos editor)))])] + (define snip (send editor find-snip pos 'after-or-none)) + (if (and snip (is-a? snip editor-snip%)) + (loop (send snip get-editor)) + (values pos editor))])] [(is-a? editor pasteboard%) (define snip (send editor find-snip x y)) (if (and snip (is-a? snip editor-snip%)) @@ -764,69 +764,69 @@ (run-in-evaluation-thread (lambda () ;(print-struct #t) - (let ([self (current-thread)] - [oeh (uncaught-exception-handler)] - [err-hndlr (error-display-handler)]) - (set! debugged-thread self) - (error-display-handler - (lambda (msg exn) - (err-hndlr msg exn) - (when (and (eq? self (current-thread)) (exn:fail? exn)) - (send (get-tab) suspend - oeh - (continuation-mark-set->list (exn-continuation-marks exn) debug-key) - 'error)))) ; this breaks the buttons because it looks like we can resume - (current-eval - (make-debug-eval-handler - (current-eval) - ; break? -- curried to avoid looking up defs from source each time - (lambda (src) - (let* ([defs (filename->defs src)] - [src-tab (if defs - (send defs get-tab) - (get-tab))] - [breakpoints (if src - (send src-tab get-breakpoints) - breakpoints)] - [single-step? (send tab get-single-step-box)] - [closed? (send src-tab get-closed-box)]) - (lambda (pos) - (and (not (unbox closed?)) - (or (unbox single-step?) - (let ([bp (hash-ref breakpoints pos #f)]) - (if (procedure? bp) - (bp) - bp))))))) - ; break-before - (lambda (top-mark ccm) - (define debug-marks (continuation-mark-set->list ccm debug-key)) - (send (get-tab) suspend oeh (cons top-mark debug-marks) 'entry-break)) - ; break-after - (case-lambda - [(top-mark ccm val) - (let* ([debug-marks (continuation-mark-set->list ccm debug-key)]) - (car (send (get-tab) suspend - oeh - (cons top-mark debug-marks) - (list 'exit-break val))))] - [(top-mark ccm . vals) - (define debug-marks (continuation-mark-set->list ccm debug-key)) - (apply values - (send (get-tab) suspend - oeh - (cons top-mark debug-marks) - (cons 'exit-break vals)))]))) - (uncaught-exception-handler - (lambda (exn) - (if (and (exn:break? exn) (send (get-tab) suspend-on-break?)) - (let ([marks (exn-continuation-marks exn)] - [cont (exn:break-continuation exn)]) - (send (get-tab) suspend - oeh - (continuation-mark-set->list marks debug-key) - 'break) - (cont)) - (oeh exn)))))))))))) + (define self (current-thread)) + (define oeh (uncaught-exception-handler)) + (define err-hndlr (error-display-handler)) + (set! debugged-thread self) + (error-display-handler + (lambda (msg exn) + (err-hndlr msg exn) + (when (and (eq? self (current-thread)) (exn:fail? exn)) + (send (get-tab) suspend + oeh + (continuation-mark-set->list (exn-continuation-marks exn) debug-key) + 'error)))) ; this breaks the buttons because it looks like we can resume + (current-eval + (make-debug-eval-handler + (current-eval) + ; break? -- curried to avoid looking up defs from source each time + (lambda (src) + (let* ([defs (filename->defs src)] + [src-tab (if defs + (send defs get-tab) + (get-tab))] + [breakpoints (if src + (send src-tab get-breakpoints) + breakpoints)] + [single-step? (send tab get-single-step-box)] + [closed? (send src-tab get-closed-box)]) + (lambda (pos) + (and (not (unbox closed?)) + (or (unbox single-step?) + (let ([bp (hash-ref breakpoints pos #f)]) + (if (procedure? bp) + (bp) + bp))))))) + ; break-before + (lambda (top-mark ccm) + (define debug-marks (continuation-mark-set->list ccm debug-key)) + (send (get-tab) suspend oeh (cons top-mark debug-marks) 'entry-break)) + ; break-after + (case-lambda + [(top-mark ccm val) + (let* ([debug-marks (continuation-mark-set->list ccm debug-key)]) + (car (send (get-tab) suspend + oeh + (cons top-mark debug-marks) + (list 'exit-break val))))] + [(top-mark ccm . vals) + (define debug-marks (continuation-mark-set->list ccm debug-key)) + (apply values + (send (get-tab) suspend + oeh + (cons top-mark debug-marks) + (cons 'exit-break vals)))]))) + (uncaught-exception-handler + (lambda (exn) + (if (and (exn:break? exn) (send (get-tab) suspend-on-break?)) + (let ([marks (exn-continuation-marks exn)] + [cont (exn:break-continuation exn)]) + (send (get-tab) suspend + oeh + (continuation-mark-set->list marks debug-key) + 'break) + (cont)) + (oeh exn))))))))))) (define (debug-tab-mixin super%) (class super% @@ -1038,34 +1038,35 @@ (send (get-frame) register-stack-frames frames already-stopped?) (send (get-frame) register-vars (list-ref frames (get-frame-num)))) (send status-message set-label - (if (and (cons? status) top-of-stack?) - (let ([expr (mark-source (first frames))]) - (cond - ; should succeed unless the user closes a secondary tab during debugging - [(filename->defs (syntax-source expr)) - => (lambda (defs) - (clean-status - (string-append - (if (syntax-position expr) - (trim-expr-str - (send defs get-text - (sub1 (syntax-position expr)) - (+ -1 (syntax-position expr) (syntax-span expr)))) - "??") - " => " - (if (= 2 (length status)) - (or (render (cadr status)) "??") - (string-append - "(values" - (let loop ([vals (rest status)]) - (cond - [(cons? vals) (string-append " " - (or (render (first vals)) - "??") - (loop (rest vals)))] - [else ")"])))))))] - [""])) - "")) + (cond + [(and (cons? status) top-of-stack?) + (define expr (mark-source (first frames))) + (cond + ; should succeed unless the user closes a secondary tab during debugging + [(filename->defs (syntax-source expr)) + => + (lambda (defs) + (clean-status + (string-append + (if (syntax-position expr) + (trim-expr-str + (send defs get-text + (sub1 (syntax-position expr)) + (+ -1 (syntax-position expr) (syntax-span expr)))) + "??") + " => " + (if (= 2 (length status)) + (or (render (cadr status)) "??") + (string-append "(values" + (let loop ([vals (rest status)]) + (cond + [(cons? vals) + (string-append " " + (or (render (first vals)) "??") + (loop (rest vals)))] + [else ")"])))))))] + [""])] + [else ""])) (cond [(get-current-frame-endpoints) => (lambda (start/end) (cond [(and (first start/end) (defs-containing-current-frame)) @@ -1198,13 +1199,12 @@ [else (already-debugging tab)])) (define/override (execute-callback) - (let ([tab (get-current-tab)]) - (cond - [(eq? tab (send tab get-primary)) - (send (get-current-tab) prepare-execution debug?) - (super execute-callback)] - [else - (already-debugging tab)]))) + (define tab (get-current-tab)) + (cond + [(eq? tab (send tab get-primary)) + (send (get-current-tab) prepare-execution debug?) + (super execute-callback)] + [else (already-debugging tab)])) (define/private (already-debugging tab) (message-box @@ -1220,19 +1220,19 @@ (send variables-text begin-edit-sequence) (send variables-text lock #f) (send variables-text delete 0 (send variables-text last-position)) - (for-each - (lambda (name/value) - (let ([name (format "~a" (syntax-e (first name/value)))] - [value (format " => ~s\n" (truncate-value (second name/value) 88 4))]) - (send variables-text insert name) - (send variables-text change-style bold-sd - (- (send variables-text last-position) (string-length name)) - (send variables-text last-position)) - (send variables-text insert value) - (send variables-text change-style normal-sd - (- (send variables-text last-position) (string-length value)) - (send variables-text last-position)))) - (third (expose-mark frame))) + (for ([name/value (in-list (third (expose-mark frame)))]) + (define name (format "~a" (syntax-e (first name/value)))) + (define value (format " => ~s\n" (truncate-value (second name/value) 88 4))) + (send variables-text insert name) + (send variables-text change-style + bold-sd + (- (send variables-text last-position) (string-length name)) + (send variables-text last-position)) + (send variables-text insert value) + (send variables-text change-style + normal-sd + (- (send variables-text last-position) (string-length value)) + (send variables-text last-position))) (send variables-text lock #t) (send variables-text end-edit-sequence)) @@ -1385,11 +1385,11 @@ (set! debug-parent-panel (make-object vertical-pane% debug-grandparent-panel)) ;; horizontal panel with debug buttons; not vertically stretchable - (set! debug-panel (instantiate horizontal-panel% () - (parent debug-parent-panel) - (stretchable-height #f) - (alignment '(center center)) - (style '(border)))) + (set! debug-panel (new horizontal-panel% + (parent debug-parent-panel) + (stretchable-height #f) + (alignment '(center center)) + (style '(border)))) ;; add a close button to the debug panel (new close-icon% [parent debug-panel] @@ -1417,10 +1417,7 @@ (super-new) (define status-message - (instantiate message% () - [label " "] - [parent debug-panel] - [stretchable-width #t])) + (new message% [label " "] [parent debug-panel] [stretchable-width #t])) (define debug-button (new switchable-button%