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

cs & thread: remove redundant internal atomically

Browse Source
This commit is contained in:
Matthew Flatt 2019-12-29 07:08:15 -06:00
parent e087059f21
commit c8f44d6597
2 changed files with 63 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
racket/src/thread/schedule.rkt
View File

@ -184,19 +184,19 @@
(poll-and-select-thread! 0 callbacks)] (poll-and-select-thread! 0 callbacks)]
[(and (not (sandman-any-sleepers?)) [(and (not (sandman-any-sleepers?))
(not (any-idle-waiters?))) (not (any-idle-waiters?)))
;; all threads done or blocked ;; all threads done or blocked
(cond (cond
[(thread-running? root-thread) [(thread-running? root-thread)
;; we shouldn't exit, because the main thread is ;; we shouldn't exit, because the main thread is
;; blocked, but it's not going to become unblocked; ;; blocked, but it's not going to become unblocked;
;; sleep forever or until a signal changes things ;; sleep forever or until a signal changes things
(process-sleep) (process-sleep)
(poll-and-select-thread! 0)] (poll-and-select-thread! 0)]
[else [else
(void)])] (void)])]
[else [else
;; try again, which should lead to `process-sleep` ;; try again, which should lead to `process-sleep`
(poll-and-select-thread! 0)])) (poll-and-select-thread! 0)]))
;; Check for threads that have been suspended until a particular time, ;; Check for threads that have been suspended until a particular time,
;; etc., as registered with the sandman ;; etc., as registered with the sandman
@ -242,7 +242,7 @@
;; ---------------------------------------- ;; ----------------------------------------
;; Have we tried all threads without since most recently making ;; Have we tried all threads since most recently making
;; progress on some thread? ;; progress on some thread?
(define (all-threads-poll-done?) (define (all-threads-poll-done?)
(= (hash-count poll-done-threads) (= (hash-count poll-done-threads)

98
racket/src/thread/thread-group.rkt
View File

@ -72,57 +72,57 @@
(set-thread-group-chain! tg (node-next n)) (set-thread-group-chain! tg (node-next n))
(node-child n)])) (node-child n)]))
;; In atomic mode:
(define (thread-group-add! parent child) (define (thread-group-add! parent child)
(atomically (assert-atomic-mode)
(let loop ([parent parent] [child child]) ;; Adding to the start of the group tends to reverse the schedule
;; Adding to the start of the group tends to reverse the schedule ;; order, but it also avoids a problem where two threads that
;; order, but it also avoids a problem where two threads that ;; both loop and `sleep` (which deschedules and reschedules) take
;; both loop and `sleep` (which deschedules and reschedules) take ;; turns and starve everything else.
;; turns and starve everything else. (define t (thread-group-chain-start parent))
(define t (thread-group-chain-start parent)) (define was-empty? (not t))
(define was-empty? (not t)) (define n (child-node child))
(define n (child-node child)) (unless (and (eq? (node-prev n) 'none)
(unless (and (eq? (node-prev n) 'none)
(eq? (node-next n) 'none))
(internal-error "thread-group-add!: thread or group is added already"))
(set-node-next! n t)
(set-node-prev! n #f)
(if t
(set-node-prev! t n)
(set-thread-group-chain-end! parent n))
(set-thread-group-chain-start! parent n)
(unless (thread-group? child)
(set! num-threads-in-groups (add1 num-threads-in-groups)))
(when was-empty?
;; added child to formerly empty parent => add the parent
(define parent-parent (thread-group-parent parent))
(when parent-parent
(loop parent-parent parent))))))
(define (thread-group-remove! parent child)
(atomically
(let loop ([parent parent] [child child])
(define n (child-node child))
(when (or (eq? (node-prev n) 'none)
(eq? (node-next n) 'none)) (eq? (node-next n) 'none))
(internal-error "thread-group-remove!: thread or group is removed already")) (internal-error "thread-group-add!: thread or group is added already"))
(if (node-next n) (set-node-next! n t)
(set-node-prev! (node-next n) (node-prev n)) (set-node-prev! n #f)
(set-thread-group-chain-end! parent (node-prev n))) (if t
(if (node-prev n) (set-node-prev! t n)
(set-node-next! (node-prev n) (node-next n)) (set-thread-group-chain-end! parent n))
(set-thread-group-chain-start! parent (node-next n))) (set-thread-group-chain-start! parent n)
(when (eq? n (thread-group-chain parent)) (unless (thread-group? child)
(set-thread-group-chain! parent (node-next n))) (set! num-threads-in-groups (add1 num-threads-in-groups)))
(set-node-next! n 'none) (when was-empty?
(set-node-prev! n 'none) ;; added child to formerly empty parent => add the parent
(unless (thread-group? child) (define parent-parent (thread-group-parent parent))
(set! num-threads-in-groups (sub1 num-threads-in-groups))) (when parent-parent
(when (not (thread-group-chain-end parent)) (thread-group-add! parent-parent parent))))
;; parent thread group is now empty, so remove it, too
(define parent-parent (thread-group-parent parent)) ;; In atomic mode:
(when parent-parent (define (thread-group-remove! parent child)
(loop parent-parent parent)))))) (assert-atomic-mode)
(define n (child-node child))
(when (or (eq? (node-prev n) 'none)
(eq? (node-next n) 'none))
(internal-error "thread-group-remove!: thread or group is removed already"))
(if (node-next n)
(set-node-prev! (node-next n) (node-prev n))
(set-thread-group-chain-end! parent (node-prev n)))
(if (node-prev n)
(set-node-next! (node-prev n) (node-next n))
(set-thread-group-chain-start! parent (node-next n)))
(when (eq? n (thread-group-chain parent))
(set-thread-group-chain! parent (node-next n)))
(set-node-next! n 'none)
(set-node-prev! n 'none)
(unless (thread-group? child)
(set! num-threads-in-groups (sub1 num-threads-in-groups)))
(when (not (thread-group-chain-end parent))
;; parent thread group is now empty, so remove it, too
(define parent-parent (thread-group-parent parent))
(when parent-parent
(thread-group-remove! parent-parent parent))))
(define (thread-group-all-threads parent accum) (define (thread-group-all-threads parent accum)
(cond (cond