Skip to content
Fetching contributors…
Cannot retrieve contributors at this time
1649 lines (1309 sloc) 52.3 KB
;;;============================================================================
;;; File: "_thread#.scm", Time-stamp: <2008-11-22 09:00:30 feeley>
;;; Copyright (c) 1994-2008 by Marc Feeley, All Rights Reserved.
;;;============================================================================
;;; Representation of exceptions.
(define-library-type-of-exception deadlock-exception
id: 54294cd7-1c33-40e1-940e-7400e1126a5a
constructor: #f
opaque:
)
(define-library-type-of-exception abandoned-mutex-exception
id: e0e435ae-0097-47c9-8d4a-9d761979522c
constructor: #f
opaque:
)
(define-library-type-of-exception scheduler-exception
id: 0d164889-74b4-48ca-b291-f5ec9e0499fe
constructor: #f
opaque:
unprintable:
read-only:
reason
)
(define-library-type-of-exception noncontinuable-exception
id: 1bcc14ff-4be5-4573-a250-729b773bdd50
constructor: #f
opaque:
unprintable:
read-only:
reason
)
(define-library-type-of-exception initialized-thread-exception
id: e38351db-bef7-4c30-b610-b9b271e99ec3
constructor: #f
opaque:
unprintable:
read-only:
procedure
arguments
)
(define-library-type-of-exception uninitialized-thread-exception
id: 71831161-39c1-4a10-bb79-04342e1981c3
constructor: #f
opaque:
unprintable:
read-only:
procedure
arguments
)
(define-library-type-of-exception inactive-thread-exception
id: 339af4ff-3d44-4bec-a90b-d981fd13834d
constructor: #f
opaque:
unprintable:
read-only:
procedure
arguments
)
(define-library-type-of-exception started-thread-exception
id: ed07bce3-b882-4737-ac5e-3035b7783b8a
constructor: #f
opaque:
unprintable:
read-only:
procedure
arguments
)
(define-library-type-of-exception terminated-thread-exception
id: 85f41657-8a51-4690-abef-d76dc37f4465
constructor: #f
opaque:
unprintable:
read-only:
procedure
arguments
)
(define-library-type-of-exception uncaught-exception
id: 7022e42c-4ecb-4476-be40-3ca2d45903a7
constructor: #f
opaque:
unprintable:
read-only:
procedure
arguments
reason
)
(define-library-type-of-exception join-timeout-exception
id: 7af7ca4a-ecca-445f-a270-de9d45639feb
constructor: #f
opaque:
unprintable:
read-only:
procedure
arguments
)
(define-library-type-of-exception mailbox-receive-timeout-exception
id: 5f13e8c4-2c68-4eb5-b24d-249a9356c918
constructor: #f
opaque:
unprintable:
read-only:
procedure
arguments
)
(define-library-type-of-exception rpc-remote-error-exception
id: 6469e5eb-3117-4c29-89df-c348479dac93
constructor: #f
opaque:
unprintable:
read-only:
procedure
arguments
message
)
;;;----------------------------------------------------------------------------
;;; Define type checking macros.
(define-check-type continuation 'continuation
##continuation?)
(define-check-type time (macro-type-time)
macro-time?)
(define-check-type absrel-time 'absrel-time
macro-absrel-time?)
(define-check-type absrel-time-or-false 'absrel-time-or-false
macro-absrel-time-or-false?)
(define-check-type thread 'thread
macro-thread?)
(define-check-type mutex (macro-type-mutex)
macro-mutex?)
(define-check-type condvar (macro-type-condvar)
macro-condvar?)
(define-check-type tgroup (macro-type-tgroup)
macro-tgroup?)
(##define-macro (macro-initialized-thread? thread)
`(macro-thread-cont ,thread))
(##define-macro (macro-started-thread-given-initialized? thread)
`(or (##not (##procedure? (macro-thread-exception? ,thread)))
(macro-thread-result ,thread)))
(##define-macro (macro-terminated-thread-given-initialized? thread)
`(##not (macro-thread-end-condvar ,thread)))
(##define-macro (macro-check-initialized-thread thread form expr)
`(if (##not (macro-initialized-thread? ,thread))
(##raise-uninitialized-thread-exception ,@form)
,expr))
(##define-macro (macro-check-not-initialized-thread thread form expr)
`(if (macro-initialized-thread? ,thread)
(##raise-initialized-thread-exception ,@form)
,expr))
(##define-macro (macro-check-not-started-thread-given-initialized thread form expr)
`(if (let ((thread ,thread))
(or (macro-terminated-thread-given-initialized? thread)
(macro-started-thread-given-initialized? thread)))
(##raise-started-thread-exception ,@form)
,expr))
;;;----------------------------------------------------------------------------
;;; Priority queue generator macro.
;; The red-black tree implementation used here is inspired from the
;; code in the MIT-Scheme runtime (file "rbtree.scm"). That code is
;; based on the algorithms presented in the book "Introduction to
;; Algorithms" by Cormen, Leiserson, and Rivest.
;;
;; The main differences with the MIT-Scheme code are:
;;
;; 1) Nil pointers are replaced by a special sentinel that is also
;; the cell that contains a pointer (in the "left child" field)
;; to the root of the red-black tree. The "right child" field of
;; the sentinel is never accessed. The sentinel is black.
;;
;; 2) The color field contains #f when the node is red and a
;; reference to the sentinel when the node is black. It is thus
;; possible to find the sentinel from any node in constant time
;; (if the node is black extract the color field, otherwise
;; extract the color field of the parent, which must be black).
;;
;; 3) One field of the sentinel always points to the leftmost node of
;; the red-black tree. This allows constant time access to the
;; "minimum" node, which is a frequent operation of priority queues.
;;
;; 4) Several cases are handled specially (see the code for details).
;;
;; 5) Macros are used to generate code specialized for each case of
;; symmetrical operations (e.g. left and right rotation).
;;
;; 6) Nodes are assumed to be preallocated. Inserting and deleting a
;; node from a red-black tree does not perform any heap
;; allocation. Moreover, all algorithms consume a constant amount
;; of stack space.
(##define-macro (define-rbtree
rbtree-init!
node->rbtree
insert!
remove!
reposition!
singleton?
color
color-set!
parent
parent-set!
left
left-set!
right
right-set!
before?
leftmost
leftmost-set!
rightmost
rightmost-set!)
(define (black rbtree)
rbtree)
(define (black? rbtree)
`(lambda (node)
(,color node)))
(define (blacken! rbtree)
`(lambda (node)
(,color-set! node ,(black rbtree))))
(define (red)
#f)
(define (red?)
`(lambda (node)
(##not (,color node))))
(define (reden!)
`(lambda (node)
(,color-set! node ,(red))))
(define (copy-color!)
`(lambda (node1 node2)
(,color-set! node1 (,color node2))))
(define (exchange-color!)
`(lambda (node1 node2)
(let ((color-node1 (,color node1)))
(,color-set! node1 (,color node2))
(,color-set! node2 color-node1))))
(define (update-parent!)
`(lambda (parent-node old-node new-node)
(if (##eq? old-node (,left parent-node))
(,left-set! parent-node new-node)
(,right-set! parent-node new-node))))
(define (rotate! side1 side1-set! side2 side2-set!)
`(lambda (node)
(let ((side2-node (,side2 node)))
(let ((side1-side2-node (,side1 side2-node)))
(,side2-set! node side1-side2-node)
(,parent-set! side1-side2-node node))
(let ((parent-node (,parent node)))
(,side1-set! side2-node node)
(,parent-set! node side2-node)
(,parent-set! side2-node parent-node)
(,(update-parent!) parent-node node side2-node)))))
(define (rotate-left!)
(rotate! left left-set! right right-set!))
(define (rotate-right!)
(rotate! right right-set! left left-set!))
(define (neighbor side other-side)
`(lambda (node rbtree)
(let ((side-node (,side node)))
(if (##eq? side-node rbtree)
(let ((parent-node (,parent node)))
(if (or (##eq? parent-node rbtree)
(##eq? node (,side parent-node)))
rbtree
parent-node))
(let loop ((x side-node))
(let ((other-side-x (,other-side x)))
(if (##eq? other-side-x rbtree)
x
(loop other-side-x))))))))
`(begin
(##define-macro (,rbtree-init! rbtree)
`(let ((rbtree ,rbtree))
(##declare (not interrupts-enabled))
,',@(if leftmost
`((,leftmost-set! rbtree rbtree))
`())
(,',(blacken! 'rbtree) rbtree)
(,',parent-set! rbtree rbtree)
(,',left-set! rbtree rbtree)))
(##define-macro (,node->rbtree node)
`(let ((node ,node))
(##declare (not interrupts-enabled))
(or (,',color node)
(let ((parent-node (,',parent node)))
(and parent-node ;; make sure node is in a rbtree
(,',color parent-node))))))
(define-prim (,insert! rbtree node)
(##declare (not interrupts-enabled))
(define (fixup!)
(let loop ((x node))
(let ((parent-x (,parent x)))
(if (,(red?) parent-x)
(let ((parent-parent-x (,parent parent-x)))
(##define-macro (body
side1
rotate-side1!
side2
rotate-side2!)
`(let ((side2-parent-parent-x (,side2 parent-parent-x)))
(if (,',(red?) side2-parent-parent-x)
(begin
(,',(blacken! 'rbtree) parent-x)
(,',(blacken! 'rbtree) side2-parent-parent-x)
(,',(reden!) parent-parent-x)
(loop parent-parent-x))
(let ((y
(if (##eq? x (,side2 parent-x))
(begin
(,rotate-side1! parent-x)
(,',parent parent-x))
(,',parent x))))
(,',(blacken! 'rbtree) y)
(let ((parent-y (,',parent y)))
(,',(reden!) parent-y)
(,rotate-side2! parent-y))))))
(if (##eq? parent-x (,left parent-parent-x))
(body ,left
,(rotate-left!)
,right
,(rotate-right!))
(body ,right
,(rotate-right!)
,left
,(rotate-left!)))))))
(,(blacken! 'rbtree) (,left rbtree))
(##void))
(##define-macro (insert-below! x)
`(let ((x ,x))
(if (,',before? node x)
(insert-left! (,',left x) x)
(insert-right! (,',right x) x))))
(define (insert-left! left-x x)
(if (##eq? left-x rbtree)
(begin
(,left-set! x node)
(,parent-set! node x)
;; check if leftmost must be updated
,@(if leftmost
`((if (##eq? x (,leftmost rbtree))
(,leftmost-set! rbtree node)))
`())
(fixup!))
(insert-below! left-x)))
(define (insert-right! right-x x)
(if (##eq? right-x rbtree)
(begin
(,right-set! x node)
(,parent-set! node x)
;; check if rightmost must be updated
,@(if rightmost
`((if (##eq? x (,rightmost rbtree))
(,rightmost-set! rbtree node)))
`())
(fixup!))
(insert-below! right-x)))
(,(reden!) node)
(,left-set! node rbtree)
(,right-set! node rbtree)
(insert-left! (,left rbtree) rbtree)
(,parent-set! rbtree rbtree))
(define-prim (,remove! node)
(##declare (not interrupts-enabled))
(let ((rbtree (,node->rbtree node)))
(define (fixup! parent-node node)
(##define-macro (body side1 rotate-side1! side2 rotate-side2!)
`(let ((x
(let ((side2-parent-node (,side2 parent-node)))
(if (,',(red?) side2-parent-node)
(begin
(,',(blacken! 'rbtree) side2-parent-node)
(,',(reden!) parent-node)
(,rotate-side1! parent-node)
(,side2 parent-node))
side2-parent-node))))
(define (common-case y)
(,',(copy-color!) y parent-node)
(,',(blacken! 'rbtree) parent-node)
(,',(blacken! 'rbtree) (,side2 y))
(,rotate-side1! parent-node)
(,',(blacken! 'rbtree) (,',left rbtree)))
(if (,',(red?) (,side2 x))
(common-case x)
(let ((side1-x (,side1 x)))
(if (,',(black? 'rbtree) side1-x)
(begin
(,',(reden!) x)
(fixup! (,',parent parent-node) parent-node))
(begin
(,',(blacken! 'rbtree) side1-x)
(,',(reden!) x)
(,rotate-side2! x)
(common-case (,side2 parent-node))))))))
(cond ((or (##eq? parent-node rbtree) (,(red?) node))
(,(blacken! 'rbtree) node))
((##eq? node (,left parent-node))
(body ,left
,(rotate-left!)
,right
,(rotate-right!)))
(else
(body ,right
,(rotate-right!)
,left
,(rotate-left!)))))
(let ((parent-node (,parent node))
(left-node (,left node))
(right-node (,right node)))
(,parent-set! node #f) ;; to avoid leaks
(,left-set! node #f)
(,right-set! node #f)
(cond ((##eq? left-node rbtree)
;; check if leftmost must be updated
,@(if leftmost
`((if (##eq? node (,leftmost rbtree))
(,leftmost-set!
rbtree
(if (##eq? right-node rbtree)
parent-node
right-node))))
`())
(,parent-set! right-node parent-node)
(,(update-parent!) parent-node node right-node)
(if (,(black? 'rbtree) node)
(begin
(,(reden!) node) ;; to avoid leaks
(fixup! parent-node right-node))))
((##eq? right-node rbtree)
;; check if rightmost must be updated
,@(if rightmost
`((if (##eq? node (,rightmost rbtree))
(,rightmost-set!
rbtree
left-node)))
`())
(,parent-set! left-node parent-node)
(,(update-parent!) parent-node node left-node)
;; At this point we know that the node is black.
;; This is because the right child is nil and the
;; left child is red (if the left child was black
;; the tree would not be balanced)
(,(reden!) node) ;; to avoid leaks
(fixup! parent-node left-node))
(else
(let loop ((x right-node) (parent-x node))
(let ((left-x (,left x)))
(if (##eq? left-x rbtree)
(begin
(,(exchange-color!) x node)
(,parent-set! left-node x)
(,left-set! x left-node)
(,parent-set! x parent-node)
(,(update-parent!) parent-node node x)
(if (##eq? x right-node)
(if (,(black? 'rbtree) node)
(begin
(,(reden!) node) ;; to avoid leaks
(fixup! x (,right x))))
(let ((right-x (,right x)))
(,parent-set! right-x parent-x)
(,left-set! parent-x right-x)
(,parent-set! right-node x)
(,right-set! x right-node)
(if (,(black? 'rbtree) node)
(begin
(,(reden!) node) ;; to avoid leaks
(fixup! parent-x right-x))))))
(loop left-x x)))))))
(,parent-set! rbtree rbtree)))
(##define-macro (,singleton? rbtree)
`(let ((rbtree ,rbtree))
(##declare (not interrupts-enabled))
(let ((root (,',left rbtree)))
(and (##not (##eq? root rbtree))
(##eq? (,',left root) rbtree)
(##eq? (,',right root) rbtree)
root))))
(define-prim (,reposition! node)
(##declare (not interrupts-enabled))
(let* ((rbtree
(,node->rbtree node))
(predecessor-node
(,(neighbor left right) node rbtree))
(successor-node
(,(neighbor right left) node rbtree)))
(if (or (and (##not (##eq? predecessor-node rbtree))
(,before? node predecessor-node))
(and (##not (##eq? successor-node rbtree))
(,before? successor-node node)))
(begin
(,remove! node)
(,insert! rbtree node)))))))
;;;----------------------------------------------------------------------------
;;; Representation of dynamic environments.
;; The dynamic environment contains the set of dynamically bound
;; "parameters" (such as the current input port and current exception
;; handler) that is attached to a continuation, and thereby to a
;; thread.
;; The dynamic environment stores the bindings of normal parameters in
;; a binary tree ordered using an integer identifier attached to the
;; parameter. Some frequently used parameters (such as the current
;; input port and exception handler) are stored separately.
(##define-macro (macro-make-denv local dynwind im ds eh ip op rc)
`(##vector ,local ,dynwind ,im ,ds ,eh ,ip ,op ,rc))
(##define-macro (macro-denv-local d) `(macro-slot 0 ,d))
(##define-macro (macro-denv-local-set! d x) `(macro-slot 0 ,d ,x))
(##define-macro (macro-denv-dynwind d) `(macro-slot 1 ,d))
(##define-macro (macro-denv-dynwind-set! d x) `(macro-slot 1 ,d ,x))
(##define-macro (macro-denv-interrupt-mask d) `(macro-slot 2 ,d))
(##define-macro (macro-denv-interrupt-mask-set! d x) `(macro-slot 2 ,d ,x))
(##define-macro (macro-denv-debugging-settings d) `(macro-slot 3 ,d))
(##define-macro (macro-denv-debugging-settings-set! d x)`(macro-slot 3 ,d ,x))
(##define-macro (macro-denv-exception-handler d) `(macro-slot 4 ,d))
(##define-macro (macro-denv-exception-handler-set! d x) `(macro-slot 4 ,d ,x))
(##define-macro (macro-denv-input-port d) `(macro-slot 5 ,d))
(##define-macro (macro-denv-input-port-set! d x) `(macro-slot 5 ,d ,x))
(##define-macro (macro-denv-output-port d) `(macro-slot 6 ,d))
(##define-macro (macro-denv-output-port-set! d x) `(macro-slot 6 ,d ,x))
(##define-macro (macro-denv-repl-context d) `(macro-slot 7 ,d))
(##define-macro (macro-denv-repl-context-set! d x) `(macro-slot 7 ,d ,x))
;;; Environment tree nodes.
(##define-macro (macro-make-env pv l r) `(##vector ,pv ,l ,r))
(##define-macro (macro-env-param-val e) `(macro-slot 0 ,e))
(##define-macro (macro-env-param-val-set! e x) `(macro-slot 0 ,e ,x))
(##define-macro (macro-env-left e) `(macro-slot 1 ,e))
(##define-macro (macro-env-left-set! e x) `(macro-slot 1 ,e ,x))
(##define-macro (macro-env-right e) `(macro-slot 2 ,e))
(##define-macro (macro-env-right-set! e x) `(macro-slot 2 ,e ,x))
;;; Dynamic-wind frames.
(##define-macro (macro-make-dynwind level before after cont)
`(##vector ,level ,before ,after ,cont))
(##define-macro (macro-dynwind-level d) `(macro-slot 0 ,d))
(##define-macro (macro-dynwind-level-set! d x) `(macro-slot 0 ,d ,x))
(##define-macro (macro-dynwind-before d) `(macro-slot 1 ,d))
(##define-macro (macro-dynwind-before-set! d x) `(macro-slot 1 ,d ,x))
(##define-macro (macro-dynwind-after d) `(macro-slot 2 ,d))
(##define-macro (macro-dynwind-after-set! d x) `(macro-slot 2 ,d ,x))
(##define-macro (macro-dynwind-cont d) `(macro-slot 3 ,d))
(##define-macro (macro-dynwind-cont-set! d x) `(macro-slot 3 ,d ,x))
;;; Parameter descriptors.
(##define-macro (macro-make-parameter-descr value hash filter)
`(##vector ,value ,hash ,filter))
(##define-macro (macro-parameter-descr-value p) `(macro-slot 0 ,p))
(##define-macro (macro-parameter-descr-value-set! p x) `(macro-slot 0 ,p ,x))
(##define-macro (macro-parameter-descr-hash p) `(macro-slot 1 ,p))
(##define-macro (macro-parameter-descr-hash-set! p x) `(macro-slot 1 ,p ,x))
(##define-macro (macro-parameter-descr-filter p) `(macro-slot 2 ,p))
(##define-macro (macro-parameter-descr-filter-set! p x) `(macro-slot 2 ,p ,x))
;;; Binding of special dynamic variables.
(##define-macro (macro-dynamic-bind var val thunk)
`(let ((val ,val) (thunk ,thunk))
(##declare (not interrupts-enabled))
(let ((current-denv (macro-thread-denv (macro-current-thread))))
(##dynamic-env-bind
(macro-make-denv
(macro-denv-local current-denv)
,(if (eq? var 'dynwind)
`val
`(macro-denv-dynwind current-denv))
,(if (eq? var 'interrupt-mask)
`val
`(macro-denv-interrupt-mask current-denv))
,(if (eq? var 'debugging-settings)
`val
`(macro-denv-debugging-settings current-denv))
,(if (eq? var 'exception-handler)
`(##cons ##current-exception-handler val)
`(macro-denv-exception-handler current-denv))
,(if (eq? var 'input-port)
`(##cons ##current-input-port val)
`(macro-denv-input-port current-denv))
,(if (eq? var 'output-port)
`(##cons ##current-output-port val)
`(macro-denv-output-port current-denv))
,(if (eq? var 'repl-context)
`(##cons #f val)
`(macro-denv-repl-context current-denv)))
thunk))))
(##define-macro (macro-current-interrupt-mask)
`(macro-denv-interrupt-mask (macro-thread-denv (macro-current-thread))))
(##define-macro (macro-debugging-settings-port)
`(macro-denv-debugging-settings (macro-thread-denv (macro-current-thread))))
(##define-macro (macro-current-exception-handler)
`(##cdr
(macro-denv-exception-handler (macro-thread-denv (macro-current-thread)))))
(##define-macro (macro-current-exception-handler-set! val)
`(##set-cdr!
(macro-denv-exception-handler (macro-thread-denv (macro-current-thread)))
,val))
(##define-macro (macro-current-input-port)
`(##cdr
(macro-denv-input-port (macro-thread-denv (macro-current-thread)))))
(##define-macro (macro-current-input-port-set! val)
`(##set-cdr!
(macro-denv-input-port (macro-thread-denv (macro-current-thread)))
,val))
(##define-macro (macro-current-output-port)
`(##cdr
(macro-denv-output-port (macro-thread-denv (macro-current-thread)))))
(##define-macro (macro-current-output-port-set! val)
`(##set-cdr!
(macro-denv-output-port (macro-thread-denv (macro-current-thread)))
,val))
(##define-macro (macro-current-repl-context)
`(##cdr
(macro-denv-repl-context (macro-thread-denv (macro-current-thread)))))
(##define-macro (macro-current-repl-context-set! val)
`(##set-cdr!
(macro-denv-repl-context (macro-thread-denv (macro-current-thread)))
,val))
;;; Exception raising.
(##define-macro (macro-raise obj)
`(let ((obj ,obj))
(##declare (not safe)) ;; avoid procedure check on the call to the handler
((macro-current-exception-handler) obj)))
(##define-macro (macro-abort obj)
`(let ((obj ,obj))
(##declare (not safe)) ;; avoid procedure check on the call to the handler
((macro-current-exception-handler) obj)
(##abort (macro-make-noncontinuable-exception obj))))
;;;----------------------------------------------------------------------------
;;; Representation of time objects.
(define-type time
id: 9700b02a-724f-4888-8da8-9b0501836d8e
type-exhibitor: macro-type-time
constructor: macro-make-time
implementer: implement-type-time
opaque:
macros:
prefix: macro-
unprintable:
point
;; the following fields are for eventual compatibility with srfi-19
type
second
nanosecond
)
(##define-macro (macro-absrel-time? obj)
`(let ((obj ,obj))
(or (##real? obj)
(macro-time? obj))))
(##define-macro (macro-absrel-time-or-false? obj)
`(let ((obj ,obj))
(or (##not obj)
(macro-absrel-time? obj))))
;;;----------------------------------------------------------------------------
;;; Root thread settings.
(##define-macro (macro-thread-root-base-priority)
(exact->inexact 0))
(##define-macro (macro-thread-root-quantum)
(exact->inexact 2/100))
(##define-macro (macro-thread-root-priority-boost)
(exact->inexact (expt 10 -6)))
(##define-macro (macro-default-heartbeat-interval)
(exact->inexact 1/100))
;;;----------------------------------------------------------------------------
;;; Representation of thread groups, threads, mutexes and condition variables.
;; A thread group contains a double-ended-queue of the threads that are
;; in the group and a double-ended-queue of the thread groups that are
;; in the group. A thread contains a double-ended-queue of the mutexes
;; that are owned by the thread. Conversely, a mutex contains a queue
;; of the threads blocked on the mutex. A condition variable also
;; contains a queue of the threads blocked on the condition variable.
;;; Representation of blocked thread queues.
(##define-macro (macro-btq-deq-next node) `(macro-slot 1 ,node))
(##define-macro (macro-btq-deq-next-set! node x) `(macro-slot 1 ,node ,x))
(##define-macro (macro-btq-deq-prev node) `(macro-slot 2 ,node))
(##define-macro (macro-btq-deq-prev-set! node x) `(macro-slot 2 ,node ,x))
(##define-macro (macro-btq-color node) `(macro-slot 3 ,node))
(##define-macro (macro-btq-color-set! node x) `(macro-slot 3 ,node ,x))
(##define-macro (macro-btq-parent node) `(macro-slot 4 ,node))
(##define-macro (macro-btq-parent-set! node x) `(macro-slot 4 ,node ,x))
(##define-macro (macro-btq-left node) `(macro-slot 5 ,node))
(##define-macro (macro-btq-left-set! node x) `(macro-slot 5 ,node ,x))
(##define-macro (macro-btq-right node) `(macro-slot 6 ,node))
(##define-macro (macro-btq-right-set! node x) `(macro-slot 6 ,node ,x))
(##define-macro (macro-btq-leftmost node) `(macro-slot 6 ,node))
(##define-macro (macro-btq-leftmost-set! node x) `(macro-slot 6 ,node ,x))
(##define-macro (macro-btq-owner node) `(macro-slot 7 ,node))
(##define-macro (macro-btq-owner-set! node x) `(macro-slot 7 ,node ,x))
(##define-macro (macro-btq-deq-init! deq)
`(let ((deq ,deq))
(##declare (not interrupts-enabled))
(macro-btq-deq-next-set! deq deq)
(macro-btq-deq-prev-set! deq deq)))
(##define-macro (macro-btq-deq-remove! item)
`(let ((item ,item))
(##declare (not interrupts-enabled))
(let ((item-next (macro-btq-deq-next item))
(item-prev (macro-btq-deq-prev item)))
(macro-btq-deq-next-set! item-prev item-next)
(macro-btq-deq-prev-set! item-next item-prev))))
(##define-macro (macro-btq-deq-insert! deq item)
`(let ((deq ,deq) (item ,item))
(##declare (not interrupts-enabled))
;; add item to tail of deq
(let ((deq-last (macro-btq-deq-prev deq)))
(macro-btq-deq-next-set! deq-last item)
(macro-btq-deq-prev-set! deq item)
(macro-btq-deq-next-set! item deq)
(macro-btq-deq-prev-set! item deq-last))))
(##define-macro (macro-btq-link! mutex thread)
`(let ((mutex ,mutex) (thread ,thread))
(##declare (not interrupts-enabled))
(macro-btq-deq-insert! thread mutex)
(macro-btq-owner-set! mutex thread)))
(##define-macro (macro-btq-unlink! mutex state)
`(let ((mutex ,mutex) (state ,state))
(##declare (not interrupts-enabled))
(macro-btq-deq-init! mutex)
(macro-btq-owner-set! mutex state)))
;;; Representation of timeout queues.
(##define-macro (macro-toq-color node) `(macro-slot 8 ,node))
(##define-macro (macro-toq-color-set! node x) `(macro-slot 8 ,node ,x))
(##define-macro (macro-toq-parent node) `(macro-slot 9 ,node))
(##define-macro (macro-toq-parent-set! node x) `(macro-slot 9 ,node ,x))
(##define-macro (macro-toq-left node) `(macro-slot 10 ,node))
(##define-macro (macro-toq-left-set! node x) `(macro-slot 10 ,node ,x))
(##define-macro (macro-toq-right node) `(macro-slot 11 ,node))
(##define-macro (macro-toq-right-set! node x) `(macro-slot 11 ,node ,x))
(##define-macro (macro-toq-leftmost node) `(macro-slot 11 ,node))
(##define-macro (macro-toq-leftmost-set! node x) `(macro-slot 11 ,node ,x))
;;; Representation of threads.
;; The state of a thread is determined by the content of the
;; "end-condvar", "exception?" and "result" fields:
;;
;; thread state "end-condvar" "exception?" "result"
;; not yet started condvar thunk #f
;; started, never run condvar thunk ##thread-start-action!
;; started, has run condvar #f action procedure/#f/#t
;; terminated with result #f #f result object
;; terminated with exception #f #t exception object
(define-type thread
id: d05e0aa7-e235-441d-aa41-c1ac02065460
extender: macro-define-type-of-thread
type-exhibitor: macro-type-thread
constructor: macro-construct-thread
implementer: implement-type-thread
opaque:
macros:
prefix: macro-
unprintable:
(btq-deq-next init: #f) ;; blocked thread queues owned by thread
(btq-deq-prev init: #f)
(btq-color init: #f) ;; to keep thread in a blocked thread queue
(btq-parent init: #f)
(btq-left init: #f)
(btq-leftmost init: #f)
(tgroup init: #f) ;; thread-group this thread belongs to
(toq-color init: #f) ;; to keep thread in a timeout queue
(toq-parent init: #f)
(toq-left init: #f)
(toq-leftmost init: #f)
(threads-deq-next init: #f) ;; threads in this thread group
(threads-deq-prev init: #f)
(floats init: #f)
(name init: #f)
(end-condvar init: #f)
(exception? init: #f)
(result init: #f)
(cont init: #f)
(denv init: #f)
(denv-cache1 init: #f)
(denv-cache2 init: #f)
(denv-cache3 init: #f)
(repl-channel init: #f)
(mailbox init: #f)
(specific init: #f)
)
;;; Access to floating point fields.
(##define-macro (macro-timeout f) `(##f64vector-ref ,f 0))
(##define-macro (macro-timeout-set! f x) `(##f64vector-set! ,f 0 ,x))
(##define-macro (macro-base-priority f) `(##f64vector-ref ,f 1))
(##define-macro (macro-base-priority-set! f x) `(##f64vector-set! ,f 1 ,x))
(##define-macro (macro-quantum f) `(##f64vector-ref ,f 2))
(##define-macro (macro-quantum-set! f x) `(##f64vector-set! ,f 2 ,x))
(##define-macro (macro-quantum-used f) `(##f64vector-ref ,f 3))
(##define-macro (macro-quantum-used-set! f x) `(##f64vector-set! ,f 3 ,x))
(##define-macro (macro-priority-boost f) `(##f64vector-ref ,f 4))
(##define-macro (macro-priority-boost-set! f x) `(##f64vector-set! ,f 4 ,x))
(##define-macro (macro-boosted-priority f) `(##f64vector-ref ,f 5))
(##define-macro (macro-boosted-priority-set! f x) `(##f64vector-set! ,f 5 ,x))
(##define-macro (macro-effective-priority f) `(##f64vector-ref ,f 6))
(##define-macro (macro-effective-priority-set! f x)`(##f64vector-set! ,f 6 ,x))
(##define-macro (macro-thread-timeout t)
`(macro-timeout (macro-thread-floats ,t)))
(##define-macro (macro-thread-timeout-set! t x)
`(macro-timeout-set! (macro-thread-floats ,t) ,x))
(##define-macro (macro-thread-base-priority t)
`(macro-base-priority (macro-thread-floats ,t)))
(##define-macro (macro-thread-base-priority-set! t x)
`(macro-base-priority-set! (macro-thread-floats ,t) ,x))
(##define-macro (macro-thread-quantum t)
`(macro-quantum (macro-thread-floats ,t)))
(##define-macro (macro-thread-quantum-set! t x)
`(macro-quantum-set! (macro-thread-floats ,t) ,x))
(##define-macro (macro-thread-quantum-used t)
`(macro-quantum-used (macro-thread-floats ,t)))
(##define-macro (macro-thread-quantum-used-set! t x)
`(macro-quantum-used-set! (macro-thread-floats ,t) ,x))
(##define-macro (macro-thread-priority-boost t)
`(macro-priority-boost (macro-thread-floats ,t)))
(##define-macro (macro-thread-priority-boost-set! t x)
`(macro-priority-boost-set! (macro-thread-floats ,t) ,x))
(##define-macro (macro-thread-boosted-priority t)
`(macro-boosted-priority (macro-thread-floats ,t)))
(##define-macro (macro-thread-boosted-priority-set! t x)
`(macro-boosted-priority-set! (macro-thread-floats ,t) ,x))
(##define-macro (macro-thread-effective-priority t)
`(macro-effective-priority (macro-thread-floats ,t)))
(##define-macro (macro-thread-effective-priority-set! t x)
`(macro-effective-priority-set! (macro-thread-floats ,t) ,x))
(##define-macro (macro-make-thread-floats parent-thread)
`(let* ((floats
(macro-thread-floats ,parent-thread))
(base-priority
(macro-base-priority floats))
(priority-boost
(macro-priority-boost floats)))
(##f64vector
(macro-inexact-+0)
base-priority
(macro-quantum floats)
(macro-inexact-+0)
priority-boost
base-priority
base-priority)))
(##define-macro (macro-make-thread-end-condvar parent-thread)
`(macro-make-condvar #f))
(##define-macro (macro-make-thread-cont parent-thread)
`(let ((cont (##vector 0)))
(##subtype-set! cont (macro-subtype-continuation))
cont))
(##define-macro (macro-make-thread-denv parent-thread)
`(let ((denv (macro-thread-denv ,parent-thread)))
(macro-make-denv
(macro-denv-local denv)
##initial-dynwind
(macro-denv-interrupt-mask denv)
(macro-denv-debugging-settings denv)
(##cons ##current-exception-handler
(macro-primordial-exception-handler))
(macro-denv-input-port denv)
(macro-denv-output-port denv)
(##cons #f
#f))))
(##define-macro (macro-make-thread-denv-cache1 parent-thread)
`(macro-thread-denv-cache1 ,parent-thread))
(##define-macro (macro-make-thread-denv-cache2 parent-thread)
`(macro-thread-denv-cache2 ,parent-thread))
(##define-macro (macro-make-thread-denv-cache3 parent-thread)
`(macro-thread-denv-cache3 ,parent-thread))
(##define-macro (macro-thread-init! thread thunk name tgroup)
`(let ((thread ,thread) (thunk ,thunk) (name ,name) (tgroup ,tgroup))
(##declare (not interrupts-enabled))
(let ((p (macro-current-thread)))
(macro-thread-tgroup-set! thread tgroup)
(macro-thread-floats-set! thread (macro-make-thread-floats p))
(macro-thread-name-set! thread name)
(macro-thread-end-condvar-set! thread (macro-make-thread-end-condvar p))
(macro-thread-exception?-set! thread thunk)
(macro-thread-cont-set! thread (macro-make-thread-cont p))
(macro-thread-denv-set! thread (macro-make-thread-denv p))
(macro-thread-denv-cache1-set! thread (macro-make-thread-denv-cache1 p))
(macro-thread-denv-cache2-set! thread (macro-make-thread-denv-cache2 p))
(macro-thread-denv-cache3-set! thread (macro-make-thread-denv-cache3 p))
(macro-btq-deq-init! thread)
(macro-tgroup-threads-deq-insert! tgroup thread)
thread)))
(##define-macro (macro-make-thread thunk name tgroup)
`(let ((thunk ,thunk) (name ,name) (tgroup ,tgroup))
(##declare (not interrupts-enabled))
(macro-thread-init! (macro-construct-thread) thunk name tgroup)))
(##define-macro (macro-thread-btq-remove-if-in-btq! thread)
`(let ((thread ,thread))
(##declare (not interrupts-enabled))
(if (macro-btq-parent thread)
(##thread-btq-remove! thread))))
(##define-macro (macro-thread-toq-remove-if-in-toq! thread)
`(let ((thread ,thread))
(##declare (not interrupts-enabled))
(if (macro-toq-parent thread)
(##thread-toq-remove! thread))))
(##define-macro (macro-thread-reschedule-if-needed!)
`(let ()
(##declare (not interrupts-enabled))
(let ((leftmost (macro-btq-leftmost (macro-run-queue))))
(if (##not (##eq? leftmost (macro-current-thread)))
(##thread-reschedule!)
(##void)))))
(##define-macro (macro-thread-save! proc . args)
`(##thread-save! ,proc ,@args))
(##define-macro (macro-thread-restore! thread proc . args)
`(##thread-restore! ,thread ,proc ,@args))
(##define-macro (macro-run-queue)
`(##run-queue))
(##define-macro (macro-primordial-thread)
`(macro-run-queue-primordial-thread (macro-run-queue)))
(##define-macro (macro-current-thread)
`(##current-thread))
(##define-macro (macro-primordial-exception-handler)
`##primordial-exception-handler)
(##define-macro (macro-thread-higher-prio? t1 t2)
`(let ((t1 ,t1) (t2 ,t2))
(let ((floats1 (macro-thread-floats t1))
(floats2 (macro-thread-floats t2)))
(##flonum.< (macro-effective-priority floats2) ;; high priority first
(macro-effective-priority floats1)))))
(##define-macro (macro-thread-sooner? t1 t2)
`(let ((t1 ,t1) (t2 ,t2))
(let ((floats1 (macro-thread-floats t1))
(floats2 (macro-thread-floats t2)))
(##flonum.< (macro-timeout floats1)
(macro-timeout floats2)))))
(##define-macro (macro-thread-sooner-or-simultaneous-and-higher-prio? t1 t2)
`(let ((t1 ,t1) (t2 ,t2))
(let ((floats1 (macro-thread-floats t1))
(floats2 (macro-thread-floats t2)))
(if (##not (##flonum.= (macro-timeout floats1)
(macro-timeout floats2)))
(##flonum.< (macro-timeout floats1)
(macro-timeout floats2))
(##flonum.< (macro-effective-priority floats2) ;; high priority first
(macro-effective-priority floats1))))))
(##define-macro (macro-thread-boost-and-clear-quantum-used! thread)
`(let ((thread ,thread))
(##declare (not interrupts-enabled))
(let ((floats (macro-thread-floats thread)))
(macro-quantum-used-set! floats (macro-inexact-+0))
(if (##not (##flonum.= (##flonum.+ (macro-base-priority floats)
(macro-priority-boost floats))
(macro-boosted-priority floats)))
(begin
;; save old boosted priority for ##thread-boosted-priority-changed!
(macro-temp-set!
(macro-thread-floats (macro-run-queue))
(macro-boosted-priority floats))
(macro-boosted-priority-set!
floats
(##flonum.+ (macro-base-priority floats)
(macro-priority-boost floats)))
(##thread-boosted-priority-changed! thread))))))
(##define-macro (macro-thread-unboost-and-clear-quantum-used! thread)
`(let ((thread ,thread))
(##declare (not interrupts-enabled))
(let ((floats (macro-thread-floats thread)))
(macro-quantum-used-set! floats (macro-inexact-+0))
(if (##not (##flonum.= (macro-base-priority floats)
(macro-boosted-priority floats)))
(begin
;; save old boosted priority for ##thread-boosted-priority-changed!
(macro-temp-set!
(macro-thread-floats (macro-run-queue))
(macro-boosted-priority floats))
(macro-boosted-priority-set!
floats
(macro-base-priority floats))
(##thread-boosted-priority-changed! thread))))))
(##define-macro (macro-thread-inherit-priority! thread parent);;;;;;;;;;;;;;;
`(let ((thread ,thread) (parent ,parent))
(##declare (not interrupts-enabled))
(let ((thread-floats (macro-thread-floats thread))
(parent-floats (macro-thread-floats parent)))
(if (##flonum.< (macro-effective-priority thread-floats)
(macro-effective-priority parent-floats))
(begin
(macro-effective-priority-set!
thread-floats
(macro-effective-priority parent-floats))
(##thread-effective-priority-changed! thread #t))))))
;;; Representation of thread mailboxes.
(define-type mailbox
id: f1bd59e2-25fc-49af-b624-e00f0c5975f8
type-exhibitor: macro-type-mailbox
constructor: macro-construct-mailbox
implementer: implement-type-mailbox
predicate: macro-mailbox?
opaque:
macros:
prefix: macro-
unprintable:
mutex
condvar
fifo
cursor
)
(##define-macro (macro-make-mailbox)
`(let ((mutex (macro-make-mutex #f))
(condvar (macro-make-condvar #f))
(fifo (macro-make-fifo)))
(macro-construct-mailbox mutex condvar fifo #f)))
;;; Representation of mutexes.
(define-type mutex
id: 42fe9aac-e9c6-4227-893e-a0ad76f58932
type-exhibitor: macro-type-mutex
constructor: macro-construct-mutex
implementer: implement-type-mutex
opaque:
macros:
prefix: macro-
unprintable:
;; fields 1 and 2 are for maintaining this mutex in a deq of btqs
;; fields 3 to 5 are for maintaining a queue of blocked threads
;; field 6 is the leftmost thread in the queue of blocked threads
;; field 7 is the owner of the mutex (or 'not-owned or 'abandoned or #f)
(btq-deq-next init: #f)
(btq-deq-prev init: #f)
(btq-color init: #f)
(btq-parent init: #f)
(btq-left init: #f)
(btq-leftmost init: #f)
(btq-owner init: #f)
(name
macro-mutex-name
macro-mutex-name-set!)
(specific
macro-mutex-specific
macro-mutex-specific-set!)
)
(##define-macro (macro-make-mutex name)
`(let ((name ,name))
(let ((mutex (macro-construct-mutex name (##void))))
(macro-btq-deq-init! mutex)
(macro-btq-init! mutex)
mutex)))
(##define-macro (macro-mutex-unlocked-not-abandoned-and-not-multiprocessor? mutex)
`(##not (macro-btq-owner ,mutex)))
(##define-macro (macro-mutex-lock! mutex absrel-timeout owner)
`(let ((mutex ,mutex) (absrel-timeout ,absrel-timeout) (owner ,owner))
(##declare (not interrupts-enabled))
(let ((state (macro-btq-owner mutex)))
(if state
(##mutex-lock-out-of-line! mutex absrel-timeout owner)
(begin
(macro-btq-link! mutex owner)
#t)))))
(##define-macro (macro-mutex-lock-anonymously! mutex absrel-timeout)
`(let ((mutex ,mutex) (absrel-timeout ,absrel-timeout))
(##declare (not interrupts-enabled))
(let ((state (macro-btq-owner mutex)))
(if state
(##mutex-lock-out-of-line! mutex absrel-timeout #f)
(begin
(macro-btq-owner-set! mutex 'not-owned)
#t)))))
(##define-macro (macro-mutex-unlock! mutex)
`(let ((mutex ,mutex))
(##declare (not interrupts-enabled))
(macro-btq-deq-remove! mutex)
(let ((leftmost (macro-btq-leftmost mutex)))
(if (##eq? leftmost mutex)
(begin
(macro-btq-unlink! mutex #f)
(##void))
(##mutex-signal! mutex leftmost #f)))))
(##define-macro (macro-mutex-unlock-no-reschedule! mutex)
`(let ((mutex ,mutex))
(##declare (not interrupts-enabled))
(macro-btq-deq-remove! mutex)
(let ((leftmost (macro-btq-leftmost mutex)))
(if (##eq? leftmost mutex)
(begin
(macro-btq-unlink! mutex #f)
(##void))
(##mutex-signal-no-reschedule! mutex leftmost #f)))))
;;; Representation of condition variables.
(define-type condition-variable
id: 6bd864f0-27ec-4639-8044-cf7c0135d716
type-exhibitor: macro-type-condvar
constructor: macro-construct-condvar
implementer: implement-type-condvar
predicate: macro-condvar?
opaque:
macros:
prefix: macro-
unprintable:
;; fields 1 and 2 are for maintaining this condition variable in a deq of btqs
;; fields 3 to 5 are for maintaining a queue of blocked threads
;; field 6 is the leftmost thread in the queue of blocked threads
;; field 7 is the owner of the condition variable
(btq-deq-next init: #f)
(btq-deq-prev init: #f)
(btq-color init: #f)
(btq-parent init: #f)
(btq-left init: #f)
(btq-leftmost init: #f)
(btq-owner init: #f)
(name
macro-condvar-name
macro-condvar-name-set!)
(specific
macro-condvar-specific
macro-condvar-specific-set!)
)
(##define-macro (macro-make-condvar name)
`(let ((name ,name))
(let ((condvar (macro-construct-condvar name (##void))))
(macro-btq-deq-init! condvar)
(macro-btq-init! condvar)
condvar)))
;;; Representation of thread groups.
(define-type thread-group
id: 713f0ba8-1d76-4a68-8dfa-eaebd4aef1e3
type-exhibitor: macro-type-tgroup
constructor: macro-construct-tgroup
implementer: implement-type-tgroup
predicate: macro-tgroup?
opaque:
macros:
prefix: macro-
unprintable:
(tgroups-deq-next
macro-tgroup-tgroups-deq-next
macro-tgroup-tgroups-deq-next-set!)
(tgroups-deq-prev
macro-tgroup-tgroups-deq-prev
macro-tgroup-tgroups-deq-prev-set!)
(tgroups
macro-tgroup-tgroups
macro-tgroup-tgroups-set!)
(parent
macro-tgroup-parent
macro-tgroup-parent-set!)
(name
macro-tgroup-name
macro-tgroup-name-set!)
(suspend-condvar
macro-tgroup-suspend-condvar
macro-tgroup-suspend-condvar-set!)
(unused1
macro-tgroup-unused1
macro-tgroup-unused1-set!)
(unused2
macro-tgroup-unused2
macro-tgroup-unused2-set!)
(unused3
macro-tgroup-unused3
macro-tgroup-unused3-set!)
(unused4
macro-tgroup-unused4
macro-tgroup-unused4-set!)
(unused5
macro-tgroup-unused5
macro-tgroup-unused5-set!)
(threads-deq-next
macro-tgroup-threads-deq-next
macro-tgroup-threads-deq-next-set!)
(threads-deq-prev
macro-tgroup-threads-deq-prev
macro-tgroup-threads-deq-prev-set!)
)
(##define-macro (macro-make-tgroup name parent)
`(let ((name ,name) (parent ,parent))
(let* ((tgroups
(##vector #f #f #f))
(tgroup
(macro-construct-tgroup
#f
#f
tgroups
parent
name
#f
#f
#f
#f
#f
#f
#f
#f)))
(macro-tgroup-tgroups-deq-init! tgroups)
(macro-tgroup-threads-deq-init! tgroup)
(if parent
(macro-tgroup-tgroups-deq-insert!
(macro-tgroup-tgroups parent)
tgroup))
tgroup)))
(##define-macro (macro-tgroup-tgroups-deq-init! deq)
`(let ((deq ,deq))
(##declare (not interrupts-enabled))
(macro-tgroup-tgroups-deq-next-set! deq deq)
(macro-tgroup-tgroups-deq-prev-set! deq deq)))
(##define-macro (macro-tgroup-tgroups-deq-remove! item)
`(let ((item ,item))
(##declare (not interrupts-enabled))
(let ((item-next (macro-tgroup-tgroups-deq-next item))
(item-prev (macro-tgroup-tgroups-deq-prev item)))
(macro-tgroup-tgroups-deq-next-set! item-prev item-next)
(macro-tgroup-tgroups-deq-prev-set! item-next item-prev))))
(##define-macro (macro-tgroup-tgroups-deq-insert! deq item)
`(let ((deq ,deq) (item ,item))
(##declare (not interrupts-enabled))
;; add item to tail of deq
(let ((deq-last (macro-tgroup-tgroups-deq-prev deq)))
(macro-tgroup-tgroups-deq-next-set! deq-last item)
(macro-tgroup-tgroups-deq-prev-set! deq item)
(macro-tgroup-tgroups-deq-next-set! item deq)
(macro-tgroup-tgroups-deq-prev-set! item deq-last))))
(##define-macro (macro-tgroup-threads-deq-init! deq)
`(let ((deq ,deq))
(##declare (not interrupts-enabled))
(macro-tgroup-threads-deq-next-set! deq deq)
(macro-tgroup-threads-deq-prev-set! deq deq)))
(##define-macro (macro-tgroup-threads-deq-remove! item)
`(let ((item ,item))
(##declare (not interrupts-enabled))
(let ((item-next (macro-tgroup-threads-deq-next item))
(item-prev (macro-tgroup-threads-deq-prev item)))
(macro-tgroup-threads-deq-next-set! item-prev item-next)
(macro-tgroup-threads-deq-prev-set! item-next item-prev))))
(##define-macro (macro-tgroup-threads-deq-insert! deq item)
`(let ((deq ,deq) (item ,item))
(##declare (not interrupts-enabled))
;; add item to tail of deq
(let ((deq-last (macro-tgroup-threads-deq-prev deq)))
(macro-tgroup-threads-deq-next-set! deq-last item)
(macro-tgroup-threads-deq-prev-set! deq item)
(macro-tgroup-threads-deq-next-set! item deq)
(macro-tgroup-threads-deq-prev-set! item deq-last))))
;;; Representation of the run queue.
(define-type run-queue
id: 2dbd1deb-107f-4730-a7ba-c191bcf132fe
type-exhibitor: macro-type-run-queue
constructor: macro-construct-run-queue
implementer: implement-type-run-queue
predicate: macro-run-queue?
opaque:
macros:
prefix: macro-
unprintable:
;; fields 1 and 2 are the deq links of blocking device condvars
;; fields 3 to 5 are for maintaining a queue of runnable threads
;; field 6 is the leftmost thread in the queue of runnable threads
;; field 7 must be #f (the queue of runnable threads has no owner)
;; fields 8 to 10 are for maintaining a timeout queue of threads
;; field 11 is the leftmost thread in the timeout queue of threads
;; field 14 is for storing the current time, heartbeat interval and a
;; temporary float
condvar-deq-next
condvar-deq-prev
btq-color
btq-parent
btq-left
btq-leftmost
false
toq-color
toq-parent
toq-left
toq-leftmost
primordial-thread
unused
floats
)
(##define-macro (macro-current-time f) `(##f64vector-ref ,f 0))
(##define-macro (macro-current-time-set! f x) `(##f64vector-set! ,f 0 ,x))
(##define-macro (macro-heartbeat-interval f) `(##f64vector-ref ,f 1))
(##define-macro (macro-heartbeat-interval-set! f x)`(##f64vector-set! ,f 1 ,x))
(##define-macro (macro-temp f) `(##f64vector-ref ,f 2))
(##define-macro (macro-temp-set! f x) `(##f64vector-set! ,f 2 ,x))
(##define-macro (macro-update-current-time!)
`(##get-current-time! (macro-thread-floats (macro-run-queue))))
(##define-macro (macro-make-run-queue)
`(let ((run-queue
(macro-construct-run-queue
#f
#f
#f
#f
#f
#f
#f
#f
#f
#f
#f
#f
#f
(##f64vector (macro-inexact-+0)
(macro-inexact-+0)
(macro-inexact-+0)))))
(macro-btq-deq-init! run-queue)
(macro-btq-init! run-queue)
(macro-toq-init! run-queue)
run-queue))
;;; Representation of thread states.
(define-library-type thread-state-uninitialized
id: c63af440-d5ef-4f02-8fe6-40836a312fae
constructor: #f
opaque:
)
(define-library-type thread-state-initialized
id: 47368926-951d-4451-92b0-dd9b4132eca9
constructor: #f
opaque:
)
(define-library-type thread-state-normally-terminated
id: c475ff99-c959-4784-a847-b0c52aff8f2a
constructor: #f
opaque:
(result printable: read-only:)
)
(define-library-type thread-state-abnormally-terminated
id: 291e311e-93e0-4765-8132-56a719dc84b3
constructor: #f
opaque:
(reason printable: read-only:)
)
(define-library-type thread-state-active
id: dc963fdc-4b54-45a2-8af6-01654a6dc6cd
constructor: #f
opaque:
(waiting-for printable: read-only:)
(timeout printable: read-only:)
)
;;;============================================================================
Something went wrong with that request. Please try again.