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

Abstracted the multi-thread pattern into a coroutine API now in mzlib's

Browse Source 
thread.ss.  We now create a new thread for each coroutine instead of
trying to reuse the same one via break signals.

original commit: 063768e8c602e6dc3d45628bee7d2d0603958ce3
This commit is contained in:
Scott Owens 2004-11-30 18:15:06 +00:00
parent 00327c9327
commit 188eaecd21
1 changed files with 44 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

122
collects/framework/private/color.ss
View File

@ -2,6 +2,7 @@
(require (lib "class.ss") (require (lib "class.ss")
(lib "etc.ss") (lib "etc.ss")
(lib "unitsig.ss") (lib "unitsig.ss")
(lib "thread.ss")
(lib "mred.ss" "mred") (lib "mred.ss" "mred")
(lib "token-tree.ss" "syntax-color") (lib "token-tree.ss" "syntax-color")
(lib "paren-tree.ss" "syntax-color") (lib "paren-tree.ss" "syntax-color")
@ -97,7 +98,7 @@
;; The lexer ;; The lexer
(define get-token #f) (define get-token #f)
;; ---------------------- Parnethesis matching ---------------------- ;; ---------------------- Parenethesis matching ----------------------
;; The pairs of matching parens ;; The pairs of matching parens
(define pairs '()) (define pairs '())
@ -130,11 +131,11 @@
;; ---------------------- Multi-threading --------------------------- ;; ---------------------- Multi-threading ---------------------------
;; A list of thunks that color the buffer ;; A list of thunks that color the buffer
(define colors null) (define colors null)
;; The thread handle to the background colorer ;; The coroutine object for tokenizing the buffer
(define background-thread #f) (define tok-cor #f)
;; Prevent the background thread from being put to sleep while modifying ;; The editor revision when tok-cor was created
;; global state (define rev #f)
(define mutex-lock (make-semaphore 1))
(inherit change-style begin-edit-sequence end-edit-sequence highlight-range (inherit change-style begin-edit-sequence end-edit-sequence highlight-range
get-style-list in-edit-sequence? get-start-position get-end-position get-style-list in-edit-sequence? get-start-position get-end-position
@ -151,12 +152,10 @@
(set! parens (new paren-tree% (matches pairs))) (set! parens (new paren-tree% (matches pairs)))
(set! current-pos start-pos) (set! current-pos start-pos)
(set! colors null) (set! colors null)
(modify)) (when tok-cor
(coroutine-kill tok-cor))
;; Let the background thread know the text has been modified. (set! tok-cor #f)
(define/private (modify) (set! rev #f))
(when background-thread
(break-thread background-thread)))
;; Actually color the buffer. ;; Actually color the buffer.
(define/private (color) (define/private (color)
@ -165,7 +164,7 @@
(set! colors (cdr colors)) (set! colors (cdr colors))
(color))) (color)))
;; Discard extra tokens at the first of invalie-tokens ;; Discard extra tokens at the first of invalid-tokens
(define/private (sync-invalid) (define/private (sync-invalid)
(when (and (not (send invalid-tokens is-empty?)) (when (and (not (send invalid-tokens is-empty?))
(< invalid-tokens-start current-pos)) (< invalid-tokens-start current-pos))
@ -175,18 +174,12 @@
(set! invalid-tokens-start (+ invalid-tokens-start length))) (set! invalid-tokens-start (+ invalid-tokens-start length)))
(sync-invalid))) (sync-invalid)))
;; re-tokenize should be called with breaks disabled, and (define/private (re-tokenize in in-start-pos enable-suspend)
;; should be called when lock is not held. When it exits,
;; the lock will be held.
(define/private (re-tokenize in in-start-pos)
(let-values ([(lexeme type data new-token-start new-token-end) (let-values ([(lexeme type data new-token-start new-token-end)
;; Allow breaks while getting tokens (get-token in)])
(parameterize-break #t
(get-token in))])
;(printf "~a~n" lexeme) ;(printf "~a~n" lexeme)
;; Also allow breaks while trying to enter the critical region:
(semaphore-wait/enable-break mutex-lock)
(unless (eq? 'eof type) (unless (eq? 'eof type)
(enable-suspend #f)
(let ((len (- new-token-end new-token-start))) (let ((len (- new-token-end new-token-start)))
(set! current-pos (+ len current-pos)) (set! current-pos (+ len current-pos))
(sync-invalid) (sync-invalid)
@ -213,14 +206,14 @@
(send parens merge-tree (send parens merge-tree
(send invalid-tokens get-root-end-position)) (send invalid-tokens get-root-end-position))
(insert-last! tokens invalid-tokens) (insert-last! tokens invalid-tokens)
(set! invalid-tokens-start +inf.0)) (set! invalid-tokens-start +inf.0)
(enable-suspend #t))
(else (else
(semaphore-post mutex-lock) (enable-suspend #t)
(re-tokenize in in-start-pos))))))) (re-tokenize in in-start-pos enable-suspend)))))))
(define/private (do-insert/delete edit-start-pos change-length) (define/private (do-insert/delete edit-start-pos change-length)
(unless (or stopped? force-stop?) (unless (or stopped? force-stop?)
(modify)
(unless up-to-date? (unless up-to-date?
(sync-invalid)) (sync-invalid))
(cond (cond
@ -254,18 +247,30 @@
(set! invalid-tokens-start (+ change-length invalid-tokens-start)) (set! invalid-tokens-start (+ change-length invalid-tokens-start))
(set! current-pos (+ start-pos tok-start))))))) (set! current-pos (+ start-pos tok-start)))))))
(inherit is-locked?) (inherit is-locked? get-revision-number)
(define done-sema (make-semaphore))
(define/private (colorer-driver) (define/private (colorer-driver)
(unless up-to-date? (unless up-to-date?
(set! done-sema (make-semaphore)) (unless (and tok-cor (= rev (get-revision-number)))
(thread-resume background-thread) (when tok-cor
(sync/timeout 0.01 done-sema) (coroutine-kill tok-cor))
(semaphore-wait mutex-lock) (set! tok-cor
(thread-suspend background-thread) (coroutine
(semaphore-post mutex-lock) (lambda (enable-suspend)
(re-tokenize (open-input-text-editor this current-pos end-pos
(lambda (x) #f))
current-pos
enable-suspend))))
(set! rev (get-revision-number)))
(with-handlers ((exn:fail?
(lambda (exn)
(parameterize ((print-struct #t))
((error-display-handler)
(format "exception in colorer thread: ~s" exn)
exn))
(set! tok-cor #f))))
(when (coroutine-run 10 tok-cor)
(set! up-to-date? #t)))
(unless (null? colors) (unless (null? colors)
(begin-edit-sequence #f #f) (begin-edit-sequence #f #f)
(color) (color)
@ -281,34 +286,6 @@
(unless up-to-date? (unless up-to-date?
(queue-callback (lambda () (colorer-callback)) #f))))) (queue-callback (lambda () (colorer-callback)) #f)))))
;; Breaks should be disabled on entry
(define/private (background-colorer-entry)
(thread-suspend (current-thread))
(background-colorer))
;; Breaks should be disabled on entry
(define/private (background-colorer)
(let/ec restart
(parameterize ((current-exception-handler
(lambda (exn)
(restart))))
(with-handlers ((exn:fail?
(lambda (exn)
(parameterize ((print-struct #t))
((error-display-handler)
(format "exception in colorer thread: ~s" exn)
exn))
(semaphore-wait mutex-lock))))
(re-tokenize (open-input-text-editor this current-pos end-pos
(lambda (x) #f))
current-pos))
(set! up-to-date? #t)
;; (printf "~a~n" (- (current-milliseconds) timer))
(semaphore-post done-sema)
(semaphore-post mutex-lock)
(thread-suspend (current-thread))))
(background-colorer))
;; Must not be called when the editor is locked ;; Must not be called when the editor is locked
(define/private (finish-now) (define/private (finish-now)
(unless stopped? (unless stopped?
@ -316,6 +293,7 @@
(unless up-to-date? (unless up-to-date?
(colorer-driver) (colorer-driver)
(loop))))) (loop)))))
;; See docs ;; See docs
(define/public (start-colorer token-sym->style- get-token- pairs-) (define/public (start-colorer token-sym->style- get-token- pairs-)
(unless force-stop? (unless force-stop?
@ -326,11 +304,6 @@
(set! get-token get-token-) (set! get-token get-token-)
(set! pairs pairs-) (set! pairs pairs-)
(set! parens (new paren-tree% (matches pairs))) (set! parens (new paren-tree% (matches pairs)))
(unless background-thread
;; Create background thread with breaks initially disabled:
(parameterize-break #f
(set! background-thread
(thread (lambda () (background-colorer-entry))))))
;; (set! timer (current-milliseconds)) ;; (set! timer (current-milliseconds))
(do-insert/delete start-pos 0))) (do-insert/delete start-pos 0)))
@ -408,10 +381,7 @@
(define/public (force-stop-colorer stop?) (define/public (force-stop-colorer stop?)
(set! force-stop? stop?) (set! force-stop? stop?)
(when stop? (when stop?
(stop-colorer) (stop-colorer)))
(when background-thread
(kill-thread background-thread)
(set! background-thread #f))))
;; ----------------------- Match parentheses ---------------------------- ;; ----------------------- Match parentheses ----------------------------
@ -663,14 +633,6 @@
(super on-focus on?) (super on-focus on?)
(match-parens (not on?))) (match-parens (not on?)))
(define/augment (after-split-snip pos)
(modify)
(inner (void) after-split-snip pos))
(define/augment (after-merge-snips pos)
(modify)
(inner (void) after-merge-snips pos))
(define/augment (after-edit-sequence) (define/augment (after-edit-sequence)
(when (has-focus?) (when (has-focus?)
(match-parens)) (match-parens))