Am 19.02.2016 um 22:39 schrieb Jörg F. Wittenberger:
> ...
>> I opened ticket 1259 for this.
>>
>> To make the kind reviewers job easier, I'll post diffs in piecemeal here.
This patch goes after killing a single - but important - comment line in
scheduler.scm:
;; This should really use a balanced tree:
Now it does.
This patch replaces the timeout queue with a balanced tree.
It does not matter so much, which kind of tree we use. But a
linear list is really a bad choice.
Assume you have a tcp-server alike: 100 client connections and
you read the next input line. It's probably (but not sure) already
in the OS's buffer. But chicken core will nevertheless establish a
timeout. The latter will so far traverse the (linear) timeout
queue. Chances are all those other timeouts are prior established
reads using the same timeout too. Thus you find the insert point
right at the end.
If you have an application which makes heavy use of chicken's core tcp
unit (I don't use chicken's timeouts at all for this, I do use them, but
only via thread-sleep!) I'd be interested to hear how much good or bad
this patch does for you.
Cheers
/Jörg
From 38c2b03e6a96097fa4fd4eeb4971305d084ae90f Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?J=C3=B6rg=20F=2E=20Wittenberger?=
<joerg.wittenber...@softeyes.net>
Date: Sat, 20 Feb 2016 18:13:49 +0100
Subject: [PATCH] Use balanced a tree for the timeout queue
---
distribution/manifest | 1 +
llrbtree.scm | 505 ++++++++++++++++++++++++++++++++++++++++++++++++++
scheduler.scm | 333 ++++++++++++++++++++++++++-------
3 files changed, 777 insertions(+), 62 deletions(-)
create mode 100644 llrbtree.scm
diff --git a/distribution/manifest b/distribution/manifest
index 1dd037f..3fc253a 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -28,6 +28,7 @@ posixunix.c
posixwin.c
profiler.c
scheduler.c
+llrbtree.scm
srfi-69.c
srfi-1.c
srfi-13.c
diff --git a/llrbtree.scm b/llrbtree.scm
new file mode 100644
index 0000000..4b19e4d
--- /dev/null
+++ b/llrbtree.scm
@@ -0,0 +1,505 @@
+;; #!/usr/bin/csi
+;; (C) 2008, 2010, 2013 Jörg F. Wittenberger.
+
+;; Redistribution permitted under either GPL, LGPL or BSD style
+;; license.
+
+;; (use extras)
+
+;; Changes
+;; Rewritten from the 2008 version; now in syntax-rules.
+
+;;* Left Leaning Red Black Tree
+
+;;** Code Generator
+
+;; Generate LLRB trees within arbitrary datastructures.
+
+(define-syntax define-llrbtree/positional
+ (syntax-rules ()
+ ((_
+ ;; The "features" is a list of symbols to control code
+ ;; expansion. "pure" expands to an implementation, which never
+ ;; updates nodes. "ordered" will enforce total order among the
+ ;; element. "leftmost" will include code to maintain a leftmost
+ ;; value of the tree (not recommended, may be removed).
+ features
+ ;; The "update*" syntax must accept a node structure and
+ ;; key-value pairs. Keys are color:, left: and right:
+
+ ;; "update" : If feature "pure" is set, "update" must expand
+ ;; to a newly allocated node, otherwise is MUST expand to a
+ ;; side effect full update of the original node.
+ update
+ ;; The following identifiers are bound in the expanded code.
+ ;; Pass #f for procedures not to be expanded.
+ init-root-node! ;; defined
+ t-lookup ;; defined
+ t-min ;; defined
+ t-fold ;; defined
+ t-for-each ;; defined
+ t-insert ;; defined
+ t-delete ;; defined
+ t-delete-min ;; defined
+ t-empty? ;; defined
+
+ ;; These syntax is used expand to code for comparision
+ ;; expressions.
+ t-k-eq? ;; key<>node-key "equal"
+ t-eq? ;; node-key<>node-key "equal"
+ t-k-<? ;; key<>node-key "less then"
+ t-<? ;; node<>node "less then"
+
+ ;; set-left!, set-right! and set-color! are unused, obsolete and
+ ;; will be removed in future version.
+ left set-left!
+ right set-right!
+ color set-color!
+ )
+ (begin
+ (define-syntax if/pure
+ (syntax-rules (pure)
+ ((_ kt kf) (if/pure features kt kf))
+ ((_ () kt kf) kf)
+ ((_ (pure . more) kt kf) kt)
+ ((_ (kw . more) kt kf) (if/pure more kt kf))))
+
+ (define-syntax if/ordered
+ (syntax-rules (ordered)
+ ((_ kt kf) (if/ordered features kt kf))
+ ((_ () kt kf) kf)
+ ((_ (ordered . more) kt kf) kt)
+ ((_ (kw . more) kt kf) (if/ordered more kt kf))))
+
+ (define-syntax if/leftmost
+ (syntax-rules (leftmost)
+ ((_ kt kf) (if/leftmost features kt kf))
+ ((_ () kt kf) kf)
+ ((_ (leftmost . more) kt kf) kt)
+ ((_ (kw . more) kt kf) (if/leftmost more kt kf))))
+
+ (define-syntax cond-define
+ (syntax-rules ()
+ ((_ (#f . params) . body) #f)
+ ((_ (id . params) . body)
+ (define (id . params) . body))))
+
+ (define-syntax root-node (syntax-rules () ((_ x) (left x))))
+
+#|
+Root pointers not yet working.
+ (define-syntax empty?
+ (syntax-rules () ((_ t n) (if/pure (not n) (eq? t n)))))
+ (define-syntax empty (syntax-rules () ((_ t) (if/pure #f t))))
+ (define-syntax black (syntax-rules () ((_ t) (if/pure #t t))))
+|#
+ (define-syntax empty?
+ (syntax-rules () ((_ t n) (not n))))
+ (define-syntax empty (syntax-rules () ((_ t) #f)))
+
+ (define-syntax black (syntax-rules () ((_ t) (if/pure #t #t))))
+ (define-syntax red (syntax-rules () ((_) #f)))
+ ;; In black? t is not used but kept for consistency with red?.
+ (define-syntax red?
+ (syntax-rules () ((_ t n) (if (empty? t n) #f (not (color n))))))
+ (define-syntax ptred?
+ (syntax-rules () ((_ t r sel) (if (empty? t r) #f (red? t (sel r))))))
+ (define-syntax black? (syntax-rules () ((_ t n) (color n))))
+ (define-syntax color-black? (syntax-rules () ((_ t c) c)))
+
+ (define-syntax with-n-node
+ (syntax-rules ()
+ ((_ 1 t n l r c ())
+ (if (empty? t n) n
+ (update n left: l right: r color: c)))
+ ((_ 1 t n l r c (step . more))
+ (begin (step t n l r c)
+ (with-n-node 1 t n l r c more)))
+ ((_ t node . steps)
+ (let ((n.n node))
+ (let ((l (left n.n))
+ (r (right n.n))
+ (c (color n.n)))
+ (with-n-node 1 t n.n l r c steps))))))
+
+ (define-syntax color-flip-node!
+ (syntax-rules ()
+ ((_ t n) (if (empty? t n) n
+ (update n color: (if (black? t n) (red) (black t)))))))
+
+ (define-syntax color-flip!
+ (syntax-rules ()
+ ((_ t n.n n.l n.r n.c)
+ (if (not (empty? t n.n))
+ (begin
+ (set! n.l (color-flip-node! t n.l))
+ (set! n.r (color-flip-node! t n.r))
+ (set! n.c (if (color-black? t n.c) (red) (black t))))))))
+
+ (define-syntax rotate-left!
+ (syntax-rules ()
+ ((_ t n.n n.l n.r n.c)
+ (begin
+ (set! n.l (update n.n left: n.l right: (left n.r) color: (red)))
+ (set! n.n n.r)
+ (set! n.r (right n.r))))))
+
+ (define-syntax rotate-right!
+ (syntax-rules ()
+ ((_ t n.n n.l n.r n.c)
+ (begin
+ (set! n.r (update n.n left: (right n.l) right: n.r color: (red)))
+ (set! n.n n.l)
+ (set! n.l (left n.l))))))
+
+ (define-syntax fixup!
+ (syntax-rules ()
+ ((_ t n.n n.l n.r n.c)
+ (begin
+ (if (red? t n.r)
+ (rotate-left! t n.n n.l n.r n.c))
+ (if (and (red? t n.l) (ptred? t n.l left))
+ (rotate-right! t n.n n.l n.r n.c))
+ (if (and (red? t n.l) (red? t n.r))
+ (color-flip! t n.n n.l n.r n.c))))))
+
+ (define-syntax move-red-right!
+ (syntax-rules ()
+ ((_ t n.n n.l n.r n.c)
+ (begin
+ (color-flip! t n.n n.l n.r n.c)
+ (if (ptred? t n.l left)
+ (begin
+ (rotate-right! t n.n n.l n.r n.c)
+ (color-flip! t n.n n.l n.r n.c)))))))
+
+ (define-syntax move-red-left!
+ (syntax-rules ()
+ ((_ t n.n n.l n.r n.c)
+ (begin
+ (color-flip! t n.n n.l n.r n.c)
+ (if (ptred? t n.r left)
+ (begin
+ (set! n.r (with-n-node t n.r rotate-right!))
+ (rotate-left! t n.n n.l n.r n.c)
+ (color-flip! t n.n n.l n.r n.c)))))))
+
+ (define-syntax delete-min
+ (syntax-rules ()
+ ((_ t %%set-leftmost! result-box %n)
+ (let delete-min-loop ((n %n))
+ (if (empty? t (left n))
+ (begin
+ (vector-set! result-box 0 n)
+ (if/leftmost
+ (if %%set-leftmost! (%%set-leftmost! n))
+ #f)
+ (left n))
+ (letrec-syntax
+ ((doit (syntax-rules ()
+ ((_ t n.n n.l n.r n.c)
+ (begin
+ (if (and (not (red? t n.l))
+ (not (ptred? t n.l left)))
+ (move-red-left! t n.n n.l n.r n.c))
+ (set! n.l (delete-min-loop n.l))
+ (fixup! t n.n n.l n.r n.c))))))
+ (with-n-node t n doit)))))))
+
+ (cond-define (init-root-node! t) (update t color: (black t) left: (empty t)))
+ (cond-define (t-empty? t n) (empty? t n))
+ (cond-define
+ (t-lookup t k)
+ (let lookup ((node (root-node t)))
+ (cond
+ ((empty? t node) node)
+ ((t-k-eq? k node) node)
+ ((t-k-<? k node) (lookup (left node)))
+ (else (lookup (right node))))))
+ (cond-define
+ (t-min t)
+ (if (empty? t (root-node t)) #f
+ (let min-loop ((node (root-node t)))
+ (cond
+ ((empty? t (left node)) node)
+ (else (min-loop (left node)))))))
+ (cond-define
+ (t-fold procedure init t)
+ (define (tfold init node)
+ (if (empty? t node)
+ init
+ (tfold (procedure node (tfold init (right node))) (left node))))
+ (tfold init (root-node t)))
+ (cond-define
+ (t-for-each procedure t)
+ (let llrb-for-each-loop ((node (root-node t)))
+ (or (empty? t node)
+ (begin
+ (procedure node)
+ (llrb-for-each-loop (left node))
+ (llrb-for-each-loop (right node))))))
+ (cond-define
+ (t-insert t n . %set-leftmost!); (t k n . set-leftmost!)
+ (if/pure #f (update n color: (red) left: (empty t) right: (empty t)))
+ (let ((nr
+ (let llrb-insert-loop ((node (root-node t))
+ (sl (and (pair? %set-leftmost!) (car %set-leftmost!))))
+ (if (empty? t node)
+ (if sl (begin (sl n) n) n)
+ (let-syntax
+ ((doit (syntax-rules ()
+ ((_ t n.n n.l n.r n.c)
+ (begin
+ (if/ordered
+ (if (t-eq? n n.n)
+ (set! n.n
+ (update n left: n.l right: n.r color: n.c))
+ (if (t-<? n n.n)
+ (set! n.l (llrb-insert-loop n.l sl))
+ (set! n.r (llrb-insert-loop n.r #f))))
+ (if (t-<? n n.n)
+ (set! n.l (llrb-insert-loop n.l sl))
+ (set! n.r (llrb-insert-loop n.r #f))))
+ (if (and (red? t n.r) (not (red? t n.l)))
+ (rotate-left! t n.n n.l n.r n.c))
+ (if (and (red? t n.l)
+ (red? t (left n.l)))
+ (rotate-right! t n.n n.l n.r n.c))
+ (if (and (red? t n.l) (red? t n.r))
+ (color-flip! t n.n n.l n.r n.c)))))))
+ (with-n-node t node doit))))))
+ #;(if (red? t nr)
+ (set! nr (update nr color: (black t))))
+ (update t left: nr color: (black t))))
+ (cond-define
+ (t-delete-min t . cont)
+ (define %set-leftmost! (and (pair? cont) (pair? (cdr cont)) (cadr cont)))
+ (if (empty? t (root-node t))
+ (if/pure
+ (if (pair? cont) ((car cont) t #f) t)
+ #f)
+ (let* ((min (vector #f))
+ (r (delete-min t %set-leftmost! min (root-node t))))
+ (if/leftmost
+ (if (and %set-leftmost! (empty? t r))
+ (%set-leftmost! r))
+ #f)
+ ;; Right or wrong?
+ ;; (if (,(red? 't) r)
+ ;; (set! r ,(update 'r color: (black 't))))
+ (if/pure
+ (let ((t (update t left: r color: (black t))))
+ (if (pair? cont) ((car cont) t (vector-ref min 0)) t))
+ (begin
+ (update t left: r color: (black t))
+ (vector-ref min 0))))))
+ (cond-define
+ (t-delete t n/k . rest)
+ (define (delete! %set-leftmost! h)
+ (if (if/ordered
+ (t-k-<? n/k h)
+ (and (not (eq? n/k h)) (t-<? n/k h)))
+ (let-syntax
+ ((doit (syntax-rules ()
+ ((_ t n.n n.l n.r n.c)
+ (begin
+ (if (and (not (red? t n.l))
+ (not (ptred? t n.l left)))
+ (move-red-left! t n.n n.l n.r n.c))
+ (set! n.l (if (empty? t n.l) (empty t)
+ (delete! %set-leftmost! n.l)))
+ (if/leftmost
+ (if (and %set-leftmost! (empty? t n.l))
+ (%set-leftmost! n.n))
+ #f)
+ (fixup! t n.n n.l n.r n.c))))))
+ (with-n-node t h doit))
+ (let-syntax
+ ((doit (syntax-rules ()
+ ((_ t n.n n.l n.r n.c)
+ (begin
+ (if (red? t n.l)
+ (rotate-right! t n.n n.l n.r n.c))
+ (if (and (if/ordered (t-k-eq? n/k n.n) (eq? n/k n.n))
+ (empty? t n.r))
+ (set! n.n n.r)
+ (begin
+ (if (and (not (red? t n.r))
+ (not (ptred? t n.r left)))
+ (move-red-right! t n.n n.l n.r n.c))
+ (if (if/ordered (t-k-eq? n/k n.n) (eq? n/k n.n))
+ (let ((minv (vector #f)))
+ (set! n.r (delete-min t #f minv n.r))
+ (set! n.n (vector-ref minv 0)))
+ (if (not (empty? t n.r))
+ (set! n.r (delete! #f n.r))))
+ (fixup! t n.n n.l n.r n.c))))))))
+ (with-n-node t h doit))))
+ (define %set-leftmost! (and (pair? rest) (car rest)))
+ (if (empty? t (root-node t)) t
+ (let ((r (delete! %set-leftmost! (root-node t))))
+ #;(if (red? t r)
+ (set! r (update r color: (black t))))
+ (update t left: r color: (black t)))))
+ )
+ )))
+
+#|
+;; Test
+(use srfi-1)
+(define-record-type <property>
+ (make-property color left right name value)
+ property?
+ (color property-color property-color-set!)
+ (left property-left property-left-set!)
+ (right property-right property-right-set!)
+ (name property-name property-name-set!)
+ (value property-value property-value-set!))
+
+(define-syntax property-update
+ (syntax-rules (left: right: color:)
+ ((_ 1 n l r c ())
+ (make-property c l r (property-name n) (property-value n)))
+ ((_ 1 n l r c (left: v . more))
+ (property-update 1 n v r c more))
+ ((_ 1 n l r c (right: v . more))
+ (property-update 1 n l v c more))
+ ((_ 1 n l r c (color: v . more))
+ (property-update 1 n l r v more))
+ ((_ n . more)
+ (property-update 1 n (property-left n) (property-right n) (property-color n) more))
+ ))
+
+(define-syntax property-k-n-eq?
+ (syntax-rules () ((_ k n) (eq? k (property-name n)))))
+
+(define-syntax property-k-n-lt
+ (syntax-rules () ((_ k n) (string<? (symbol->string k) (symbol->string (property-name n))))))
+
+(define-syntax property-n-n-lt
+ (syntax-rules () ((_ node1 node2) (string<? (symbol->string (property-name node1))
+ (symbol->string (property-name node2))))))
+
+(define-llrbtree/positional
+ (ordered pure)
+ property-update
+ property-set-init! ;; defined
+ property-lookup ;; defined
+ #f ;; no min defined
+ property-set-fold ;; defined
+ property-set-for-each ;#f ;; no for-each defined
+ property-node-insert! ;; defined
+ property-delete! ;; defined
+ #f ;; no delete-min defined
+ property-set-empty? ;; defined
+ property-k-n-eq?
+ property-k-n-lt
+ property-n-n-lt
+ property-left
+ property-left-set!
+ property-right
+ property-right-set!
+ property-color
+ property-color-set!
+ #f)
+
+
+(define pt (property-set-init! (make-property #f #f #f #f #f)))
+
+(define pt2
+ (fold
+ (lambda (p pt)
+ (property-node-insert! pt (car p) (make-property #f #f #f (car p) (cdr p))))
+ pt
+ '((one . 1)
+ (two . 2)
+ (three . 3))))
+
+(property-set-for-each
+ (lambda (n) (format #t "~a: ~a\n" (property-name n) (property-value n)))
+ pt2)
+
+|#
+
+
+;;** Usage Example
+
+;; This example was kept verbatim from the old code version. Needs to
+;; be updated to the current interface.
+
+#|
+ (define-record-type <int-priority-queue>
+ (make-int-priority-queue-entry color left right index value)
+ int-priority-queue-entry?
+ (color int-priority-queue-color int-priority-queue-color-set!)
+ (left int-priority-queue-left int-priority-queue-left-set!)
+ (right int-priority-queue-right int-priority-queue-right-set!)
+ (index int-priority-queue-index int-priority-queue-index-set!)
+ (value int-priority-queue-value int-priority-queue-value-set!))
+
+ (define-inline (make-queue-entry k v)
+ (make-int-priority-queue-entry #f #f #f k v))
+
+(define-llrbtree-code
+ (ordered)
+ ((node . args)
+ `(let ((node ,node))
+ . ,(let loop ((args args))
+ (if (null? args)
+ '(node)
+ (cons
+ (case (car args)
+ ((color:) `(int-priority-queue-color-set! node ,(cadr args)))
+ ((left:) `(int-priority-queue-left-set! node ,(cadr args)))
+ ((right:) `(int-priority-queue-right-set! node ,(cadr args)))
+ (else (error (format "unbrauchbar ~a" args))))
+ (loop (cddr args)))))))
+ int-priority-queue-init! ;; defined
+ int-priority-queue-lookup ;; defined
+ #f ;; no min defined
+ int-priority-queue-node-fold ;; defined
+ int-priority-queue-node-for-each ;; defined
+ int-priority-queue-node-insert! ;; defined
+ int-priority-queue-node-delete! ;; delete by node defined
+ int-priority-queue-delete-min! ;; defined
+ int-priority-queue-empty? ;; defined
+ ((k n)
+ `(fx= ,k (int-priority-queue-index ,n)))
+ ((k n)
+ `(fx<= ,k (int-priority-queue-index ,n)))
+ ((n1 n2)
+ `(fx<= (int-priority-queue-index ,n1) (int-priority-queue-index ,n2)))
+ int-priority-queue-left
+ int-priority-queue-left-set!
+ int-priority-queue-right
+ int-priority-queue-right-set!
+ int-priority-queue-color
+ int-priority-queue-color-set!
+ #f)
+
+(define tree (int-priority-queue-init! (make-queue-entry #f #f)))
+
+(int-priority-queue-node-insert! tree 5 (make-queue-entry 5 "fünf"))
+(int-priority-queue-node-insert! tree 1 (make-queue-entry 1 "eins"))
+(int-priority-queue-node-insert! tree 8 (make-queue-entry 8 "acht"))
+(int-priority-queue-node-insert! tree 6 (make-queue-entry 6 "sechs"))
+(int-priority-queue-node-insert! tree 11 (make-queue-entry 11 "elf"))
+
+(int-priority-queue-node-fold
+ (lambda (n i)
+ (format (current-output-port) "~a: ~a\n" (int-priority-queue-index n) (int-priority-queue-value n))
+ #f)
+ #f
+ tree)
+
+(int-priority-queue-delete-min! tree)
+
+(int-priority-queue-node-fold
+ (lambda (n i)
+ (format (current-output-port) "~a: ~a\n" (int-priority-queue-index n) (int-priority-queue-value n))
+ #f)
+ #f
+ tree)
+
+(exit)
+|#
\ No newline at end of file
diff --git a/scheduler.scm b/scheduler.scm
index feaac28..edc2813 100644
--- a/scheduler.scm
+++ b/scheduler.scm
@@ -28,7 +28,8 @@
(declare
(unit scheduler)
(disable-interrupts)
- (hide ready-queue-head ready-queue-tail ##sys#timeout-list
+ (hide ready-queue-head ready-queue-tail
+;; uncomment after test ##sys#timeout-list ##sys#timeout-list-head
##sys#update-thread-state-buffer ##sys#restore-thread-state-buffer
pending-queue ##sys#unblock-threads-for-i/o
fdset-set fdset-test create-fdset stderr
@@ -146,12 +147,9 @@ EOF
;;; BEGIN NEW SECTION (Integrating old scheduler)
;; A backward compatible mockup of things we need shortly to change.
-(define-syntax ##sys#timeout-list-empty? (syntax-rules () ((_) (null? ##sys#timeout-list))))
(define-syntax ##sys#fd-list-empty? (syntax-rules () ((_) (null? ##sys#fd-list))))
(define-inline (fd-list-lookup lst fd) (assq fd lst))
-(define-inline (int-priority-queue-value e) (cdr e))
-(define-inline (int-priority-queue-value-set! e v) (set-cdr! e v))
-(define-syntax ##sys#fd-list-clear-entry! (syntax-rules () ((_ e) (set! ##sys#timeout-list (##sys#delq e ##sys#timeout-list)))))
+(define-syntax ##sys#fd-list-clear-entry! (syntax-rules () ((_ e) (set! ##sys#fd-list (##sys#delq e ##sys#fd-list)))))
(define-syntax fdset-clear
(syntax-rules ()
@@ -163,6 +161,213 @@ EOF
;;; Garbage above. Following this line there may be new code to be kept.
;;; Garbage above.
+(include "llrbtree.scm")
+
+(cond-expand
+
+(the-typesafe-debug-feature
+;; There is a lolevel replacement in the default.
+
+(define-record-type <prio-queue-node>
+ (make-prio-queue-node color left right index value)
+ prio-queue-node-entry?
+ (color prio-queue-node-color prio-queue-node-color-set!)
+ (left prio-queue-node-left prio-queue-node-left-set!)
+ (right prio-queue-node-right prio-queue-node-right-set!)
+ (index prio-queue-node-index prio-queue-node-index-set!)
+ (value prio-queue-node-value prio-queue-node-value-set!))
+
+(define-inline (make-prio-queue-entry k v)
+ (make-prio-queue-node #f #f #f k v))
+
+) (use-inline
+
+(define-inline (make-prio-queue-entry k v)
+ (##sys#vector #f #f #f k v))
+
+(define-inline (prio-queue-node-entry? arg) (##sys#structure? arg 'prio-queue-node-entry))
+
+(define-inline (prio-queue-node-color x) (##sys#slot x 0))
+(define-inline (prio-queue-node-color-set! x v) (##sys#setislot x 0 v))
+(define-inline (prio-queue-node-left x) (##sys#slot x 1))
+(define-inline (prio-queue-node-left-set! x v) (##sys#setslot x 1 v))
+(define-inline (prio-queue-node-right x) (##sys#slot x 2))
+(define-inline (prio-queue-node-right-set! x v) (##sys#setslot x 2 v))
+(define-inline (prio-queue-node-index x) (##sys#slot x 3))
+(define-inline (prio-queue-node-index-set! x v) (##sys#setislot x 3 v))
+(define-inline (prio-queue-node-value x) (##sys#slot x 4))
+(define-inline (prio-queue-node-value-set! x v) (##sys#setslot x 4 v))
+
+) (else
+
+(define-inline (make-prio-queue-entry k v)
+ (##sys#vector #f #f #f k v))
+
+(define-syntax prio-queue-node-entry?
+ (syntax-rules () ((_ arg) (##sys#structure? arg 'prio-queue-node-entry))))
+
+(define-syntax prio-queue-node-color
+ (syntax-rules () ((_ x) (##sys#slot x 0))))
+(define-syntax prio-queue-node-color-set!
+ (syntax-rules () ((_ x v) (##sys#setislot x 0 v))))
+(define-syntax prio-queue-node-left
+ (syntax-rules () ((_ x) (##sys#slot x 1))))
+(define-syntax prio-queue-node-left-set!
+ (syntax-rules () ((_ x v) (##sys#setslot x 1 v))))
+(define-syntax prio-queue-node-right
+ (syntax-rules () ((_ x) (##sys#slot x 2))))
+(define-syntax prio-queue-node-right-set!
+ (syntax-rules () ((_ x v) (##sys#setslot x 2 v))))
+(define-syntax prio-queue-node-index
+ (syntax-rules () ((_ x) (##sys#slot x 3))))
+(define-syntax prio-queue-node-index-set!
+ (syntax-rules () ((_ x v) (##sys#setislot x 3 v))))
+(define-syntax prio-queue-node-value
+ (syntax-rules () ((_ x) (##sys#slot x 4))))
+(define-syntax prio-queue-node-value-set!
+ (syntax-rules () ((_ x v) (##sys#setslot x 4 v))))
+
+))
+
+(define-syntax prio-queue-node-update
+ (syntax-rules (left: right: color:)
+ ((_ 1 n l r c ())
+ (##sys#vector c l r (prio-queue-node-index n) (prio-queue-node-value n)))
+ ((_ 1 n l r c (left: v . more))
+ (prio-queue-node-update 1 n v r c more))
+ ((_ 1 n l r c (right: v . more))
+ (prio-queue-node-update 1 n l v c more))
+ ((_ 1 n l r c (color: v . more))
+ (prio-queue-node-update 1 n l r v more))
+ ((_ n . more)
+ (prio-queue-node-update
+ 1 n (prio-queue-node-left n) (prio-queue-node-right n) (prio-queue-node-color n) more))))
+
+(define-syntax prio-queue-node-update!
+ (syntax-rules (left: right: color:)
+ ((_ n) n)
+ ((_ n left: v . more)
+ (begin
+ (prio-queue-node-left-set! n v)
+ (prio-queue-node-update! n . more)))
+ ((_ n right: v . more)
+ (begin
+ (prio-queue-node-right-set! n v)
+ (prio-queue-node-update! n . more)))
+ ((_ n color: v . more)
+ (begin
+ (prio-queue-node-color-set! n v)
+ (prio-queue-node-update! n . more)))
+ ))
+
+;;; The Timeout Queue
+
+(define-inline (timeout= a b) (fp= a b))
+(define-inline (timeout< a b) (fp< a b))
+(define-inline (timeout>= a b) (fp>= a b))
+
+(define-syntax timeout-queue-node-key-node=?
+ (syntax-rules ()
+ ((_ key node) (timeout= key (prio-queue-node-index node)))))
+
+(define-syntax timeout-queue-node-key-node<?
+ (syntax-rules () ((_ key node) (fp< key (prio-queue-node-index node)))))
+
+(define-syntax timeout-queue-node-node-node=?
+ (syntax-rules ()
+ ((_ n1 n2) (timeout= (prio-queue-node-index n1) (prio-queue-node-index n2)))))
+
+(define-syntax timeout-queue-node-node-node<?
+ (syntax-rules ()
+ ((_ n1 n2) (timeout< (prio-queue-node-index n1) (prio-queue-node-index n2)))))
+
+(define-llrbtree/positional
+ (ordered)
+ prio-queue-node-update!
+ timeout-queue-node-init! ;; defined
+ timeout-queue-node-lookup ;; defined
+ #f ;; no min defined
+ timeout-queue-fold ;; defined
+ #f ;; prio-queue-node-node-for-each ;; defined
+ timeout-queue-node-insert! ;; defined
+ timeout-queue-node-delete! ;; delete by node defined
+ timeout-queue-delete-min! ;; defined
+ timeout-queue-node-empty? ;; defined
+ timeout-queue-node-key-node=?
+ timeout-queue-node-node-node=?
+ timeout-queue-node-key-node<?
+ timeout-queue-node-node-node<?
+ prio-queue-node-left
+ prio-queue-node-left-set!
+ prio-queue-node-right
+ prio-queue-node-right-set!
+ prio-queue-node-color
+ prio-queue-node-color-set!
+ )
+
+(define (make-prio-queue)
+ (timeout-queue-node-init! (make-prio-queue-entry #f #f)))
+
+(define ##sys#timeout-list (make-prio-queue))
+
+(define-inline (make-timeout-list-entry k v)
+ (make-prio-queue-entry k v))
+
+(define ##sys#timeout-list-head #f)
+
+(define-inline (##sys#timeout-list-empty?) (not ##sys#timeout-list-head))
+
+(define-inline (timeout-queue-next) ##sys#timeout-list-head)
+
+(define-inline (timeout-queue-unqueue!)
+ (set! ##sys#timeout-list-head
+ (timeout-queue-delete-min! ##sys#timeout-list)))
+
+(define-inline (timeout-queue-remove-entry! entry)
+ (if (eq? ##sys#timeout-list-head entry)
+ (timeout-queue-unqueue!)
+ (timeout-queue-node-delete! ##sys#timeout-list (prio-queue-node-index entry))))
+
+(define-inline (timeout-queue-insert-thread! t tm)
+ (cond
+ ((not ##sys#timeout-list-head)
+ (let ((entry (make-timeout-list-entry tm (list t))))
+ (##sys#setslot t 4 entry)
+ (set! ##sys#timeout-list-head entry)))
+ ((fx> tm
+ (prio-queue-node-index ##sys#timeout-list-head))
+ (let ((entry (timeout-queue-node-lookup ##sys#timeout-list tm)))
+ (if entry
+ (begin
+ (##sys#setslot t 4 entry)
+ ;; FIXME: this is a linear list only because coding is not finished.
+ (prio-queue-node-value-set!
+ entry (cons t (prio-queue-node-value entry))))
+ (let ((entry (make-timeout-list-entry tm (list t))))
+ (##sys#setslot t 4 entry)
+ (timeout-queue-node-insert! ##sys#timeout-list entry)))))
+ ((fx< tm
+ (prio-queue-node-index ##sys#timeout-list-head))
+ (timeout-queue-node-insert!
+ ##sys#timeout-list ##sys#timeout-list-head)
+ (let ((entry (make-timeout-list-entry tm (list t))))
+ (##sys#setslot t 4 entry)
+ (set! ##sys#timeout-list-head entry)))
+ (else
+ (prio-queue-node-value-set!
+ ##sys#timeout-list-head
+ (cons t (prio-queue-node-value ##sys#timeout-list-head)))
+ (##sys#setslot t 4 ##sys#timeout-list-head))))
+
+;;; The Filedescriptor Queue
+;;; BEGIN Filedescriptor Queue
+
+;;; Make diff pick it up.
+
+;;; Make diff pick it up.
+;; make that diff finds the end.
+;;; END Filedescriptor Queue
+
#|
we
@@ -290,72 +495,59 @@ dunno what to do
(##sys#schedule) ) ) ; expected not to return!
(oldhook reason state) ) ) )
-(define ##sys#timeout-list '())
-
(define (##sys#remove-from-timeout-list t)
- (let loop ((l ##sys#timeout-list) (prev #f))
- (if (null? l)
- l
- (let ((h (##sys#slot l 0))
- (r (##sys#slot l 1)))
- (if (eq? (##sys#slot h 1) t)
- (if prev
- (set-cdr! prev r)
- (set! ##sys#timeout-list r))
- (loop r l))))))
+ (let ((entry (##sys#slot t 4)))
+ (if entry
+ ;; This is a linear list because this list is usually very short.
+ (let ((remaining (##sys#delq t (prio-queue-node-value entry))))
+ (if (null? remaining)
+ (timeout-queue-remove-entry! entry)
+ (prio-queue-node-value-set! entry remaining))
+ (##sys#setislot t 4 #f)))))
(define-inline (##sys#thread-basic-unblock! t)
(dbg "unblocking: " t)
(##sys#add-to-ready-queue t) )
(define (##sys#unblock-threads-for-timeout!)
- (dbg "timeout queue " ##sys#timeout-list)
+ (dbg "timeout queue " (##sys#timeout-list-empty?))
(let ((now (##core#inline_allocate ("C_a_i_current_milliseconds" 4) #f)))
- (let loop ((lst ##sys#timeout-list))
- (if (null? lst)
- (set! ##sys#timeout-list '())
- (let* ([tmo1 (caar lst)] ; timeout of thread on list
- [tto (cdar lst)] ; thread on list
- [tmo2 (##sys#slot tto 4)] ) ; timeout value stored in thread
- (dbg "timeout: " tto " -> " tmo2 " (now: " now ")")
- (if (not (equal? tmo1 tmo2)) (dbg "chicken would loose timeout " tmo1 " since " tto " has " tmo2))
- (if (equal? tmo1 tmo2) ;XXX why do we check this?
- (if (fp>= now tmo1) ; timeout reached?
- (begin
- (##sys#setislot tto 13 #t) ; mark as being unblocked by timeout
- (##sys#thread-clear-blocking-state! tto)
- (##sys#thread-basic-unblock! tto)
- (loop (cdr lst)) )
- (set! ##sys#timeout-list lst) )
- (loop (cdr lst)) ) ) ) )
+ (let loop ()
+ (unless (##sys#timeout-list-empty?)
+ (let* ((entry (timeout-queue-next))
+ (tmo (prio-queue-node-index entry)))
+ (dbg " " now " -> " tmo)
+ (if (timeout>= now tmo)
+ (begin
+ (timeout-queue-unqueue!)
+ (for-each
+ (lambda (tto)
+ (##sys#setislot tto 4 #f)
+ (##sys#setislot tto 13 #t) ; mark as being unblocked by timeout
+ (##sys#thread-clear-blocking-state! tto)
+ ;;(pp `(CLEARED: ,tto ,@##sys#fd-list) ##sys#standard-error) ;***
+ (##sys#thread-basic-unblock! tto))
+ (prio-queue-node-value entry))
+ (loop) ) ))))
(if (and (##sys#fd-list-empty?) (ready-queue-empty?))
(if (##sys#timeout-list-empty?)
(##sys#signal-hook #:runtime-error "deadlock")
;; Sleep for the number of milliseconds of next thread
;; to wake up.
- (let ((tmo1 (caar ##sys#timeout-list)))
- (##core#inline
- "C_msleep"
- (fxmax
- 0
- (##core#inline "C_quickflonumtruncate" (fp- tmo1 now)))) )))))
+ (let ((tmo (prio-queue-node-index (timeout-queue-next))))
+ (##core#inline "C_msleep" (fxmax 0 (##core#inline "C_quickflonumtruncate" (fp- tmo now)))) )))))
(define (##sys#thread-block-for-timeout! t tm)
(dbg t " blocks for timeout " tm)
(unless (flonum? tm) ; to catch old code that uses fixnum timeouts
(panic
(sprintf "##sys#thread-block-for-timeout!: invalid timeout: ~S" tm)))
- (when (fp> tm 0.0)
+ (when (timeout< 0.0 tm)
;; This should really use a balanced tree:
- (let loop ([tl ##sys#timeout-list] [prev #f])
- (if (or (null? tl) (fp< tm (caar tl)))
- (if prev
- (set-cdr! prev (cons (cons tm t) tl))
- (set! ##sys#timeout-list (cons (cons tm t) tl)) )
- (loop (cdr tl) tl) ) )
+ ;; Now it is. ;-)
+ (timeout-queue-insert-thread! t tm)
(##sys#setslot t 3 'blocked)
- (##sys#setislot t 13 #f)
- (##sys#setslot t 4 tm) ) )
+ (##sys#setislot t 13 #f) ) )
(define (##sys#thread-block-for-termination! t t2)
(dbg t " blocks for " t2)
@@ -487,9 +679,9 @@ dunno what to do
(let* ((to? (not (##sys#timeout-list-empty?)))
(rq? (ready-queue-not-empty?))
(tmo (if (and to? (not rq?)) ; no thread was unblocked by timeout, so wait
- (let* ((tmo1 (caar ##sys#timeout-list))
- (now (##core#inline_allocate ("C_a_i_current_milliseconds" 4) #f)))
- (fpmax 0.0 (fp- tmo1 now)) )
+ (let ((tmo (prio-queue-node-index (timeout-queue-next)))
+ (now (##core#inline_allocate ("C_a_i_current_milliseconds" 4) #f)))
+ (fpmax 0.0 (fp- tmo now)))
0.0) ) ) ; otherwise immediate timeout.
(dbg "waiting for I/O with timeout " tmo)
(let ((n ((foreign-lambda int "C_ready_fds_timeout" bool double)
@@ -561,20 +753,35 @@ dunno what to do
(let loop ((l (cdar l)))
(if (null? l) i
(cns 'i/o fd (car l) (loop (cdr l)))))))
- (let loop ((l ##sys#timeout-list) (i i))
- (if (pair? l)
- (loop (cdr l) (cns 'timeout (caar l) (cdar l) i))
- i)))))))))
+ (let ((n (timeout-queue-next)))
+ (if n
+ (timeout-queue-fold
+ (lambda (n i)
+ (foldr
+ (lambda (t i)
+ (cns 'timeout (prio-queue-node-index n) t i))
+ i
+ (prio-queue-node-value n)))
+ (foldr
+ (lambda (t i)
+ (cns 'timeout (prio-queue-node-index n) t i))
+ i
+ (prio-queue-node-value n))
+ ##sys#timeout-list)
+ '())))))))))
;;; Remove all waiting threads from the relevant queues with the exception of the current thread:
(define (##sys#fetch-and-clear-threads)
- (let ([all (vector (##sys#ready-queue) ready-queue-tail ##sys#fd-list ##sys#timeout-list)])
+ (let ([all (vector (##sys#ready-queue) ready-queue-tail
+ ##sys#fd-list
+ (cons ##sys#timeout-list-head ##sys#timeout-list))])
(set-cdr! ready-queue-head '())
(set! ready-queue-tail ready-queue-head)
(set! ##sys#fd-list '())
- (set! ##sys#timeout-list '())
+ (set! ##sys#timeout-list-head #f)
+ (set! ##sys#timeout-list (make-prio-queue))
all) )
@@ -584,7 +791,9 @@ dunno what to do
(set-cdr! ready-queue-head (##sys#slot vec 0))
(set! ready-queue-tail (##sys#slot vec 1))
(set! ##sys#fd-list (##sys#slot vec 2))
- (set! ##sys#timeout-list (##sys#slot vec 3)) )
+ (let ((x (##sys#slot vec 3)))
+ (set! ##sys#timeout-list-head (car x))
+ (set! ##sys#timeout-list (cdr x))) )
;;; Clear blocking queues
@@ -596,13 +805,13 @@ dunno what to do
(let* ((fd (##sys#slot blocked 0))
(entry (fd-list-lookup ##sys#fd-list fd)))
(if entry
- (let ((ts (##sys#delq t (int-priority-queue-value entry)))) ; remove from fd-list entry
+ (let ((ts (##sys#delq t (cdr #;prio-queue-node-value entry)))) ; remove from fd-list entry
(cond ((null? ts)
;;(pp `(CLEAR FD: ,fd ,t) ##sys#standard-error)
(fdset-delfd fd)
(##sys#fd-list-clear-entry! entry)) ; no more threads waiting for this fd
(else
- (int-priority-queue-value-set! entry ts)) ) )
+ (set-cdr! #;prio-queue-node-value-set! entry ts)) ) )
(begin
#|
(define stderr ##sys#standard-error)
--
2.6.2
_______________________________________________
Chicken-hackers mailing list
Chicken-hackers@nongnu.org
https://lists.nongnu.org/mailman/listinfo/chicken-hackers
