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)]
[(and (not (sandman-any-sleepers?))
(not (any-idle-waiters?)))
;; all threads done or blocked
(cond
[(thread-running? root-thread)
;; we shouldn't exit, because the main thread is
;; blocked, but it's not going to become unblocked;
;; sleep forever or until a signal changes things
(process-sleep)
(poll-and-select-thread! 0)]
[else
(void)])]
[else
;; try again, which should lead to `process-sleep`
(poll-and-select-thread! 0)]))
;; all threads done or blocked
(cond
[(thread-running? root-thread)
;; we shouldn't exit, because the main thread is
;; blocked, but it's not going to become unblocked;
;; sleep forever or until a signal changes things
(process-sleep)
(poll-and-select-thread! 0)]
[else
(void)])]
[else
;; try again, which should lead to `process-sleep`
(poll-and-select-thread! 0)]))
;; Check for threads that have been suspended until a particular time,
;; 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?
(define (all-threads-poll-done?)
(= (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))
(node-child n)]))
;; In atomic mode:
(define (thread-group-add! parent child)
(atomically
(let loop ([parent parent] [child child])
;; Adding to the start of the group tends to reverse the schedule
;; order, but it also avoids a problem where two threads that
;; both loop and `sleep` (which deschedules and reschedules) take
;; turns and starve everything else.
(define t (thread-group-chain-start parent))
(define was-empty? (not t))
(define n (child-node child))
(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)
(assert-atomic-mode)
;; Adding to the start of the group tends to reverse the schedule
;; order, but it also avoids a problem where two threads that
;; both loop and `sleep` (which deschedules and reschedules) take
;; turns and starve everything else.
(define t (thread-group-chain-start parent))
(define was-empty? (not t))
(define n (child-node child))
(unless (and (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
(loop parent-parent parent))))))
(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
(thread-group-add! parent-parent parent))))
;; In atomic mode:
(define (thread-group-remove! parent child)
(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)
(cond