rework online compilation's internals
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
parent
e19243329c
commit
938959611e
|
|
@ -5,7 +5,7 @@
|
|||
compiler/cm)
|
||||
(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)
|
||||
(struct handler (key proc))
|
||||
|
|
@ -70,12 +70,12 @@
|
|||
(continuation-marks
|
||||
(job-working-thd job))))
|
||||
(ep-log-info (format "expanding-place.rkt: kill; worker-thd stack (size ~a) dead? ~a:"
|
||||
(length stack)
|
||||
(thread-dead? (job-working-thd job))))
|
||||
(length stack)
|
||||
(thread-dead? (job-working-thd job))))
|
||||
(for ([x (in-list stack)])
|
||||
(ep-log-info (format " ~s" x))))
|
||||
(custodian-shutdown-all (job-cust job))
|
||||
(place-channel-put (job-response-pc job) #f))
|
||||
((job-stop-watching-abnormal-termination job))
|
||||
(custodian-shutdown-all (job-cust job)))
|
||||
|
||||
(struct exn:access exn:fail ())
|
||||
|
||||
|
|
@ -114,7 +114,7 @@
|
|||
(parameterize ([current-custodian orig-cust])
|
||||
(thread
|
||||
(λ ()
|
||||
(channel-put normal-termination #t)
|
||||
(stop-watching-abnormal-termination)
|
||||
(semaphore-post sema)
|
||||
(channel-put exn-chan exn))))
|
||||
(semaphore-wait sema)
|
||||
|
|
@ -160,7 +160,7 @@
|
|||
(parameterize ([current-custodian orig-cust])
|
||||
(thread
|
||||
(λ ()
|
||||
(channel-put normal-termination #t)
|
||||
(stop-watching-abnormal-termination)
|
||||
(semaphore-post sema)
|
||||
(channel-put result-chan handler-results))))
|
||||
(semaphore-wait sema)
|
||||
|
|
@ -168,13 +168,19 @@
|
|||
|
||||
(thread
|
||||
(λ ()
|
||||
(sync
|
||||
(handle-evt
|
||||
normal-termination
|
||||
(λ (x) (void)))
|
||||
(handle-evt
|
||||
(thread-dead-evt working-thd)
|
||||
(λ (x) (channel-put abnormal-termination #t))))))
|
||||
(let loop ([watch-dead? #t])
|
||||
(sync
|
||||
(handle-evt
|
||||
normal-termination
|
||||
(λ (x) (loop #f)))
|
||||
(if watch-dead?
|
||||
(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
|
||||
(λ ()
|
||||
|
|
@ -184,7 +190,11 @@
|
|||
(λ (val)
|
||||
(place-channel-put
|
||||
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
|
||||
result-chan
|
||||
(λ (val)
|
||||
|
|
@ -194,39 +204,39 @@
|
|||
(λ (exn)
|
||||
(place-channel-put
|
||||
response-pc
|
||||
(cond
|
||||
[(exn:access? exn)
|
||||
(vector 'access-violation (exn-message exn))]
|
||||
[else
|
||||
(vector
|
||||
(cond
|
||||
[(and (exn:fail:read? exn)
|
||||
(andmap (λ (srcloc) (equal? (srcloc-source srcloc) the-source))
|
||||
(exn:fail:read-srclocs exn)))
|
||||
'reader-in-defs-error]
|
||||
[(and (exn? exn)
|
||||
(regexp-match #rx"expand: unbound identifier" (exn-message exn)))
|
||||
'exn:variable]
|
||||
[else 'exn])
|
||||
(trim-message
|
||||
(if (exn? exn)
|
||||
(regexp-replace* #rx"[ \t]*\n[ \t]*" (exn-message exn) " ")
|
||||
(format "uncaught exn: ~s" exn)))
|
||||
(if (exn:srclocs? exn)
|
||||
(sort
|
||||
(filter
|
||||
values
|
||||
(for/list ([srcloc ((exn:srclocs-accessor exn) exn)])
|
||||
(and (srcloc? srcloc)
|
||||
(equal? the-source (srcloc-source srcloc))
|
||||
(srcloc-position srcloc)
|
||||
(srcloc-span srcloc)
|
||||
(vector (srcloc-position srcloc)
|
||||
(srcloc-span srcloc)))))
|
||||
<
|
||||
#:key (λ (x) (vector-ref x 0)))
|
||||
'()))])))))))
|
||||
(job cust response-pc working-thd))
|
||||
(vector
|
||||
(cond
|
||||
[(exn:access? exn)
|
||||
'access-violation]
|
||||
[(and (exn:fail:read? exn)
|
||||
(andmap (λ (srcloc) (equal? (srcloc-source srcloc) the-source))
|
||||
(exn:fail:read-srclocs exn)))
|
||||
'reader-in-defs-error]
|
||||
[(and (exn? exn)
|
||||
(regexp-match #rx"expand: unbound identifier" (exn-message exn)))
|
||||
'exn:variable]
|
||||
[else 'exn])
|
||||
(trim-message
|
||||
(if (exn? exn)
|
||||
(regexp-replace* #rx"[ \t]*\n[ \t]*" (exn-message exn) " ")
|
||||
(format "uncaught exn: ~s" exn)))
|
||||
(if (exn:srclocs? exn)
|
||||
(sort
|
||||
(for/list ([srcloc ((exn:srclocs-accessor exn) exn)]
|
||||
#:when (and (srcloc? srcloc)
|
||||
(equal? the-source (srcloc-source srcloc))
|
||||
(srcloc-position srcloc)
|
||||
(srcloc-span srcloc)))
|
||||
(vector (srcloc-position srcloc)
|
||||
(srcloc-span srcloc)))
|
||||
<
|
||||
#:key (λ (x) (vector-ref x 0)))
|
||||
'()))))))))
|
||||
|
||||
(define (stop-watching-abnormal-termination)
|
||||
(channel-put normal-termination #t))
|
||||
|
||||
(job cust response-pc working-thd stop-watching-abnormal-termination))
|
||||
|
||||
(define (catch-and-log port sema)
|
||||
(let loop ()
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -2090,7 +2090,7 @@ If the namespace does not, they are colored the unbound color.
|
|||
(λ (defs-text val)
|
||||
(log-timeline
|
||||
"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
|
||||
defs-text
|
||||
val))))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user