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

rework online compilation's internals

Browse Source 
Things should now generally be set up to work better --
for example online check syntax is smarter now about
what happens when switching tabs/frames and this also
makes it easier to add new ways for a window to become
dirty (that is, for it to be known that it needs to
be recompiled)
This commit is contained in:
Robby Findler 2012-12-14 14:58:51 -06:00
parent e19243329c
commit 938959611e
3 changed files with 842 additions and 528 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

106
collects/drracket/private/expanding-place.rkt
View File

@ -5,7 +5,7 @@
compiler/cm) compiler/cm)
(provide start) (provide start)
(struct job (cust response-pc working-thd)) (struct job (cust response-pc working-thd stop-watching-abnormal-termination))
;; key : any (used by equal? for comparision, but back in the main place) ;; key : any (used by equal? for comparision, but back in the main place)
(struct handler (key proc)) (struct handler (key proc))
@ -70,12 +70,12 @@
(continuation-marks (continuation-marks
(job-working-thd job)))) (job-working-thd job))))
(ep-log-info (format "expanding-place.rkt: kill; worker-thd stack (size ~a) dead? ~a:" (ep-log-info (format "expanding-place.rkt: kill; worker-thd stack (size ~a) dead? ~a:"
(length stack) (length stack)
(thread-dead? (job-working-thd job)))) (thread-dead? (job-working-thd job))))
(for ([x (in-list stack)]) (for ([x (in-list stack)])
(ep-log-info (format " ~s" x)))) (ep-log-info (format " ~s" x))))
(custodian-shutdown-all (job-cust job)) ((job-stop-watching-abnormal-termination job))
(place-channel-put (job-response-pc job) #f)) (custodian-shutdown-all (job-cust job)))
(struct exn:access exn:fail ()) (struct exn:access exn:fail ())
@ -114,7 +114,7 @@
(parameterize ([current-custodian orig-cust]) (parameterize ([current-custodian orig-cust])
(thread (thread
(λ () (λ ()
(channel-put normal-termination #t) (stop-watching-abnormal-termination)
(semaphore-post sema) (semaphore-post sema)
(channel-put exn-chan exn)))) (channel-put exn-chan exn))))
(semaphore-wait sema) (semaphore-wait sema)
@ -160,7 +160,7 @@
(parameterize ([current-custodian orig-cust]) (parameterize ([current-custodian orig-cust])
(thread (thread
(λ () (λ ()
(channel-put normal-termination #t) (stop-watching-abnormal-termination)
(semaphore-post sema) (semaphore-post sema)
(channel-put result-chan handler-results)))) (channel-put result-chan handler-results))))
(semaphore-wait sema) (semaphore-wait sema)
@ -168,13 +168,19 @@
(thread (thread
(λ () (λ ()
(sync (let loop ([watch-dead? #t])
(handle-evt (sync
normal-termination (handle-evt
(λ (x) (void))) normal-termination
(handle-evt (λ (x) (loop #f)))
(thread-dead-evt working-thd) (if watch-dead?
(λ (x) (channel-put abnormal-termination #t)))))) (handle-evt
(thread-dead-evt working-thd)
(λ (x)
(ep-log-info "expanding-place.rkt: abnormal termination")
(channel-put abnormal-termination #t)
(loop #f)))
never-evt)))))
(thread (thread
(λ () (λ ()
@ -184,7 +190,11 @@
(λ (val) (λ (val)
(place-channel-put (place-channel-put
response-pc response-pc
(vector 'abnormal-termination)))) (vector 'abnormal-termination
;; note: this message is actually ignored: a string
;; constant is used back in the drracket place
"Expansion thread terminated unexpectedly"
'()))))
(handle-evt (handle-evt
result-chan result-chan
(λ (val) (λ (val)
@ -194,39 +204,39 @@
(λ (exn) (λ (exn)
(place-channel-put (place-channel-put
response-pc response-pc
(cond (vector
[(exn:access? exn) (cond
(vector 'access-violation (exn-message exn))] [(exn:access? exn)
[else 'access-violation]
(vector [(and (exn:fail:read? exn)
(cond (andmap (λ (srcloc) (equal? (srcloc-source srcloc) the-source))
[(and (exn:fail:read? exn) (exn:fail:read-srclocs exn)))
(andmap (λ (srcloc) (equal? (srcloc-source srcloc) the-source)) 'reader-in-defs-error]
(exn:fail:read-srclocs exn))) [(and (exn? exn)
'reader-in-defs-error] (regexp-match #rx"expand: unbound identifier" (exn-message exn)))
[(and (exn? exn) 'exn:variable]
(regexp-match #rx"expand: unbound identifier" (exn-message exn))) [else 'exn])
'exn:variable] (trim-message
[else 'exn]) (if (exn? exn)
(trim-message (regexp-replace* #rx"[ \t]*\n[ \t]*" (exn-message exn) " ")
(if (exn? exn) (format "uncaught exn: ~s" exn)))
(regexp-replace* #rx"[ \t]*\n[ \t]*" (exn-message exn) " ") (if (exn:srclocs? exn)
(format "uncaught exn: ~s" exn))) (sort
(if (exn:srclocs? exn) (for/list ([srcloc ((exn:srclocs-accessor exn) exn)]
(sort #:when (and (srcloc? srcloc)
(filter (equal? the-source (srcloc-source srcloc))
values (srcloc-position srcloc)
(for/list ([srcloc ((exn:srclocs-accessor exn) exn)]) (srcloc-span srcloc)))
(and (srcloc? srcloc) (vector (srcloc-position srcloc)
(equal? the-source (srcloc-source srcloc)) (srcloc-span srcloc)))
(srcloc-position srcloc) <
(srcloc-span srcloc) #:key (λ (x) (vector-ref x 0)))
(vector (srcloc-position srcloc) '()))))))))
(srcloc-span srcloc)))))
< (define (stop-watching-abnormal-termination)
#:key (λ (x) (vector-ref x 0))) (channel-put normal-termination #t))
'()))])))))))
(job cust response-pc working-thd)) (job cust response-pc working-thd stop-watching-abnormal-termination))
(define (catch-and-log port sema) (define (catch-and-log port sema)
(let loop () (let loop ()

1262
collects/drracket/private/module-language.rkt
View File

File diff suppressed because it is too large Load Diff

2
collects/drracket/private/syncheck/gui.rkt
View File

@ -2090,7 +2090,7 @@ If the namespace does not, they are colored the unbound color.
(λ (defs-text val) (λ (defs-text val)
(log-timeline (log-timeline
"replace-compile-comp-trace" "replace-compile-comp-trace"
(send (send (send defs-text get-canvas) get-top-level-window) (send (send (send defs-text get-tab) get-frame)
replay-compile-comp-trace replay-compile-comp-trace
defs-text defs-text
val)))))) val))))))