_thread.scm

;;;============================================================================

;;; File: "_thread.scm", Time-stamp: <2008-09-27 23:18:40 feeley>

;;; Copyright (c) 1994-2008 by Marc Feeley, All Rights Reserved.

;;;============================================================================

(##include "header.scm")
;;(##include "sys.scm")

;;;============================================================================

;;; Implementation of exceptions.

(implement-library-type-deadlock-exception)
(implement-library-type-abandoned-mutex-exception)
(implement-library-type-scheduler-exception)
(implement-library-type-noncontinuable-exception)

(implement-library-type-initialized-thread-exception)

(define-prim (##raise-initialized-thread-exception proc . args)
  (##extract-procedure-and-arguments
   proc
   args
   #f
   #f
   #f
   (lambda (procedure arguments dummy1 dummy2 dummy3)
     (macro-raise
      (macro-make-initialized-thread-exception procedure arguments)))))

(implement-library-type-uninitialized-thread-exception)

(define-prim (##raise-uninitialized-thread-exception proc . args)
  (##extract-procedure-and-arguments
   proc
   args
   #f
   #f
   #f
   (lambda (procedure arguments dummy1 dummy2 dummy3)
     (macro-raise
      (macro-make-uninitialized-thread-exception procedure arguments)))))

(implement-library-type-inactive-thread-exception)

(define-prim (##raise-inactive-thread-exception proc . args)
  (##extract-procedure-and-arguments
   proc
   args
   #f
   #f
   #f
   (lambda (procedure arguments dummy1 dummy2 dummy3)
     (macro-raise
      (macro-make-inactive-thread-exception procedure arguments)))))

(implement-library-type-started-thread-exception)

(define-prim (##raise-started-thread-exception proc . args)
  (##extract-procedure-and-arguments
   proc
   args
   #f
   #f
   #f
   (lambda (procedure arguments dummy1 dummy2 dummy3)
     (macro-raise
      (macro-make-started-thread-exception procedure arguments)))))

(implement-library-type-terminated-thread-exception)

(define-prim (##raise-terminated-thread-exception proc . args)
  (##extract-procedure-and-arguments
   proc
   args
   #f
   #f
   #f
   (lambda (procedure arguments dummy1 dummy2 dummy3)
     (macro-raise
      (macro-make-terminated-thread-exception procedure arguments)))))

(implement-library-type-uncaught-exception)

(define-prim (##raise-uncaught-exception reason proc . args)
  (##extract-procedure-and-arguments
   proc
   args
   reason
   #f
   #f
   (lambda (procedure arguments reason dummy1 dummy2)
     (macro-raise
      (macro-make-uncaught-exception procedure arguments reason)))))

(implement-library-type-join-timeout-exception)

(define-prim (##raise-join-timeout-exception proc . args)
  (##extract-procedure-and-arguments
   proc
   args
   #f
   #f
   #f
   (lambda (procedure arguments dummy1 dummy2 dummy3)
     (macro-raise
      (macro-make-join-timeout-exception procedure arguments)))))

(implement-library-type-mailbox-receive-timeout-exception)

(define-prim (##raise-mailbox-receive-timeout-exception proc . args)
  (##extract-procedure-and-arguments
   proc
   args
   #f
   #f
   #f
   (lambda (procedure arguments dummy1 dummy2 dummy3)
     (macro-raise
      (macro-make-mailbox-receive-timeout-exception procedure arguments)))))

;;;----------------------------------------------------------------------------

;;; Define type checking procedures.

(implement-check-type-continuation)
(implement-check-type-time)
(implement-check-type-absrel-time)
(implement-check-type-absrel-time-or-false)
(implement-check-type-thread)
(implement-check-type-mutex)
(implement-check-type-condvar)
(implement-check-type-tgroup)

;;;----------------------------------------------------------------------------

(implement-type-thread)
(implement-type-mutex)
(implement-type-condvar)
(implement-type-tgroup)

(implement-library-type-thread-state-uninitialized)
(implement-library-type-thread-state-initialized)
(implement-library-type-thread-state-normally-terminated)
(implement-library-type-thread-state-abnormally-terminated)
(implement-library-type-thread-state-active)

(##declare (not interrupts-enabled));;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;============================================================================

;;; File: "thread.scm"

;;; Copyright (c) 2003 by Marc Feeley, All Rights Reserved.

;;; Version 1.3 (august 14, 2000)

(##define-macro (macro-if-gambit-3.0 yes no)
  no)

(##define-macro (macro-not-yet-implemented)
  `(##void));;;;;;;;;;;*************

;;;----------------------------------------------------------------------------

;;; Implementation of dynamic environments.

(define ##parameter-counter 0)

(define-prim (##make-parameter
              init
              #!optional
              (f (macro-absent-obj)))
  (let ((filter
         (if (##eq? f (macro-absent-obj))
           (lambda (x) x)
           f)))
    (macro-check-procedure filter 2 (make-parameter init f)
      (let* ((val
              (filter init))
             (new-count
              (##fixnum.+ ##parameter-counter 1)))
        ;; Note: it is unimportant if the increment of
        ;; ##parameter-counter is not atomic; it simply means a
        ;; possible close repetition of the same hash code
        (set! ##parameter-counter new-count)
        (let ((descr
               (macro-make-parameter-descr
                val
                (##partial-bit-reverse new-count)
                filter)))
          (letrec ((param
                    (lambda (#!optional (new-val (macro-absent-obj)))
                      (if (##eq? new-val (macro-absent-obj))
                        (##dynamic-ref param)
                        (##dynamic-set!
                         param
                         ((macro-parameter-descr-filter descr) new-val))))))
            param))))))

(define-prim (make-parameter init #!optional (f (macro-absent-obj)))
  (macro-force-vars (f)
    (##make-parameter init f)))

(define ##current-exception-handler
  (##make-parameter
   (lambda (exc)
     (##thread-end-with-uncaught-exception! exc))
   (lambda (val)
     (macro-check-procedure val 1 (##current-exception-handler val)
       val))))

(define current-exception-handler
  ##current-exception-handler)

(define ##current-readtable
  (##make-parameter
   ##main-readtable
   (lambda (val)
     (macro-check-readtable val 1 (##current-readtable val)
       val))))

(define current-readtable
  ##current-readtable)

(##open-all-predefined)

(define ##current-input-port
  (##make-parameter
   ##stdin-port
   (lambda (val)
     (macro-check-input-port val 1 (##current-input-port val)
       val))))

(define current-input-port
  ##current-input-port)

(define ##current-output-port
  (##make-parameter
   ##stdout-port
   (lambda (val)
     (macro-check-output-port val 1 (##current-output-port val)
       val))))

(define current-output-port
  ##current-output-port)

(define ##current-error-port
  (##make-parameter
   ##stderr-port
   (lambda (val)
     (macro-check-output-port val 1 (##current-error-port val)
       val))))

(define current-error-port
  ##current-error-port)

(define-prim (##current-directory-filter val)
  (if (##eq? val (macro-absent-obj))
    (let ((current-dir
           (##os-path-normalize-directory #f)))
      (if (##fixnum? current-dir)
        (##exit-with-err-code current-dir)
        current-dir))
    (macro-check-string val 1 (##current-directory val)
      (let ((normalized-dir
             (##os-path-normalize-directory (##path-expand val))))
        (if (##fixnum? normalized-dir)
          (##raise-os-exception #f normalized-dir ##current-directory val)
          normalized-dir)))))

(define ##current-directory
  (##make-parameter
   (macro-absent-obj)
   ##current-directory-filter))

(define current-directory
  ##current-directory)

(define-prim (##parameter? obj)
  (##declare (not interrupts-enabled))
  (and (##procedure? obj)
       (##closure? obj)
       (##eq? (##closure-code obj)
              (##closure-code ##current-exception-handler))))

(##define-macro (macro-parameter-descr param)
  `(##closure-ref ,param 1))

(define-prim (##parameterize param val thunk)
  (##declare (not interrupts-enabled))
  (macro-check-procedure param 1 (##parameterize param val thunk)
    (macro-check-procedure thunk 3 (##parameterize param val thunk)
      (if (##parameter? param)
        (##dynamic-let
         param
         ((macro-parameter-descr-filter (macro-parameter-descr param)) val)
         thunk)
        (let ((save (param)))
          (##dynamic-wind
           (lambda () ;; before
             (param val))
           thunk
           (lambda () ;; after
             (param save))))))))

(define-prim (##dynamic-ref param)
  (##declare (not interrupts-enabled))
  (cond ((##eq? param ##current-exception-handler)
         (macro-current-exception-handler))
        ((##eq? param ##current-input-port)
         (macro-current-input-port))
        ((##eq? param ##current-output-port)
         (macro-current-output-port))
        (else
         (let* ((current-thread
                 (macro-current-thread))
                (c1
                 (macro-thread-denv-cache1 current-thread)))
           (if (##eq? param (##car c1))
             (##cdr c1)
             (let ((c2 (macro-thread-denv-cache2 current-thread)))
               (if (##eq? param (##car c2))
                 (begin
                   (macro-thread-denv-cache2-set! current-thread c1)
                   (macro-thread-denv-cache1-set! current-thread c2)
                   (##cdr c2))
                 (let ((c3 (macro-thread-denv-cache3 current-thread)))
                   (if (##eq? param (##car c3))
                     (begin
                       (macro-thread-denv-cache3-set! current-thread c2)
                       (macro-thread-denv-cache2-set! current-thread c1)
                       (macro-thread-denv-cache1-set! current-thread c3)
                       (##cdr c3))
                     (let* ((denv
                             (macro-thread-denv current-thread))
                            (x
                             (##env-lookup (macro-denv-local denv) param)))
                       (if x
                         (begin
                           (macro-thread-denv-cache3-set!
                            current-thread
                            (macro-thread-denv-cache2 current-thread))
                           (macro-thread-denv-cache2-set!
                            current-thread
                            (macro-thread-denv-cache1 current-thread))
                           (macro-thread-denv-cache1-set!
                            current-thread
                            x)
                           (##cdr x))
                         (macro-parameter-descr-value
                          (macro-parameter-descr param)))))))))))))

(define-prim (##dynamic-set! param val)
  (##declare (not interrupts-enabled))
  (cond ((##eq? param ##current-exception-handler)
         (macro-current-exception-handler-set! val)
         (##void))
        ((##eq? param ##current-input-port)
         (macro-current-input-port-set! val)
         (##void))
        ((##eq? param ##current-output-port)
         (macro-current-output-port-set! val)
         (##void))
        (else
         (let* ((current-thread
                 (macro-current-thread))
                (c1
                 (macro-thread-denv-cache1 current-thread)))
           (if (##eq? param (##car c1))
             (begin
               (##set-cdr! c1 val)
               (##void))
             (let ((c2 (macro-thread-denv-cache2 current-thread)))
               (if (##eq? param (##car c2))
                 (begin
                   (macro-thread-denv-cache2-set! current-thread c1)
                   (macro-thread-denv-cache1-set! current-thread c2)
                   (##set-cdr! c2 val)
                   (##void))
                 (let ((c3 (macro-thread-denv-cache3 current-thread)))
                   (if (##eq? param (##car c3))
                     (begin
                       (macro-thread-denv-cache3-set! current-thread c2)
                       (macro-thread-denv-cache2-set! current-thread c1)
                       (macro-thread-denv-cache1-set! current-thread c3)
                       (##set-cdr! c3 val)
                       (##void))
                     (let* ((denv
                             (macro-thread-denv current-thread))
                            (x
                             (##env-lookup (macro-denv-local denv) param)))
                       (if x
                         (begin
                           (macro-thread-denv-cache3-set!
                            current-thread
                            (macro-thread-denv-cache2 current-thread))
                           (macro-thread-denv-cache2-set!
                            current-thread
                            (macro-thread-denv-cache1 current-thread))
                           (macro-thread-denv-cache1-set!
                            current-thread
                            x)
                           (##set-cdr! x val)
                           (##void))
                         (begin
                           (macro-parameter-descr-value-set!
                            (macro-parameter-descr param)
                            val)
                           (##void)))))))))))))

(define-prim (##dynamic-let param val thunk)
  (##declare (not interrupts-enabled))
  (cond ((##eq? param ##current-exception-handler)
         (macro-dynamic-bind exception-handler
          val
          thunk))
        ((##eq? param ##current-input-port)
         (macro-dynamic-bind input-port
          val
          thunk))
        ((##eq? param ##current-output-port)
         (macro-dynamic-bind output-port
          val
          thunk))
        (else
         (let* ((param-val
                 (##cons param val))
                (denv
                 (macro-thread-denv (macro-current-thread)))
                (new-local-denv
                 (##env-insert (macro-denv-local denv) param-val)))
           (##dynamic-env-bind
            (macro-make-denv
             new-local-denv
             (macro-denv-dynwind denv)
             (macro-denv-interrupt-mask denv)
             (macro-denv-debugging-settings denv)
             (macro-denv-exception-handler denv)
             (macro-denv-input-port denv)
             (macro-denv-output-port denv)
             (macro-denv-repl-context denv))
            thunk)))))

(define-prim (##dynamic-env->list denv)
  (##cons (macro-denv-exception-handler denv)
          (##cons (macro-denv-input-port denv)
                  (##cons (macro-denv-output-port denv)
                          (##env-flatten (macro-denv-local denv)
                                         '())))))

(define-prim (##env-insert env param-val)
  (let* ((param
          (##car param-val))
         (hash-param
          (macro-parameter-descr-hash
           (macro-parameter-descr param))))

    (define (insert env)
      (if (##null? env)
        (macro-make-env
         param-val
         '()
         '())
        (let* ((x
                (macro-env-param-val env))
               (param-x
                (##car x))
               (hash-param-x
                (macro-parameter-descr-hash
                 (macro-parameter-descr param-x))))
          (cond ((##fixnum.< hash-param hash-param-x)
                 (macro-make-env
                  x
                  (insert (macro-env-left env))
                  (macro-env-right env)))
                ((or (##fixnum.< hash-param-x hash-param)
                     (##not (##eq? param-x param)))
                 (macro-make-env
                  x
                  (macro-env-left env)
                  (insert (macro-env-right env))))
                (else
                 (macro-make-env
                  param-val
                  (macro-env-left env)
                  (macro-env-right env)))))))

    (insert env)))

(define-prim (##env-insert! env param val)
  (##declare (not interrupts-enabled))
  (let ((hash-param
         (macro-parameter-descr-hash
          (macro-parameter-descr param))))

    (define (insert! env)
      (let* ((x
              (macro-env-param-val env))
             (param-x
              (##car x))
             (hash-param-x
              (macro-parameter-descr-hash
               (macro-parameter-descr param-x))))
        (cond ((##fixnum.< hash-param hash-param-x)
               (let ((branch (macro-env-left env)))
                 (if (##null? branch)
                   (let ((y (##cons param val)))
                     (macro-env-left-set! env (macro-make-env y '() '()))
                     (##void))
                   (insert! branch))))
              ((or (##fixnum.< hash-param-x hash-param)
                   (##not (##eq? param-x param)))
               (let ((branch (macro-env-right env)))
                 (if (##null? branch)
                   (let ((y (##cons param val)))
                     (macro-env-right-set! env (macro-make-env y '() '()))
                     (##void))
                   (insert! branch))))
              (else
               (##set-cdr! x val)
               (##void)))))

    (insert! env)))

(define-prim (##env-lookup env param)
  (##declare (not interrupts-enabled))
  (let ((hash-param
         (macro-parameter-descr-hash
          (macro-parameter-descr param))))

    (define (lookup env)
      (if (##null? env)
        #f
        (let* ((x
                (macro-env-param-val env))
               (param-x
                (##car x))
               (hash-param-x
                (macro-parameter-descr-hash
                 (macro-parameter-descr param-x))))
          (cond ((##fixnum.< hash-param hash-param-x)
                 (lookup (macro-env-left env)))
                ((or (##fixnum.< hash-param-x hash-param)
                     (##not (##eq? param-x param)))
                 (lookup (macro-env-right env)))
                (else
                 x)))))

    (lookup env)))

(define-prim (##env-flatten env tail)

  (define (flatten env tail)
    (if (##null? env)
      tail
      (##cons (macro-env-param-val env)
              (flatten (macro-env-left env)
                       (flatten (macro-env-right env)
                                tail)))))

  (flatten env tail))

;;;----------------------------------------------------------------------------

;;; Implementation of time objects.

(define-prim (##absrel-timeout->timeout absrel-timeout)
  (cond ((##not absrel-timeout)
         #t)
        ((macro-time? absrel-timeout)
         (macro-update-current-time!)
         (let ((current-time
                (macro-current-time
                 (macro-thread-floats (macro-run-queue))))
               (point
                (macro-time-point absrel-timeout)))
           (and (##flonum.< current-time point)
                point)))
        ((and (##fixnum? absrel-timeout)
              (##not (##fixnum.< 0 absrel-timeout)))
         #f)
        (else
         (let ((flonum-absrel-timeout
                (macro-real->inexact absrel-timeout)))
           (and (##flonum.positive? flonum-absrel-timeout)
                (begin
                  (macro-update-current-time!)
                  (let ((current-time
                         (macro-current-time
                          (macro-thread-floats (macro-run-queue)))))
                    (##flonum.+ current-time
                                flonum-absrel-timeout))))))))

(define-prim (##timeout->time absrel-timeout)
  (cond ((##not absrel-timeout)
         (macro-make-time (macro-inexact-+inf) #f #f #f))
        ((macro-time? absrel-timeout)
         absrel-timeout)
        ((##real? absrel-timeout)
         (let ((flonum-absrel-timeout
                (macro-real->inexact absrel-timeout)))
           (macro-update-current-time!)
           (let ((current-time
                  (macro-current-time
                   (macro-thread-floats (macro-run-queue)))))
             (macro-make-time
              (##flonum.+ current-time flonum-absrel-timeout)
              #f
              #f
              #f))))
        (else
         (##fail-check-absrel-time-or-false
          1
          timeout->time
          absrel-timeout))))

;;;----------------------------------------------------------------------------

;;; Implementation of blocked thread queues.

(define-rbtree
 macro-btq-init!
 macro-thread->btq
 ##btq-insert!
 ##btq-remove!
 ##btq-reposition!
 macro-btq-singleton?
 macro-btq-color
 macro-btq-color-set!
 macro-btq-parent
 macro-btq-parent-set!
 macro-btq-left
 macro-btq-left-set!
 macro-btq-right
 macro-btq-right-set!
 macro-thread-higher-prio?
 macro-btq-leftmost
 macro-btq-leftmost-set!
 #f
 #f
)

(define-prim (##btq-abandon! btq)
  (##declare (not interrupts-enabled))
  (macro-btq-deq-remove! btq)
  (let ((leftmost (macro-btq-leftmost btq)))
    (if (##eq? leftmost btq)
      (macro-btq-unlink! btq 'abandoned)
      (if (macro-mutex? btq)
        (##mutex-signal-no-reschedule! btq leftmost #t)
        (begin
          (let ((owner (macro-btq-owner btq)))
            (if (macro-thread? owner)
              (##thread-effective-priority-downgrade! owner)))
          (macro-btq-unlink! btq 'abandoned))))))

;;; Implementation of timeout queues.

(define-rbtree
 macro-toq-init!
 macro-thread->toq
 ##toq-insert!
 ##toq-remove!
 ##toq-reposition!
 macro-toq-singleton?
 macro-toq-color
 macro-toq-color-set!
 macro-toq-parent
 macro-toq-parent-set!
 macro-toq-left
 macro-toq-left-set!
 macro-toq-right
 macro-toq-right-set!
 macro-thread-sooner-or-simultaneous-and-higher-prio?
 macro-toq-leftmost
 macro-toq-leftmost-set!
 #f
 #f
)

;;;----------------------------------------------------------------------------

;;; Implementation of threads.

(define-prim (##run-queue)
  (##declare (not interrupts-enabled))
  (macro-run-queue))

(define-prim (##current-thread)
  (##declare (not interrupts-enabled))
  (macro-current-thread))

(define-prim (##make-thread thunk name tgroup)
  (##declare (not interrupts-enabled))
  (macro-make-thread thunk name tgroup))

(define-prim (##thread-start! thread)
  (##declare (not interrupts-enabled))
  (macro-thread-result-set! thread ##thread-start-action!)
  (##btq-insert! (macro-run-queue) thread)
  (macro-thread-reschedule-if-needed!)
  thread)

(define-prim (##thread-base-priority-set! thread base-priority)

  (##declare (not interrupts-enabled))

  (let ((floats (macro-thread-floats thread)))

    ;; save old boosted priority for ##thread-boosted-priority-changed!

    (macro-temp-set!
     (macro-thread-floats (macro-run-queue))
     (macro-boosted-priority floats))

    (if (##flonum.= (macro-base-priority floats)
                    (macro-boosted-priority floats))
(begin (set! pcase3 (##fixnum.+ pcase3 1));;;;;;;;;;;;;;;;;;
      (macro-boosted-priority-set!
       floats
       base-priority)
)
(begin (set! pcase4 (##fixnum.+ pcase4 1));;;;;;;;;;;;;;;;;;
      (macro-boosted-priority-set!
       floats
       (##flonum.+ base-priority
                   (macro-priority-boost floats))))
)

    (macro-base-priority-set! floats base-priority)

    (##thread-boosted-priority-changed! thread)

    ;; the change of priority may have made a higher priority
    ;; thread runnable, check for this

    (macro-thread-reschedule-if-needed!)))

(define-prim (##thread-quantum-set! thread quantum)

  (##declare (not interrupts-enabled))

  (macro-thread-quantum-set! thread quantum)

  ;; check if the current thread's quantum is now over

  (if (and (##eq? thread (macro-current-thread))
           (##not (##flonum.< (macro-thread-quantum-used thread) quantum)))
    (##thread-yield!)
    (##void)))

(define-prim (##thread-priority-boost-set! thread priority-boost)

  (##declare (not interrupts-enabled))

  (let ((floats (macro-thread-floats thread)))

    (macro-priority-boost-set! floats priority-boost)

    (if (##flonum.= (macro-base-priority floats)
                    (macro-boosted-priority floats))

(begin (set! pcase5 (##fixnum.+ pcase5 1));;;;;;;;;;;;;;;;;;
      (##void)
)

      (begin

(set! pcase6 (##fixnum.+ pcase6 1));;;;;;;;;;;;;;;;;;

        ;; 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)
                     priority-boost))

        (##thread-boosted-priority-changed! thread)

        ;; the change of priority may have made a higher priority
        ;; thread runnable, check for this

        (macro-thread-reschedule-if-needed!)))))

(define-prim (##thread-boosted-priority-changed! thread)

  (##declare (not interrupts-enabled))

  (let ((floats (macro-thread-floats thread)))
    (cond ((##flonum.<
            (macro-effective-priority floats)
            (macro-boosted-priority floats))
(set! pcase7 (##fixnum.+ pcase7 1));;;;;;;;;;;;;;;;;;
           (macro-effective-priority-set!
            floats
            (macro-boosted-priority floats))
           (##thread-effective-priority-changed! thread #t))
          ((##flonum.=
            (macro-effective-priority floats)
            (macro-temp (macro-thread-floats (macro-run-queue))))
(set! pcase8 (##fixnum.+ pcase8 1));;;;;;;;;;;;;;;;;;
           (##thread-effective-priority-downgrade! thread))
(else (set! pcase9 (##fixnum.+ pcase9 1)));;;;;;;;;;;;;;;;;;
)))

(define-prim (##thread-effective-priority-changed! thread effective-priority-increased?)

  (##declare (not interrupts-enabled))

  (if (macro-toq-parent thread)
    (##toq-reposition! thread)) ;; reposition thread in the toq it is in

  (if (macro-btq-parent thread)
    (begin
      (##btq-reposition! thread) ;; reposition thread in the btq it is in

      ;; make sure the owner of the blocked thread queue
      ;; (i.e. mutex, condvar, etc) inherits the thread's effective
      ;; priority

      (let ((owner (macro-btq-owner (macro-thread->btq thread))))
        (if (macro-thread? owner)
          (if effective-priority-increased?
(begin (set! pcase10 (##fixnum.+ pcase10 1));;;;;;;;;;;;;;;;;;
            (macro-thread-inherit-priority! owner thread)
)
(begin (set! pcase11 (##fixnum.+ pcase11 1));;;;;;;;;;;;;;;;;;
            (##thread-effective-priority-downgrade! owner)))))))
)

;; (##thread-effective-priority-downgrade! thread) is called to
;; recompute the effective priority of a thread.  It is only called in
;; situations where the new effective priority is no more than the old
;; one.

(define-prim (##thread-effective-priority-downgrade! thread)

  (##declare (not interrupts-enabled))

  (let ((floats (macro-thread-floats thread)))

    ;; save old effective priority for later

    (macro-temp-set!
     (macro-thread-floats (macro-run-queue))
     (macro-effective-priority floats))

    ;; compute the maximum of the boosted priority and the
    ;; effective priority of all the threads in blocked thread
    ;; queues (i.e. mutexes, condvars, etc) owned by the thread

    (macro-effective-priority-set!
     floats
     (macro-boosted-priority floats))

    (let loop ((btq (macro-btq-deq-next thread)))
      (if (##not (##eq? btq thread))
        (let ((leftmost (macro-btq-leftmost btq)))
          (if (##not (##eq? leftmost btq))
            (let ((leftmost-floats (macro-thread-floats leftmost)))
              (if (##flonum.< (macro-effective-priority floats)
                              (macro-effective-priority leftmost-floats))
                (macro-effective-priority-set!
                 floats
                 (macro-effective-priority leftmost-floats)))))
          (loop (macro-btq-deq-next btq)))))

;;;;;;;;;;;;(set! pcase14 (##cons (##cons (macro-temp (macro-thread-floats (macro-run-queue))) (macro-effective-priority floats))pcase14));;;;;;;;;;;;;;;;;;;;;;;
    (if (##not (##flonum.=
                (macro-temp (macro-thread-floats (macro-run-queue)))
                (macro-effective-priority floats)))
(begin (set! pcase12 (##fixnum.+ pcase12 1));;;;;;;;;;;;;;;;;;
      (##thread-effective-priority-changed! thread #f)
)
(set! pcase13 (##fixnum.+ pcase13 1));;;;;;;;;;;;;;;;;;
)))

(define-prim (##thread-btq-insert! btq thread)
  (##declare (not interrupts-enabled))
  (##btq-insert! btq thread)
  (let ((owner (macro-btq-owner btq)))
    (if (macro-thread? owner)
      (macro-thread-inherit-priority! owner thread))))

(define-prim (##thread-btq-remove! thread)

  (##declare (not interrupts-enabled))

  (let ((owner (macro-btq-owner (macro-thread->btq thread))))
    (##btq-remove! thread)
    (if (macro-thread? owner)
      (if (##flonum.= (macro-thread-effective-priority thread)
                      (macro-thread-effective-priority owner))
        (##thread-effective-priority-downgrade! owner)))))

(define-prim (##thread-toq-remove! thread)
  (##declare (not interrupts-enabled))
  (##toq-remove! thread))

(define-prim (##thread-check-timeouts!)

  (##declare (not interrupts-enabled))

  (macro-update-current-time!)

  (let ((run-queue (macro-run-queue)))
    (let loop ()
      (let ((leftmost (macro-toq-leftmost run-queue)))
        (if (and (##not (##eq? leftmost run-queue))
                 (##not (macro-thread-sooner? run-queue leftmost)))
          (begin
            (macro-thread-result-set! leftmost ##thread-timeout-action!)
            (macro-thread-btq-remove-if-in-btq! leftmost)
            (##thread-toq-remove! leftmost)
            (##btq-insert! run-queue leftmost)
            (loop)))))))

(define-prim (##thread-check-devices! timeout)

  (##declare (not interrupts-enabled))

  (let* ((run-queue (macro-run-queue))
         (code (##os-condvar-select! run-queue timeout)))
    (let loop ((condvar (macro-btq-deq-next run-queue)))
      (if (##eq? condvar run-queue)
        code
        (let ((next (macro-btq-deq-next condvar)))
          (if (##fixnum.odd? (macro-btq-owner condvar))
            (##device-condvar-broadcast-no-reschedule! condvar))
          (loop next))))))

(define-prim (##thread-heartbeat!)

  (##declare (not interrupts-enabled))

  (let ((code (##thread-check-devices! #f))) ;; poll devices

    (##thread-check-timeouts!)

    (if (and (##fixnum.< code 0)
             (##not (##fixnum.= code ##err-code-EINTR)))

      ;; there was an error that cannot be handled, so force the
      ;; primordial thread to wakeup and raise a "scheduler
      ;; error" exception

      (##thread-report-scheduler-error! code))

    (let* ((run-queue
            (macro-run-queue))
           (current-thread
            (macro-current-thread))
           (run-queue-floats
            (macro-thread-floats run-queue))
           (current-thread-floats
            (macro-thread-floats current-thread))
           (quantum-used
            (##flonum.+ (macro-quantum-used current-thread-floats)
                        (macro-heartbeat-interval run-queue-floats))))

      (macro-quantum-used-set! current-thread-floats quantum-used)

      (if (##flonum.< quantum-used
                      (macro-quantum current-thread-floats))
        (macro-thread-reschedule-if-needed!)
        (##thread-yield!)))))

(define-prim (##thread-yield!)

  (##declare (not interrupts-enabled))

  (let* ((current-thread
          (macro-current-thread))
         (run-queue
          (macro-run-queue)))
    (if (##eq? (macro-btq-singleton? run-queue) current-thread)
      (begin
        ;; fast case where only one thread is runnable
        (macro-thread-unboost-and-clear-quantum-used! current-thread)
        (##void))
      (macro-thread-save!
       (lambda (current-thread)
         (##btq-remove! current-thread)
         (macro-thread-unboost-and-clear-quantum-used! current-thread)
         (macro-thread-result-set! current-thread ##thread-void-action!)
         (##btq-insert! (macro-run-queue) current-thread)
         (##thread-schedule!))))))

(define-prim (##thread-reschedule!)

  (##declare (not interrupts-enabled))

  (macro-thread-save!
   (lambda (current-thread)
     (macro-thread-result-set! current-thread ##thread-void-action!)
     (##thread-schedule!))))

(define-prim (##thread-sleep! absrel-timeout)

  (##declare (not interrupts-enabled))

  (let ((timeout (##absrel-timeout->timeout absrel-timeout)))
    (if timeout
      (let loop ()
        (let ((result
               (macro-thread-save!
                (lambda (current-thread timeout)
                  (##btq-remove! current-thread)
                  (macro-thread-unboost-and-clear-quantum-used!
                   current-thread)
                  (if (##not (##eq? timeout #t))
                    (begin
                      (macro-thread-timeout-set! current-thread timeout)
                      (##toq-insert! (macro-run-queue) current-thread)))
                  (##thread-schedule!))
                timeout)))
          (if (##eq? result (##void))
            (loop)
            (##void))))
      (##void))))

(define-prim (##thread-schedule!)

  (##declare (not interrupts-enabled))

  (let ((run-queue
         (macro-run-queue)))

    ;; check if there are runnable threads

    (let ((next-thread
           (macro-btq-leftmost run-queue)))
      (if (##not (##eq? next-thread run-queue))

        ;; there are runnable threads, so continue executing the next
        ;; runnable thread

        (macro-thread-restore!
         next-thread
         (macro-thread-result next-thread))

        ;; there are no runnable threads, so check if there are threads
        ;; waiting for a timeout or for a device to become ready

        (let ((next-sleeper
               (macro-toq-leftmost run-queue))
              (next-condvar
               (macro-btq-deq-next run-queue)))
          (if (or (##not (##eq? next-sleeper run-queue))
                  (##not (##eq? next-condvar run-queue)))

            ;; wait for the next timeout or for a device to become ready

            (let ((code
                   (##thread-check-devices!
                    (if (##eq? next-sleeper run-queue)
                      #t ;; timeout is infinite
                      (macro-thread-floats next-sleeper)))))

              ;; ##thread-check-devices! only returns after a device
              ;; becomes ready or the timeout is reached or an error is
              ;; detected

              (##thread-check-timeouts!)

              (cond ((##not (##fixnum.< code 0)) ;; no error?
                     #f)

                    ((##fixnum.= code ##err-code-EINTR)

                     ;; an interrupt may need to be serviced, so make
                     ;; sure at least one thread is runnable

                     (let ((next-thread
                            (macro-btq-leftmost run-queue)))
                       (if (##eq? next-thread run-queue)

                         ;; no thread is currently runnable, so wake up
                         ;; a thread that is sleeping or waiting on a
                         ;; device

                         (let ((next-sleeper
                                (macro-toq-leftmost run-queue)))
                           (if (##not (##eq? next-sleeper run-queue))

                             ;; a thread was sleeping so make it
                             ;; temporarily wake up so that it detects
                             ;; the interrupt (after the interrupt is
                             ;; processed the thread will resume
                             ;; sleeping)

                             (##thread-int!
                              next-sleeper
                              #f
                              ##thread-void-action!)

                             (let ((next-condvar
                                    (macro-btq-deq-next run-queue)))
                               (if (##not (##eq? next-condvar run-queue))

                                 ;; a thread is blocked on a device so
                                 ;; make it temporarily wake up so that
                                 ;; it detects the interrupt (after the
                                 ;; interrupt is processed the thread
                                 ;; will resume waiting)

                                 (##device-condvar-broadcast-no-reschedule!
                                  next-condvar)

                                 ;; no thread can possibly make further
                                 ;; progress, so let next call of
                                 ;; ##thread-schedule! detect and
                                 ;; handle the deadlock

                                 #f)))))))

                    (else

                     ;; there was an error that cannot be handled, so
                     ;; force the primordial thread to wakeup (it can't
                     ;; be currently runnable) and raise a "scheduler
                     ;; error" exception

                     (##thread-report-scheduler-error! code))))

            ;; no thread can possibly make further progress, so force
            ;; the primordial thread to wakeup (it can't be currently
            ;; runnable) and raise a "deadlock" exception

            (##thread-int!
             (macro-primordial-thread)
             #f
             ##thread-deadlock-action!))

          ;; check things one more time!

          (##thread-schedule!))))))

(define-prim (##thread-report-scheduler-error! code)

  (##declare (not interrupts-enabled))

  (##thread-int!
   (macro-primordial-thread)
   #f
   (lambda ()

     (macro-raise
      (macro-make-scheduler-exception
       (macro-make-os-exception #f #f #f code)))

     ;; return void so that primordial thread will continue
     ;; normally if exception handler returns

     (##void))))

(define-prim (##thread-interrupt!
              thread
              #!optional
              (action (macro-absent-obj)))
  (let ((act
         (if (##eq? action (macro-absent-obj))
             ##user-interrupt!
             action)))
    (##thread-int! thread action (lambda () (act) (##void)))))

(define-prim (##thread-int! thread action thunk-returning-void)

  ;; Note: the thunk-returning-void procedure must return void in
  ;; order to restart the interrupted thread properly.

  (##declare (not interrupts-enabled))

  (cond ((##eq? thread (macro-current-thread))
         (thunk-returning-void))

        ((or (##not (macro-initialized-thread? thread))
             (macro-terminated-thread-given-initialized? thread)
             (##not (macro-started-thread-given-initialized? thread)))
         (##raise-inactive-thread-exception thread-interrupt! thread action))

        (else

         ;; remove the thread from any blocked thread queue and
         ;; timeout queue it is in

         (macro-thread-btq-remove-if-in-btq! thread)
         (macro-thread-toq-remove-if-in-toq! thread)

         (macro-thread-result-set! thread thunk-returning-void)

         (##btq-insert! (macro-run-queue) thread)

         (##void))))

(define-prim (##thread-start-action!)

  (##declare (not interrupts-enabled))

  (let* ((current-thread
          (macro-current-thread))
         (thunk
          (macro-thread-exception? current-thread)))
    (macro-thread-exception?-set! current-thread #f)
    (let ((result (thunk)))
      (##thread-end! (macro-current-thread) #f result))))

(define-prim (##thread-void-action!)
  (##declare (not interrupts-enabled))
  (##void))

(define-prim (##thread-abandoned-mutex-action!)
  (##declare (not interrupts-enabled))
  (macro-raise (macro-make-constant-abandoned-mutex-exception)))

(define-prim (##thread-locked-mutex-action!)
  (##declare (not interrupts-enabled))
  #t)

(define-prim (##thread-signaled-condvar-action!)
  (##declare (not interrupts-enabled))
  #t)

(define-prim (##thread-timeout-action!)
  (##declare (not interrupts-enabled))
  #f)

(define-prim (##thread-deadlock-action!)

  (##declare (not interrupts-enabled))

  (macro-raise (macro-make-constant-deadlock-exception))

  ;; return void so that primordial thread will continue normally
  ;; if exception handler returns

  (##void))

(define-prim (##thread-suspend! thread)
  (##declare (not interrupts-enabled))
  (macro-not-yet-implemented));;;;;;;;;;;;;;;;

(define-prim (##thread-resume! thread)
  (##declare (not interrupts-enabled))
  (macro-not-yet-implemented));;;;;;;;;;;;;;

(define-prim (##thread-terminate! thread)
  (##declare (not interrupts-enabled))
  (##thread-end!
   thread
   'terminated-thread-exception
   #f))

(define-prim (##thread-end-with-uncaught-exception! exc)
  (##thread-end!
   (macro-current-thread)
   'uncaught-exception
   exc))

(define-prim (##primordial-exception-handler exc)
  (##declare (not interrupts-enabled))
  (let ((handler ##primordial-exception-handler-hook))
    (if (##procedure? handler)
      (handler exc ##thread-end-with-uncaught-exception!)
      (##thread-end-with-uncaught-exception! exc))))

(define primordial-exception-handler ##primordial-exception-handler)

(define ##primordial-exception-handler-hook #f)
(set! ##primordial-exception-handler-hook #f)

(define-prim (##thread-end! thread exception? result)

  (##declare (not interrupts-enabled))

  (if (##eq? thread (macro-primordial-thread))

    ;; termination of the primordial thread causes the program to terminate

    (if (##eq? exception? 'uncaught-exception)
      (##exit-with-exception result)
      (##exit))

    ;; perform thread termination only if thread is not already
    ;; terminated, or in the process of terminating

    (let ((end-condvar (macro-thread-end-condvar thread)))
      (if (##not end-condvar)
        (##void)
        (begin

          ;; the thread must abandon all the blocked thread queues
          ;; (i.e. mutexes, condvars, etc) it owns

          (let loop ()
            (let ((next-btq (macro-btq-deq-next thread)))
              (if (##not (##eq? next-btq thread))
                (begin
                  (##btq-abandon! next-btq)
                  (loop)))))

          (macro-thread-end-condvar-set! thread #f)
          (macro-thread-exception?-set! thread exception?)
          (macro-thread-result-set! thread result)
          (##condvar-signal-no-reschedule! end-condvar #t)
          (macro-thread-btq-remove-if-in-btq! thread)
          (macro-thread-toq-remove-if-in-toq! thread)
          (macro-tgroup-threads-deq-remove! thread)
          (macro-tgroup-threads-deq-init! thread)
          (macro-thread-cont-set! thread #t)
          (macro-thread-denv-set! thread #f)
          (macro-thread-denv-cache1-set! thread #f)
          (macro-thread-denv-cache2-set! thread #f)
          (macro-thread-denv-cache3-set! thread #f)
          (cond ((##eq? thread (macro-current-thread))
                 (##thread-schedule!))
                (else
                 (macro-thread-reschedule-if-needed!))))))))

(define-prim (##thread-join! thread absrel-timeout timeout-val)
  (##declare (not interrupts-enabled))
  (let ((joined-before-timeout?
         (let ((end-condvar (macro-thread-end-condvar thread)))
           (if end-condvar
             (let ((timeout
                    (##absrel-timeout->timeout
                     (if (##eq? absrel-timeout (macro-absent-obj))
                       #f
                       absrel-timeout))))
               (if timeout
                 (let loop ()
                   (let ((result
                          (macro-thread-save!
                           (lambda (current-thread thread timeout)
                             (let ((end-condvar
                                    (macro-thread-end-condvar thread)))

                               ;; do a final check of the state of
                               ;; the thread (this double check is
                               ;; necessary because a thread-switch
                               ;; may occur during the capturing of
                               ;; the continuation by
                               ;; macro-thread-save!)

                               (if end-condvar
                                 (begin
                                   (##btq-remove! current-thread)
                                   (macro-thread-boost-and-clear-quantum-used!
                                    current-thread)
                                   (##thread-btq-insert!
                                    end-condvar
                                    current-thread)
                                   (if (##not (##eq? timeout #t))
                                     (begin
                                       (macro-thread-timeout-set!
                                        current-thread
                                        timeout)
                                       (##toq-insert!
                                        (macro-run-queue)
                                        current-thread)))
                                   (##thread-schedule!))
                                 #t)))
                           thread
                           timeout)))
                     (if (##eq? result (##void))
                       (loop)
                       result)))
                 #f))
             #t))))

    (if joined-before-timeout?
      (case (macro-thread-exception? thread)
        ((uncaught-exception)
         (##raise-uncaught-exception
          (macro-thread-result thread)
          thread-join!
          thread
          absrel-timeout
          timeout-val))
        ((terminated-thread-exception)
         (##raise-terminated-thread-exception
          thread-join!
          thread
          absrel-timeout
          timeout-val))
        (else
         (macro-thread-result thread)))
      (if (##eq? timeout-val (macro-absent-obj))
        (##raise-join-timeout-exception
         thread-join!
         thread
         absrel-timeout
         timeout-val)
        timeout-val))))

(define-prim (##make-root-thread
              thunk
              name
              tgroup
              input-port
              output-port)

  (##declare (not interrupts-enabled))

  (let* ((interrupt-mask
          0)
         (debugging-settings
          0)
         (local-binding
          (##cons ##current-directory
                  (macro-parameter-descr-value
                   (macro-parameter-descr ##current-directory)))))

    ;; these macros are defined to prevent the normal thread
    ;; inheritance mechanism when a root thread is created

    (##define-macro (macro-current-thread)
      `#f)

    (##define-macro (macro-thread-denv thread)
      `#f)

    (##define-macro (macro-denv-local denv)
      `(macro-make-env local-binding '() '()))

    (##define-macro (macro-denv-dynwind denv)
      `##initial-dynwind)

    (##define-macro (macro-denv-interrupt-mask denv)
      `interrupt-mask)

    (##define-macro (macro-denv-debugging-settings denv)
      `debugging-settings)

    (##define-macro (macro-denv-input-port denv)
      `(##cons ##current-input-port input-port))

    (##define-macro (macro-denv-output-port denv)
      `(##cons ##current-output-port output-port))

    (##define-macro (macro-thread-denv-cache1 thread)
      `local-binding)

    (##define-macro (macro-thread-denv-cache2 thread)
      `local-binding)

    (##define-macro (macro-thread-denv-cache3 thread)
      `local-binding)

    (##define-macro (macro-thread-floats thread)
      `#f)

    (##define-macro (macro-base-priority floats)
      `(macro-thread-root-base-priority))

    (##define-macro (macro-quantum floats)
      `(macro-thread-root-quantum))

    (##define-macro (macro-priority-boost floats)
      `(macro-thread-root-priority-boost))

    ;; create root thread

    (macro-make-thread thunk name tgroup)))

(define-prim (make-root-thread
              thunk
              #!optional
              (n (macro-absent-obj))
              (tg (macro-absent-obj))
              (ip (macro-absent-obj))
              (op (macro-absent-obj)))
  (macro-force-vars (thunk n tg ip op)
    (let* ((name
            (if (##eq? n (macro-absent-obj))
              (##void)
              n))
           (tgroup
            (if (##eq? tg (macro-absent-obj))
              (macro-thread-tgroup (macro-current-thread))
              tg))
           (input-port
            (if (##eq? ip (macro-absent-obj))
              ##stdin-port
              ip))
           (output-port
            (if (##eq? op (macro-absent-obj))
              ##stdout-port
              op)))
      (macro-check-procedure thunk 1 (make-root-thread thunk n tg ip op)
        (macro-check-tgroup tgroup 3 (make-root-thread thunk n tg ip op)
          (macro-check-input-port input-port 4 (make-root-thread thunk n tg ip op)
            (macro-check-output-port output-port 5 (make-root-thread thunk n tg ip op)
              (##make-root-thread thunk name tgroup input-port output-port))))))))

(define-prim (##thread-startup!)

  (##declare (not interrupts-enabled))

  (let* ((primordial-tgroup
          (##make-tgroup 'primordial #f))
         (input-port
          (macro-parameter-descr-value
           (macro-parameter-descr ##current-input-port)))
         (output-port
          (macro-parameter-descr-value
           (macro-parameter-descr ##current-output-port)))
         (primordial-thread
          (##make-root-thread
           #f
           'primordial
           primordial-tgroup
           input-port
           output-port)))

    (##c-code
     "
     ___ps->current_thread = ___ARG1;
     ___ps->run_queue = ___ARG2;
     ___RESULT = ___FAL;
     "
     primordial-thread
     (macro-make-run-queue))

    (macro-run-queue-primordial-thread-set!
     (macro-run-queue)
     primordial-thread)

    (##btq-insert! (macro-run-queue) primordial-thread)

    (##interrupt-vector-set! 1 ##thread-heartbeat!)

    ;; These parameters are locally bound in all threads, so the value
    ;; field of the parameter descriptors are of no use and can be cleared.
    (macro-parameter-descr-value-set!
     (macro-parameter-descr ##current-exception-handler)
     #f)
    (macro-parameter-descr-value-set!
     (macro-parameter-descr ##current-input-port)
     #f)
    (macro-parameter-descr-value-set!
     (macro-parameter-descr ##current-output-port)
     #f)

    ;; assign serial number 1 to primordial thread
    (##object->serial-number primordial-thread)

    (##void)))

(define-prim (##thread-heartbeat-interval-set! seconds)
  (##declare (not interrupts-enabled))
  (let* ((actual-interval
          (##heartbeat-interval-set! seconds))
         (run-queue
          (macro-run-queue))
         (run-queue-floats
          (macro-thread-floats run-queue)))
    (macro-heartbeat-interval-set! run-queue-floats actual-interval)
    actual-interval))

;;;----------------------------------------------------------------------------

;;; Mailbox operations.

(define-prim (##thread-mailbox-get! thread)
  (##declare (not interrupts-enabled))
  (or (macro-thread-mailbox thread)
      (let ((mb (macro-make-mailbox)))
        (or (macro-thread-mailbox thread)
            (begin
              (macro-thread-mailbox-set! thread mb)
              mb)))))

(define-prim (##thread-mailbox-rewind)
  (##declare (not interrupts-enabled))
  (let ((mb (##thread-mailbox-get! (macro-current-thread))))
    (macro-mailbox-cursor-set! mb #f)
    (##void)))

(define-prim (thread-mailbox-rewind)
  (##thread-mailbox-rewind))

(define-prim (##thread-mailbox-extract-and-rewind)
  (##declare (not interrupts-enabled))
  (let* ((mb
          (##thread-mailbox-get! (macro-current-thread)))
         (cursor
          (macro-mailbox-cursor mb)))
    (if cursor
      (let* ((next (macro-fifo-next cursor))
             (next2 (macro-fifo-next next)))
        (macro-fifo-next-set! cursor next2)
        (if (##not (##pair? next2))
          (macro-fifo-tail-set! (macro-mailbox-fifo mb) cursor))
        (macro-mailbox-cursor-set! mb #f)))
    (##void)))

(define-prim (thread-mailbox-extract-and-rewind)
  (##thread-mailbox-extract-and-rewind))

(define-prim (##thread-mailbox-next-or-receive
              extract-and-rewind?
              prim
              absrel-timeout
              timeout-val)
  (##declare (not interrupts-enabled))
  (let* ((mb
          (##thread-mailbox-get! (macro-current-thread)))
         (cursor
          (macro-mailbox-cursor mb))
         (next
          (if cursor
            (macro-fifo-next cursor)
            (macro-mailbox-fifo mb)))
         (next2
          (macro-fifo-next next)))
    (if (##pair? next2)
      (let ((result (macro-fifo-elem next2)))
        (if extract-and-rewind?
          (let ((next3 (macro-fifo-next next2)))
            (macro-fifo-next-set! next next3)
            (if (##not (##pair? next3))
              (macro-fifo-tail-set! (macro-mailbox-fifo mb) next))
            (macro-mailbox-cursor-set! mb #f))
          (macro-mailbox-cursor-set! mb next))
        result)
      (let ((timeout
             (##absrel-timeout->timeout
              (if (##eq? absrel-timeout (macro-absent-obj))
                #f
                absrel-timeout))))
        (let loop ()
          (let* ((mb
                  (##thread-mailbox-get! (macro-current-thread)))
                 (mutex
                  (macro-mailbox-mutex mb)))
            (macro-mutex-lock! mutex #f (macro-current-thread))
            (let* ((cursor
                    (macro-mailbox-cursor mb))
                   (next
                    (if cursor
                      (macro-fifo-next cursor)
                      (macro-mailbox-fifo mb)))
                   (next2
                    (macro-fifo-next next)))
              (if (##pair? next2)
                (let ((result (macro-fifo-elem next2)))
                  (if extract-and-rewind?
                    (let ((next3 (macro-fifo-next next2)))
                      (macro-fifo-next-set! next next3)
                      (if (##not (##pair? next3))
                        (macro-fifo-tail-set! (macro-mailbox-fifo mb) next))
                      (macro-mailbox-cursor-set! mb #f))
                    (macro-mailbox-cursor-set! mb next))
                  (macro-mutex-unlock! mutex)
                  result)
                (if (##mutex-signal-and-condvar-wait!
                     mutex
                     (macro-mailbox-condvar mb)
                     timeout)
                  (loop)
                  (if (##eq? timeout-val (macro-absent-obj))
                    (##raise-mailbox-receive-timeout-exception
                     prim
                     absrel-timeout
                     timeout-val)
                    timeout-val))))))))))

(define-prim (thread-mailbox-next
              #!optional
              (absrel-timeout (macro-absent-obj))
              (timeout-val (macro-absent-obj)))
  (macro-force-vars (absrel-timeout)
    (if (or (##eq? absrel-timeout (macro-absent-obj))
            (macro-absrel-time-or-false? absrel-timeout))
      (##thread-mailbox-next-or-receive
       #f
       thread-mailbox-next
       absrel-timeout
       timeout-val)
      (##fail-check-absrel-time-or-false
       1
       thread-mailbox-next
       absrel-timeout
       timeout-val))))

(define-prim (thread-receive
              #!optional
              (absrel-timeout (macro-absent-obj))
              (timeout-val (macro-absent-obj)))
  (macro-force-vars (absrel-timeout)
    (if (or (##eq? absrel-timeout (macro-absent-obj))
            (macro-absrel-time-or-false? absrel-timeout))
      (##thread-mailbox-next-or-receive
       #t
       thread-receive
       absrel-timeout
       timeout-val)
      (##fail-check-absrel-time-or-false
       1
       thread-receive
       absrel-timeout
       timeout-val))))

(define-prim (##thread-send thread obj)
  (##declare (not interrupts-enabled))
  (let* ((mb
          (##thread-mailbox-get! thread))
         (mutex
          (macro-mailbox-mutex mb)))
    (macro-mutex-lock! mutex #f (macro-current-thread))
    (macro-fifo-insert-at-tail! (macro-mailbox-fifo mb) obj)
    (macro-mutex-unlock! mutex)
    (##condvar-signal! (macro-mailbox-condvar mb) #f)
    (##void)))

(define-prim (thread-send thread obj)
  (macro-force-vars (thread)
    (macro-check-thread thread 1 (thread-send thread obj)
      (macro-check-initialized-thread thread (thread-send thread obj)
        (##thread-send thread obj)))))

;;;----------------------------------------------------------------------------

;;; Implementation of mutexes.

(define-prim (##make-mutex name)
  (##declare (not interrupts-enabled))
  (macro-make-mutex name))

(define-prim (##mutex-lock-out-of-line! mutex absrel-timeout new-owner)
  (##declare (not interrupts-enabled))
  (let ((owner (macro-btq-owner mutex)))
    (if (##eq? owner 'abandoned)
      (begin
        (if new-owner
          (if (macro-thread-end-condvar new-owner)
            (macro-btq-link! mutex new-owner))
          (macro-btq-owner-set! mutex 'not-owned))
        (##thread-abandoned-mutex-action!))
      (let ((timeout (##absrel-timeout->timeout absrel-timeout)))
        (if timeout
          (let loop ()
            (let ((result
                   (macro-thread-save!
                    (lambda (current-thread mutex timeout new-owner)
                      (let ((owner (macro-btq-owner mutex)))

                        ;; do a final check of the state of the
                        ;; mutex and suspend if can't lock the
                        ;; mutex (this double check is necessary
                        ;; because a thread-switch may occur during
                        ;; the capturing of the continuation by
                        ;; macro-thread-save!)

                        (cond ((##not owner)
                               (if new-owner
                                 (if (macro-thread-end-condvar new-owner)
                                   (macro-btq-link! mutex new-owner)
                                   (macro-btq-owner-set! mutex 'abandoned))
                                 (macro-btq-owner-set! mutex 'not-owned))
                               #t)
                              ((##eq? owner 'abandoned)
                               (if new-owner
                                 (if (macro-thread-end-condvar new-owner)
                                   (macro-btq-link! mutex new-owner))
                                 (macro-btq-owner-set! mutex 'not-owned))
                               (##thread-abandoned-mutex-action!))
                              (else
                               (##btq-remove! current-thread)
                               (macro-thread-boost-and-clear-quantum-used!
                                current-thread)
                               (macro-thread-result-set!
                                current-thread
                                new-owner)
                               (##thread-btq-insert! mutex current-thread)
                               (if (##not (##eq? timeout #t))
                                 (begin
                                   (macro-thread-timeout-set!
                                    current-thread
                                    timeout)
                                   (##toq-insert!
                                    (macro-run-queue)
                                    current-thread)))
                               (##thread-schedule!)))))
                    mutex
                    timeout
                    new-owner)))
              (if (##eq? result (##void))
                (loop)
                result)))
          #f)))))

(define-prim (##mutex-signal! mutex thread abandoned?)

  (##declare (not interrupts-enabled))

  (##mutex-signal-no-reschedule! mutex thread abandoned?)

  ;; check if the call to ##mutex-signal-no-reschedule! caused a
  ;; higher priority thread to become runnable

  (macro-thread-reschedule-if-needed!))

(define-prim (##mutex-signal-no-reschedule! mutex thread abandoned?)

  (##declare (not interrupts-enabled))

  (##thread-btq-remove! thread)

  (let ((new-owner (macro-thread-result thread)))
    (if new-owner
      (if (macro-thread-end-condvar new-owner)
        (begin
          (macro-btq-link! mutex new-owner)
          (let ((new-leftmost (macro-btq-leftmost mutex)))
            (if (##not (##eq? new-leftmost mutex))
              (macro-thread-inherit-priority! new-owner new-leftmost))))
        (macro-btq-unlink! mutex 'abandoned))
      (macro-btq-unlink! mutex 'not-owned)))

  (macro-thread-result-set!
   thread
   (if abandoned?
     ##thread-abandoned-mutex-action!
     ##thread-locked-mutex-action!))

  (macro-thread-toq-remove-if-in-toq! thread)

  (##btq-insert! (macro-run-queue) thread))

(define-prim (##mutex-signal-and-condvar-wait! mutex condvar timeout)

  (##declare (not interrupts-enabled))

  (if timeout
    (let ((result
           (macro-thread-save!
            (lambda (current-thread mutex condvar timeout)
              (##btq-remove! current-thread)
              (macro-thread-boost-and-clear-quantum-used!
               current-thread)
              (##thread-btq-insert! condvar current-thread)
              (if (##not (##eq? timeout #t))
                (begin
                  (macro-thread-timeout-set!
                   current-thread
                   timeout)
                  (##toq-insert!
                   (macro-run-queue)
                   current-thread)))
              (macro-mutex-unlock-no-reschedule! mutex)
              (##thread-schedule!))
            mutex
            condvar
            timeout)))
      (if (##eq? result (##void))
        #t ;; abort wait when interrupted
        result))
    (begin
      (macro-mutex-unlock-no-reschedule! mutex)
      (macro-thread-reschedule-if-needed!)
      #f)))

(define-prim (##wait-for-io! condvar timeout)
  (##declare (not interrupts-enabled))
  (if timeout
    (let ((result
           (macro-thread-save!
            (lambda (current-thread condvar timeout)
              (##btq-remove! current-thread)
              (macro-thread-boost-and-clear-quantum-used!
               current-thread)
              (##thread-btq-insert! condvar current-thread)
              (if (##not (##eq? timeout #t))
                (begin
                  (macro-thread-timeout-set!
                   current-thread
                   timeout)
                  (##toq-insert!
                   (macro-run-queue)
                   current-thread)))
              (macro-btq-deq-remove! condvar)
              (macro-btq-deq-insert! (macro-run-queue) condvar)
              (##thread-schedule!))
            condvar
            timeout)))
      (if (##eq? result (##void))
        #t ;; abort wait when interrupted
        result))
    (begin
      (macro-thread-reschedule-if-needed!)
      #f)))

(define-prim (##device-condvar-broadcast-no-reschedule! condvar)
  (##declare (not interrupts-enabled))
  (macro-btq-deq-remove! condvar)
  (macro-btq-deq-init! condvar)
  (##condvar-signal-no-reschedule! condvar #t))

;;;----------------------------------------------------------------------------

;;; Implementation of condition variables.

(define-prim (##make-condvar name)
  (##declare (not interrupts-enabled))
  (macro-make-condvar name))

(define-prim (##condvar-signal! condvar broadcast?)
  (##declare (not interrupts-enabled))
  (##condvar-signal-no-reschedule! condvar broadcast?)
  (macro-thread-reschedule-if-needed!))

(define-prim (##condvar-signal-no-reschedule! condvar broadcast?)
  (##declare (not interrupts-enabled))
  (let loop ()
    (let ((leftmost (macro-btq-leftmost condvar)))
      (if (##not (##eq? leftmost condvar))
        (begin
          (macro-thread-result-set!
           leftmost
           ##thread-signaled-condvar-action!)
          (##thread-btq-remove! leftmost)
          (macro-thread-toq-remove-if-in-toq! leftmost)
          (##btq-insert! (macro-run-queue) leftmost)
;;;;;;(set! pcase14 (##cons leftmost pcase14));;;;;;;;;;;;;;;;;;;;;;;
          (if broadcast?
            (loop)
            (##void)))
        (##void)))))

;;;----------------------------------------------------------------------------

;;; Implementation of thread groups.

(define-prim (##make-tgroup name parent)
  (##declare (not interrupts-enabled))
  (macro-make-tgroup name parent))

(define-prim (##tgroup-suspend! tgroup)
  (##declare (not interrupts-enabled))
  (macro-not-yet-implemented))

(define-prim (##tgroup-resume! tgroup)
  (##declare (not interrupts-enabled))
  (macro-not-yet-implemented))

(define-prim (##tgroup-terminate! tgroup)
  (##declare (not interrupts-enabled))
  (macro-not-yet-implemented))

(define-prim (##tgroup->tgroup-vector tgroup)
  (##declare (not interrupts-enabled))
  (let ((deq (macro-tgroup-tgroups tgroup)))
    (let loop1 ((probe deq) (n 0))
      (let ((next (macro-tgroup-tgroups-deq-next probe)))
        (if (##not (##eq? next deq))
            (loop1 next (##fixnum.+ n 1))
            (let ((v (##make-vector n)))
              (let loop2 ((probe deq) (i 0))
                (let ((next (macro-tgroup-tgroups-deq-next probe)))
                  (if (##not (##eq? next deq))
                      (if (##fixnum.= i n) ;; more elements this time around?
                          (loop1 next (##fixnum.+ i 1))
                          (begin
                            (##vector-set! v i next)
                            (loop2 next (##fixnum.+ i 1))))
                      (begin
                        (##vector-shrink! v i) ;; there may be fewer elements!
                        v))))))))))

(define-prim (##tgroup->tgroup-list tgroup)
  (##declare (not interrupts-enabled))
  (##vector->list (##tgroup->tgroup-vector tgroup)))

(define-prim (##tgroup->thread-vector tgroup)
  (##declare (not interrupts-enabled))
  (let ((deq tgroup))
    (let loop1 ((probe deq) (n 0))
      (let ((next (macro-tgroup-threads-deq-next probe)))
        (if (##not (##eq? next deq))
            (loop1 next (##fixnum.+ n 1))
            (let ((v (##make-vector n)))
              (let loop2 ((probe deq) (i 0))
                (let ((next (macro-tgroup-threads-deq-next probe)))
                  (if (##not (##eq? next deq))
                      (if (##fixnum.= i n) ;; more elements this time around?
                          (loop1 next (##fixnum.+ i 1))
                          (begin
                            (##vector-set! v i next)
                            (loop2 next (##fixnum.+ i 1))))
                      (begin
                        (##vector-shrink! v i) ;; there may be fewer elements!
                        v))))))))))

(define-prim (##tgroup->thread-list tgroup)
  (##declare (not interrupts-enabled))
  (##vector->list (##tgroup->thread-vector tgroup)))

;;;----------------------------------------------------------------------------

;;; User accessible primitives for time objects.

(define-prim (##current-time-point)
  (macro-update-current-time!)
  (macro-current-time (macro-thread-floats (macro-run-queue))))

(define-prim (current-time)
  (macro-make-time (##current-time-point) #f #f #f))

(define-prim (time? obj)
  (macro-time? obj))

(define-prim (time->seconds t)
  (macro-force-vars (t)
    (macro-check-time t 1 (time->seconds t)
      (macro-time-point t))))

(define-prim (seconds->time s)
  (macro-force-vars (s)
    (macro-check-real s 1 (seconds->time s)
      (macro-make-time (macro-real->inexact s) #f #f #f))))

(define-prim (timeout->time absrel-timeout)
  (macro-force-vars (absrel-timeout)
    (##timeout->time absrel-timeout)))

;;;----------------------------------------------------------------------------

;;; User accessible primitives for threads.

(define-prim (current-thread)
  (macro-current-thread))

(define-prim (thread? obj)
  (macro-force-vars (obj)
    (macro-thread? obj)))

(define-prim (make-thread
              thunk
              #!optional
              (n (macro-absent-obj))
              (tg (macro-absent-obj)))
  (macro-force-vars (thunk n tg)
    (let* ((name
            (if (##eq? n (macro-absent-obj))
              (##void)
              n))
           (tgroup
            (if (##eq? tg (macro-absent-obj))
              (macro-thread-tgroup (macro-current-thread))
              tg)))
      (macro-check-procedure thunk 1 (make-thread thunk n tg)
        (macro-check-tgroup tgroup 3 (make-thread thunk n tg)
          (macro-make-thread thunk name tgroup))))))

(define-prim (thread-init!
              thread
              thunk
              #!optional
              (n (macro-absent-obj))
              (tg (macro-absent-obj)))
  (macro-force-vars (thread thunk n tg)
    (let* ((name
            (if (##eq? n (macro-absent-obj))
              (##void)
              n))
           (tgroup
            (if (##eq? tg (macro-absent-obj))
              (macro-thread-tgroup (macro-current-thread))
              tg)))
      (macro-check-thread thread 1 (thread-init! thread thunk n tg)
        (macro-check-procedure thunk 2 (thread-init! thread thunk n tg)
          (macro-check-tgroup tgroup 4 (thread-init! thread thunk n tg)
            (macro-check-not-initialized-thread
             thread
             (thread-init! thread thunk n tg)
             (macro-thread-init! thread thunk name tgroup))))))))

(define-prim (thread-name thread)
  (macro-force-vars (thread)
    (macro-check-thread thread 1 (thread-name thread)
      (macro-check-initialized-thread thread (thread-name thread)
        (macro-thread-name thread)))))

(define-prim (thread-thread-group thread)
  (macro-force-vars (thread)
    (macro-check-thread thread 1 (thread-thread-group thread)
      (macro-check-initialized-thread thread (thread-thread-group thread)
        (macro-thread-tgroup thread)))))

(define-prim (thread-specific thread)
  (macro-force-vars (thread)
    (macro-check-thread thread 1 (thread-specific thread)
      (macro-check-initialized-thread thread (thread-specific thread)
        (macro-thread-specific thread)))))

(define-prim (thread-specific-set! thread obj)
  (macro-force-vars (thread)
    (macro-check-thread thread 1 (thread-specific-set! thread obj)
      (macro-check-initialized-thread thread (thread-specific-set! thread obj)
        (begin
          (macro-thread-specific-set! thread obj)
          (##void))))))

(define-prim (thread-base-priority thread)
  (macro-force-vars (thread)
    (macro-check-thread thread 1 (thread-base-priority thread)
      (macro-check-initialized-thread thread (thread-base-priority thread)
        (macro-thread-base-priority thread)))))

(define-prim (thread-base-priority-set! thread base-priority)
  (macro-force-vars (thread base-priority)
    (macro-check-thread
     thread
     1
     (thread-base-priority-set! thread base-priority)
     (macro-check-real
      base-priority
      2
      (thread-base-priority-set! thread base-priority)
      (macro-check-initialized-thread
       thread
       (thread-base-priority-set! thread base-priority)
       (##thread-base-priority-set!
        thread
        (macro-real->inexact base-priority)))))))

(define-prim (thread-quantum thread)
  (macro-force-vars (thread)
    (macro-check-thread thread 1 (thread-quantum thread)
      (macro-check-initialized-thread thread (thread-quantum thread)
        (macro-thread-quantum thread)))))

(define-prim (thread-quantum-set! thread quantum)
  (macro-force-vars (thread quantum)
    (macro-check-thread thread 1 (thread-quantum-set! thread quantum)
      (macro-check-real
       quantum
       2
       (thread-quantum-set! thread quantum)
       (let ((q (macro-real->inexact quantum)))
         (if (##flonum.negative? q)
           (##raise-range-exception 2 thread-quantum-set! thread quantum)
           (macro-check-initialized-thread
            thread
            (thread-quantum-set! thread quantum)
            (##thread-quantum-set! thread q))))))))

(define-prim (thread-priority-boost thread)
  (macro-force-vars (thread)
    (macro-check-thread thread 1 (thread-priority-boost thread)
      (macro-check-initialized-thread thread (thread-priority-boost thread)
        (macro-thread-priority-boost thread)))))

(define-prim (thread-priority-boost-set! thread priority-boost)
  (macro-force-vars (thread priority-boost)
    (macro-check-thread
     thread
     1
     (thread-priority-boost-set! thread priority-boost)
     (macro-check-real
      priority-boost
      2
      (thread-priority-boost-set! thread priority-boost)
      (let ((b (macro-real->inexact priority-boost)))
        (if (##flonum.negative? b)
          (##raise-range-exception 2
                                   thread-priority-boost-set!
                                   thread
                                   priority-boost)
          (macro-check-initialized-thread
           thread
           (thread-priority-boost-set! thread priority-boost)
           (##thread-priority-boost-set! thread b))))))))

(define-prim (thread-start! thread)
  (macro-force-vars (thread)
    (macro-check-thread thread 1 (thread-start! thread)
      (macro-check-initialized-thread thread (thread-start! thread)
        (macro-check-not-started-thread-given-initialized
         thread
         (thread-start! thread)
         (##thread-start! thread))))))

(define-prim (thread-yield!)
  (##thread-yield!))

(define-prim (thread-sleep! absrel-timeout)
  (macro-force-vars (absrel-timeout)
    (macro-check-absrel-time
     absrel-timeout
     1
     (thread-sleep! absrel-timeout)
     (##thread-sleep! absrel-timeout))))

(define-prim (thread-suspend! thread)
  (macro-force-vars (thread)
    (macro-check-thread thread 1 (thread-suspend! thread)
      (macro-check-initialized-thread thread (thread-suspend! thread)
        (##thread-suspend! thread)))))

(define-prim (thread-resume! thread)
  (macro-force-vars (thread)
    (macro-check-thread thread 1 (thread-resume! thread)
      (macro-check-initialized-thread thread (thread-resume! thread)
        (##thread-resume! thread)))))

(define-prim (thread-terminate! thread)
  (macro-force-vars (thread)
    (macro-check-thread thread 1 (thread-terminate! thread)
      (macro-check-initialized-thread thread (thread-terminate! thread)
        (##thread-terminate! thread)))))

(define-prim (thread-join!
              thread
              #!optional
              (absrel-timeout (macro-absent-obj))
              (timeout-val (macro-absent-obj)))
  (macro-force-vars (thread absrel-timeout)
    (macro-check-thread
     thread
     1
     (thread-join! thread absrel-timeout timeout-val)
     (if (or (##eq? absrel-timeout (macro-absent-obj))
             (macro-absrel-time-or-false? absrel-timeout))
       (macro-check-initialized-thread
        thread
        (thread-join! thread absrel-timeout timeout-val)
        (##thread-join! thread absrel-timeout timeout-val))
       (##fail-check-absrel-time-or-false
        2
        thread-join!
        thread
        absrel-timeout
        timeout-val)))))

(define-prim (thread-interrupt!
              thread
              #!optional
              (thunk (macro-absent-obj)))
  (macro-force-vars (thread thunk)
    (macro-check-thread thread 1 (thread-interrupt! thread thunk)
      (if (##eq? thunk (macro-absent-obj))
          (##thread-interrupt! thread)
          (macro-check-procedure thunk 2 (thread-interrupt! thread thunk)
            (##thread-interrupt! thread thunk))))))

(define-prim (thread-state thread)
  (macro-force-vars (thread)
    (macro-check-thread thread 1 (thread-state thread)
      (##thread-state thread))))

(define-prim (##thread-state thread)
  (##declare (not interrupts-enabled))
  (cond ((##not (macro-initialized-thread? thread))
         (macro-make-constant-thread-state-uninitialized))
        ((macro-terminated-thread-given-initialized? thread)
         (if (macro-thread-exception? thread)
             (macro-make-thread-state-abnormally-terminated
              (macro-thread-result thread))
             (macro-make-thread-state-normally-terminated
              (macro-thread-result thread))))
        ((##not (macro-started-thread-given-initialized? thread))
         (macro-make-constant-thread-state-initialized))
        (else
         (let* ((btq
                 (macro-thread->btq thread))
                (toq
                 (macro-thread->toq thread))
                (timeout
                 (and toq
                      (let* ((floats (macro-thread-floats thread))
                             (timeout (macro-timeout floats)))
                        (macro-make-time timeout #f #f #f)))))
           (macro-make-thread-state-active
            (cond ((##eq? btq (macro-run-queue))
                   #f)
                  ((and (macro-condvar? btq)
                        (##io-condvar? btq))
                   (##io-condvar-port btq))
                  (else
                   btq))
            timeout)))))

;;; User accessible primitives for mutexes.

(define-prim (mutex? obj)
  (macro-force-vars (obj)
    (macro-mutex? obj)))

(define-prim (make-mutex #!optional (n (macro-absent-obj)))
  (macro-force-vars (n)
    (let ((name
           (if (##eq? n (macro-absent-obj))
             (##void)
             n)))
      (macro-make-mutex name))))

(define-prim (mutex-name mutex)
  (macro-force-vars (mutex)
    (macro-check-mutex mutex 1 (mutex-name mutex)
      (macro-mutex-name mutex))))

(define-prim (mutex-specific mutex)
  (macro-force-vars (mutex)
    (macro-check-mutex mutex 1 (mutex-specific mutex)
      (macro-mutex-specific mutex))))

(define-prim (mutex-specific-set! mutex obj)
  (macro-force-vars (mutex)
    (macro-check-mutex mutex 1 (mutex-specific-set! mutex obj)
      (begin
        (macro-mutex-specific-set! mutex obj)
        (##void)))))

(define-prim (mutex-state mutex)
  (macro-force-vars (mutex)
    (macro-check-mutex mutex 1 (mutex-state mutex)
      (or (macro-btq-owner mutex)
          'not-abandoned))))

(define-prim (mutex-lock!
              mutex
              #!optional
              (absrel-timeout (macro-absent-obj))
              (thread (macro-absent-obj)))
  (macro-force-vars (mutex absrel-timeout thread)
    (macro-check-mutex mutex 1 (mutex-lock! mutex absrel-timeout thread)
      (cond ((##eq? absrel-timeout (macro-absent-obj))
             (macro-mutex-lock! mutex #f (macro-current-thread)))
            ((##not absrel-timeout)
             (cond ((##eq? thread (macro-absent-obj))
                    (macro-mutex-lock! mutex #f (macro-current-thread)))
                   ((##not thread)
                    (macro-mutex-lock-anonymously! mutex absrel-timeout))
                   (else
                    (macro-check-thread
                     thread
                     1
                     (mutex-lock! mutex absrel-timeout thread)
                     (macro-check-initialized-thread
                      thread
                      (mutex-lock! mutex absrel-timeout thread)
                      (macro-mutex-lock! mutex absrel-timeout thread))))))
            ((macro-absrel-time? absrel-timeout)
             (cond ((##eq? thread (macro-absent-obj))
                    (macro-mutex-lock!
                     mutex
                     absrel-timeout
                     (macro-current-thread)))
                   ((##not thread)
                    (macro-mutex-lock-anonymously!
                     mutex
                     absrel-timeout))
                   (else
                    (macro-check-thread
                     thread
                     3
                     (mutex-lock! mutex absrel-timeout thread)
                     (macro-check-initialized-thread
                      thread
                      (mutex-lock! mutex absrel-timeout thread)
                      (macro-mutex-lock!
                       mutex
                       absrel-timeout
                       thread))))))
            (else
             (##fail-check-absrel-time-or-false
              2
              mutex-lock!
              mutex
              absrel-timeout
              thread))))))

(define-prim (mutex-unlock!
              mutex
              #!optional
              (condvar (macro-absent-obj))
              (absrel-timeout (macro-absent-obj)))
  (macro-force-vars (mutex condvar absrel-timeout)
    (macro-check-mutex
     mutex
     1
     (mutex-unlock! mutex condvar absrel-timeout)
     (if (##eq? condvar (macro-absent-obj))
       (macro-mutex-unlock! mutex)
       (macro-check-condvar
        condvar
        2
        (mutex-unlock! mutex condvar absrel-timeout)
        (cond ((or (##eq? absrel-timeout (macro-absent-obj))
                   (##not absrel-timeout))
               (##mutex-signal-and-condvar-wait! mutex condvar #t))
              ((macro-absrel-time? absrel-timeout)
               (let ((timeout (##absrel-timeout->timeout absrel-timeout)))
                 (##mutex-signal-and-condvar-wait!
                  mutex
                  condvar
                  timeout)))
              (else
               (##fail-check-absrel-time-or-false
                3
                mutex-unlock!
                mutex
                condvar
                absrel-timeout))))))))

;;; User accessible primitives for condition variables

(define-prim (condition-variable? obj)
  (macro-force-vars (obj)
    (macro-condvar? obj)))

(define-prim (make-condition-variable #!optional (n (macro-absent-obj)))
  (macro-force-vars (n)
    (let ((name
           (if (##eq? n (macro-absent-obj))
             (##void)
             n)))
      (macro-make-condvar name))))

(define-prim (condition-variable-name condvar)
  (macro-force-vars (condvar)
    (macro-check-condvar condvar 1 (condition-variable-name condvar)
      (macro-condvar-name condvar))))

(define-prim (condition-variable-specific condvar)
  (macro-force-vars (condvar)
    (macro-check-condvar condvar 1 (condition-variable-specific condvar)
      (macro-condvar-specific condvar))))

(define-prim (condition-variable-specific-set! condvar obj)
  (macro-force-vars (condvar)
    (macro-check-condvar condvar 1 (condition-variable-specific-set! condvar obj)
      (begin
        (macro-condvar-specific-set! condvar obj)
        (##void)))))

(define-prim (condition-variable-signal! condvar)
  (macro-force-vars (condvar)
    (macro-check-condvar condvar 1 (condition-variable-signal! condvar)
      (##condvar-signal! condvar #f))))

(define-prim (condition-variable-broadcast! condvar)
  (macro-force-vars (condvar)
    (macro-check-condvar condvar 1 (condition-variable-broadcast! condvar)
      (##condvar-signal! condvar #t))))

;;; User accessible primitives for thread groups.

(define-prim (thread-group? obj)
  (macro-force-vars (obj)
    (macro-tgroup? obj)))

(define-prim (make-thread-group
              #!optional
              (n (macro-absent-obj))
              (p (macro-absent-obj)))
  (macro-force-vars (n p)
    (let ((name
           (if (##eq? n (macro-absent-obj))
             (##void)
             n)))
      (cond ((##eq? p (macro-absent-obj))
             (##make-tgroup
              name
              (macro-thread-tgroup (macro-current-thread))))
            (p
             (macro-check-tgroup p 2 (make-thread-group n p)
               (##make-tgroup name p)))
            (else
             (##make-tgroup name #f))))))

(define-prim (thread-group-name tgroup)
  (macro-force-vars (tgroup)
    (macro-check-tgroup tgroup 1 (thread-group-name tgroup)
      (macro-tgroup-name tgroup))))

(define-prim (thread-group-parent tgroup)
  (macro-force-vars (tgroup)
    (macro-check-tgroup tgroup 1 (thread-group-parent tgroup)
      (macro-tgroup-parent tgroup))))

(define-prim (thread-group-suspend! tgroup)
  (macro-force-vars (tgroup)
    (macro-check-tgroup tgroup 1 (thread-group-suspend! tgroup)
      (##tgroup-suspend! tgroup))))

(define-prim (thread-group-resume! tgroup)
  (macro-force-vars (tgroup)
    (macro-check-tgroup tgroup 1 (thread-group-resume! tgroup)
      (##tgroup-resume! tgroup))))

(define-prim (thread-group-terminate! tgroup)
  (macro-force-vars (tgroup)
    (macro-check-tgroup tgroup 1 (thread-group-terminate! tgroup)
      (##tgroup-terminate! tgroup))))

(define-prim (thread-group->thread-group-vector tgroup)
  (macro-force-vars (tgroup)
    (macro-check-tgroup tgroup 1 (thread-group->thread-group-vector tgroup)
      (##tgroup->tgroup-vector tgroup))))

(define-prim (thread-group->thread-group-list tgroup)
  (macro-force-vars (tgroup)
    (macro-check-tgroup tgroup 1 (thread-group->thread-group-list tgroup)
      (##tgroup->tgroup-list tgroup))))

(define-prim (thread-group->thread-vector tgroup)
  (macro-force-vars (tgroup)
    (macro-check-tgroup tgroup 1 (thread-group->thread-vector tgroup)
      (##tgroup->thread-vector tgroup))))

(define-prim (thread-group->thread-list tgroup)
  (macro-force-vars (tgroup)
    (macro-check-tgroup tgroup 1 (thread-group->thread-list tgroup)
      (##tgroup->thread-list tgroup))))

;;;----------------------------------------------------------------------------

;;; User accessible primitives for exception handling.

(define-prim (with-exception-handler handler thunk)
  (macro-force-vars (handler thunk)
    (macro-check-procedure handler 1 (with-exception-handler handler thunk)
      (macro-check-procedure thunk 2 (with-exception-handler handler thunk)
        (macro-dynamic-bind exception-handler
         handler
         thunk)))))

(define-prim (##with-exception-catcher catcher thunk)
  (##continuation-capture
   (lambda (cont)
     (macro-dynamic-bind exception-handler
      (lambda (exc)
        (##continuation-graft cont catcher exc))
      thunk))))

(define-prim (with-exception-catcher catcher thunk)
  (macro-force-vars (catcher thunk)
    (macro-check-procedure catcher 1 (with-exception-catcher catcher thunk)
      (macro-check-procedure thunk 2 (with-exception-catcher catcher thunk)
        (##with-exception-catcher catcher thunk)))))

(define-prim (##raise obj);;;;;;;;;;;;;;;;;;
  (macro-raise obj))

(define-prim (raise obj)
  (macro-raise obj))

(define-prim (##abort obj);;;;;;;;;;;;;;;;;;;;;;;;;;
  (macro-abort obj))

(define-prim (abort obj)
  (macro-abort obj))

;;;----------------------------------------------------------------------------

(define-prim (##call-with-current-continuation
              receiver
              #!optional
              (lift1 (macro-absent-obj))
              (lift2 (macro-absent-obj))
              (lift3 (macro-absent-obj))
              #!rest
              others)

  (define (reify-continuation cont)
    (lambda (#!optional
             (val1 (macro-absent-obj))
             (val2 (macro-absent-obj))
             (val3 (macro-absent-obj))
             #!rest
             others)
      (##continuation-return-aux cont val1 val2 val3 others)))

  (cond ((##eq? lift1 (macro-absent-obj))
         (##continuation-capture
          (lambda (cont)
            (receiver (reify-continuation cont)))))
        ((##eq? lift2 (macro-absent-obj))
         (##continuation-capture
          (lambda (cont lift1)
            (receiver (reify-continuation cont) lift1))
          lift1))
        ((##eq? lift3 (macro-absent-obj))
         (##continuation-capture
          (lambda (cont lift1 lift2)
            (receiver (reify-continuation cont) lift1 lift2))
          lift1
          lift2))
        ((##null? others)
         (##continuation-capture
          (lambda (cont lift1 lift2 lift3)
            (receiver (reify-continuation cont) lift1 lift2 lift3))
          lift1
          lift2
          lift3))
        (else
         (let ((lifts
                (##cons lift1
                        (##cons lift2
                                (##cons lift3
                                        others)))))
           (##continuation-capture
            (lambda (cont)
              (##apply
               receiver
               (##cons (reify-continuation cont) lifts))))))))

(define-prim (call-with-current-continuation
              receiver
              #!optional
              (lift1 (macro-absent-obj))
              (lift2 (macro-absent-obj))
              (lift3 (macro-absent-obj))
              #!rest
              others)
  (macro-force-vars (receiver)
    (macro-check-procedure
     receiver
     1
     (call-with-current-continuation receiver lift1 lift2 lift3 . others)
     (cond ((##eq? lift1 (macro-absent-obj))
            (##call-with-current-continuation receiver))
           ((##eq? lift2 (macro-absent-obj))
            (##call-with-current-continuation receiver lift1))
           ((##eq? lift3 (macro-absent-obj))
            (##call-with-current-continuation receiver lift1 lift2))
           ((##null? others)
            (##call-with-current-continuation receiver lift1 lift2 lift3))
           (else
            (##apply
             ##call-with-current-continuation
             (##cons receiver
                     (##cons lift1
                             (##cons lift2
                                     (##cons lift3
                                             others))))))))))

(define call/cc
  call-with-current-continuation)

(define ##initial-dynwind
  '#(0)) ;; only the "level" field is needed

(define-prim (##values
              #!optional
              (val1 (macro-absent-obj))
              (val2 (macro-absent-obj))
              (val3 (macro-absent-obj))
              #!rest
              others)
  (cond ((##eq? val2 (macro-absent-obj))
         (if (##eq? val1 (macro-absent-obj))
           (##values)
           val1))
        ((##eq? val3 (macro-absent-obj))
         (##values val1 val2))
        ((##null? others)
         (##values val1 val2 val3))
        (else
         (##subtype-set!
          (##list->vector (##cons val1 (##cons val2 (##cons val3 others))))
          (macro-subtype-boxvalues)))))

(define-prim (values
              #!optional
              (val1 (macro-absent-obj))
              (val2 (macro-absent-obj))
              (val3 (macro-absent-obj))
              #!rest
              others)
  (cond ((##eq? val2 (macro-absent-obj))
         (if (##eq? val1 (macro-absent-obj))
           (##values)
           val1))
        ((##eq? val3 (macro-absent-obj))
         (##values val1 val2))
        ((##null? others)
         (##values val1 val2 val3))
        (else
         (##subtype-set!
          (##list->vector (##cons val1 (##cons val2 (##cons val3 others))))
          (macro-subtype-boxvalues)))))

(define-prim (##call-with-values producer consumer)
  (let ((results ;; may get bound to a multiple-values object
         (producer)))
    (if (##not (##values? results))
      (consumer results)
      (let ((len (##vector-length results)))
        (cond ((##fixnum.= len 2)
               (consumer (##vector-ref results 0)
                         (##vector-ref results 1)))
              ((##fixnum.= len 3)
               (consumer (##vector-ref results 0)
                         (##vector-ref results 1)
                         (##vector-ref results 2)))
              ((##fixnum.= len 0)
               (consumer))
              (else
               (##apply consumer (##vector->list results))))))))

(define-prim (call-with-values producer consumer)
  (macro-force-vars (producer consumer)
    (macro-check-procedure producer 1 (call-with-values producer consumer)
      (macro-check-procedure consumer 2 (call-with-values producer consumer)
        (##call-with-values producer consumer)))))

(define-prim (##dynamic-wind before thunk after)
  (##continuation-capture
   (lambda (cont)
     (before)
     (let* ((dynwind
             (macro-denv-dynwind
              (macro-thread-denv (macro-current-thread))))
            (new-dynwind
             (macro-make-dynwind
              (##fixnum.+ (macro-dynwind-level dynwind) 1)
              before
              after
              cont))
            (results ;; may get bound to a multiple-values object
             (macro-dynamic-bind dynwind
              new-dynwind
              thunk)))
       (after)
       results))))

(define-prim (dynamic-wind before thunk after)
  (macro-force-vars (before thunk after)
    (macro-check-procedure before 1 (dynamic-wind before thunk after)
      (macro-check-procedure thunk 2 (dynamic-wind before thunk after)
        (macro-check-procedure after 3 (dynamic-wind before thunk after)
          (##dynamic-wind before thunk after))))))

(define-prim (##procedure->continuation proc)
  (##declare (not interrupts-enabled))
  (##closure-ref proc 1))

(define-prim ##thread-save!
  (##first-argument
   (lambda (proc #!rest args)
     (##declare (not interrupts-enabled))
     (##thread-save! (lambda (thread) (##apply proc (##cons thread args)))))))

(define-prim ##thread-restore!
  (##first-argument
   (lambda (thread proc #!rest args)
     (##declare (not interrupts-enabled))
     (##thread-restore! thread (lambda () (##apply proc args))))))

(define-prim (continuation? obj)
  (##continuation? obj))

(define-prim (##continuation-capture-aux receiver lift1 lift2 lift3 others)
  (##declare (not interrupts-enabled))
  (cond ((##eq? lift1 (macro-absent-obj))
         (##continuation-capture receiver))
        ((##eq? lift2 (macro-absent-obj))
         (##continuation-capture receiver lift1))
        ((##eq? lift3 (macro-absent-obj))
         (##continuation-capture receiver lift1 lift2))
        ((##null? others)
         (##continuation-capture receiver lift1 lift2 lift3))
        (else
         (let ((lifts
                (##cons lift1
                        (##cons lift2
                                (##cons lift3
                                        others)))))
           (##continuation-capture
            (lambda (cont)
              (##apply receiver (##cons cont lifts))))))))

(define-prim (##continuation-capture
              receiver
              #!optional
              (lift1 (macro-absent-obj))
              (lift2 (macro-absent-obj))
              (lift3 (macro-absent-obj))
              #!rest
              others)
  (##continuation-capture-aux receiver lift1 lift2 lift3 others))

(define-prim (continuation-capture
              receiver
              #!optional
              (lift1 (macro-absent-obj))
              (lift2 (macro-absent-obj))
              (lift3 (macro-absent-obj))
              #!rest
              others)
  (macro-check-procedure receiver 1 (continuation-capture receiver lift1 lift2 lift3 . others)
    (##continuation-capture-aux receiver lift1 lift2 lift3 others)))

(define-prim ##continuation-graft-no-winding
  (##first-argument
   (lambda (cont
            proc
            #!optional
            (arg1 (macro-absent-obj))
            (arg2 (macro-absent-obj))
            (arg3 (macro-absent-obj))
            #!rest
            others)
     (##declare (not interrupts-enabled))
     (cond ((##eq? arg1 (macro-absent-obj))
            (##continuation-graft-no-winding cont proc))
           ((##eq? arg2 (macro-absent-obj))
            (##continuation-graft-no-winding cont proc arg1))
           ((##eq? arg3 (macro-absent-obj))
            (##continuation-graft-no-winding cont proc arg1 arg2))
           ((##null? others)
            (##continuation-graft-no-winding cont proc arg1 arg2 arg3))
           (else
            (let ((args
                   (##cons arg1
                           (##cons arg2
                                   (##cons arg3
                                           others)))))
              (##continuation-graft-no-winding cont ##apply proc args)))))))

(define-prim ##continuation-return-no-winding
  (##first-argument
   (lambda (cont results)
     (##declare (not interrupts-enabled))
     (##continuation-return-no-winding cont results))))

(define-prim (##continuation-unwind-wind src dst continue)

  (define (unwind-src src dst continue) ;; src level > dst level
    (##continuation-graft-no-winding
     (macro-dynwind-cont src)
     (lambda ()
       ((macro-dynwind-after src))
       (let ((new-src
              (macro-denv-dynwind
               (macro-continuation-denv (macro-dynwind-cont src)))))
         (cond ((##fixnum.< (macro-dynwind-level dst)
                            (macro-dynwind-level new-src))
                (unwind-src new-src dst continue))
               ((and (##not (##eq? new-src dst))
                     (##fixnum.< 0 (macro-dynwind-level new-src)))
                (unwind-src-wind-dst new-src dst continue))
               (else
                (continue)))))))

  (define (wind-dst src dst continue) ;; src level < dst level
    (let* ((new-dst
            (macro-denv-dynwind
             (macro-continuation-denv (macro-dynwind-cont dst))))
           (new-continue
            (lambda ()
              (##continuation-graft-no-winding
               (macro-dynwind-cont dst)
               (lambda ()
                 ((macro-dynwind-before dst))
                 (continue))))))
      (cond ((##fixnum.< (macro-dynwind-level src)
                         (macro-dynwind-level new-dst))
             (wind-dst src new-dst new-continue))
            ((and (##not (##eq? src new-dst))
                  (##fixnum.< 0 (macro-dynwind-level new-dst)))
             (unwind-src-wind-dst src new-dst new-continue))
            (else
             (new-continue)))))

  (define (unwind-src-wind-dst src dst continue) ;; src level = dst level
    (##continuation-graft-no-winding
     (macro-dynwind-cont src)
     (lambda ()
       ((macro-dynwind-after src))
       (let* ((new-src
               (macro-denv-dynwind
                (macro-continuation-denv (macro-dynwind-cont src))))
              (new-dst
               (macro-denv-dynwind
                (macro-continuation-denv (macro-dynwind-cont dst))))
              (new-continue
               (lambda ()
                 (##continuation-graft-no-winding
                  (macro-dynwind-cont dst)
                  (lambda ()
                    ((macro-dynwind-before dst))
                    (continue))))))
         (if (and (##not (##eq? new-src new-dst))
                  (##not (##fixnum.= (macro-dynwind-level new-src) 0)))
           (unwind-src-wind-dst
            new-src
            new-dst
            (lambda () (new-continue)))
           (new-continue))))))

  (let ((src-level
         (macro-dynwind-level src))
        (dst-level
         (macro-dynwind-level dst)))
    (cond ((##fixnum.< dst-level src-level)
           (unwind-src src dst continue))
          ((##fixnum.< src-level dst-level)
           (wind-dst src dst continue))
          (else
           (unwind-src-wind-dst src dst continue)))))

(define-prim (##continuation-graft-aux cont proc arg1 arg2 arg3 others)

  (##declare (not interrupts-enabled))

  (define (continue)
    (cond ((##eq? arg1 (macro-absent-obj))
           (##continuation-graft-no-winding cont proc))
          ((##eq? arg2 (macro-absent-obj))
           (##continuation-graft-no-winding cont proc arg1))
          ((##eq? arg3 (macro-absent-obj))
           (##continuation-graft-no-winding cont proc arg1 arg2))
          ((##null? others)
           (##continuation-graft-no-winding cont proc arg1 arg2 arg3))
          (else
           (let ((args
                  (##cons arg1
                          (##cons arg2
                                  (##cons arg3
                                          others)))))
             (##continuation-graft-no-winding cont ##apply proc args)))))

  (let* ((src
          (macro-denv-dynwind
           (macro-thread-denv (macro-current-thread))))
         (dst
          (macro-denv-dynwind
           (macro-continuation-denv cont))))
    (if (or (##eq? src dst) ;; check common case (same dynamic-wind context)
            (and (##fixnum.= (macro-dynwind-level src) 0)
                 (##fixnum.= (macro-dynwind-level dst) 0)))
        (continue)
        (##continuation-unwind-wind src dst (lambda () (continue))))))

(define-prim (##continuation-graft
              cont
              proc
              #!optional
              (arg1 (macro-absent-obj))
              (arg2 (macro-absent-obj))
              (arg3 (macro-absent-obj))
              #!rest
              others)
  (##continuation-graft-aux cont proc arg1 arg2 arg3 others))

(define-prim (continuation-graft
              cont
              proc
              #!optional
              (arg1 (macro-absent-obj))
              (arg2 (macro-absent-obj))
              (arg3 (macro-absent-obj))
              #!rest
              others)
  (macro-check-continuation cont 1 (continuation-graft cont proc arg1 arg2 arg3 . others)
    (macro-check-procedure proc 2 (continuation-graft cont proc arg1 arg2 arg3 . others)
      (##continuation-graft-aux cont proc arg1 arg2 arg3 others))))

(define-prim (##continuation-return-aux cont val1 val2 val3 others)

  (##declare (not interrupts-enabled))

  (define (continue)
    (##continuation-return-no-winding
     cont
     (cond ((##eq? val1 (macro-absent-obj))
            (##values))
           ((##eq? val2 (macro-absent-obj))
            val1)
           ((##eq? val3 (macro-absent-obj))
            (##values val1 val2))
           ((##null? others)
            (##values val1 val2 val3))
           (else
            (##subtype-set!
             (##list->vector
              (##cons val1
                      (##cons val2
                              (##cons val3
                                      others))))
             (macro-subtype-boxvalues))))))

  (let* ((src
          (macro-denv-dynwind
           (macro-thread-denv (macro-current-thread))))
         (dst
          (macro-denv-dynwind
           (macro-continuation-denv cont))))
    (if (or (##eq? src dst) ;; check common case (same dynamic-wind context)
            (and (##fixnum.= (macro-dynwind-level src) 0)
                 (##fixnum.= (macro-dynwind-level dst) 0)))
        (continue)
        (##continuation-unwind-wind src dst (lambda () (continue))))))

(define-prim (##continuation-return
              cont
              #!optional
              (val1 (macro-absent-obj))
              (val2 (macro-absent-obj))
              (val3 (macro-absent-obj))
              #!rest
              others)
  (##continuation-return-aux cont val1 val2 val3 others))

(define-prim (continuation-return
              cont
              #!optional
              (val1 (macro-absent-obj))
              (val2 (macro-absent-obj))
              (val3 (macro-absent-obj))
              #!rest
              others)
  (macro-check-continuation cont 1 (continuation-return cont val1 val2 val3 . others)
    (##continuation-return-aux cont val1 val2 val3 others)))

;;;----------------------------------------------------------------------------

(define-prim (apply proc arg1 . other-args)

  (define (build-arg-list i arg other-args)

    (define (copy-proper-list lst)
      (macro-force-vars (lst)
        (if (##pair? lst)
          (let ((tail (copy-proper-list (##cdr lst))))
            (macro-if-checks
              (if (##fixnum? tail)
                tail
                (##cons (##car lst) tail))
              (##cons (##car lst) tail)))
          (macro-if-checks
            (if (##null? lst)
              '()
              i) ;; error: list expected
            '()))))

    (define (check-proper-list lst)
      (macro-if-checks
        ;; This procedure may get into an infinite loop if another thread
        ;; mutates "lst" (if lst1 and lst2 each point to disconnected cycles).
        (let loop ((lst1 lst) (lst2 lst))
          (macro-force-vars (lst1)
            (if (##not (##pair? lst1))
                (if (##null? lst1)
                    lst
                    i)
                (let ((lst1 (##cdr lst1)))
                  (macro-force-vars (lst1 lst2)
                    (cond ((##eq? lst1 lst2)
                           i)
                          ((##not (##pair? lst2))
                          ;; this case is possible if other threads mutate the list
                          (if (##null? lst2)
                              lst
                              i))
                          ((##pair? lst1)
                           (loop (##cdr lst1) (##cdr lst2)))
                          (else
                           (if (##null? lst1)
                               lst
                               i))))))))
        lst))

    (if (##pair? other-args)
      (let ((tail
             (build-arg-list (##fixnum.+ i 1)
                             (##car other-args)
                             (##cdr other-args))))
        (macro-if-checks
          (if (##fixnum? tail)
            tail
            (##cons arg tail))
          (##cons arg tail)))
      (macro-if-forces
        (copy-proper-list arg)
        (check-proper-list arg))))

  (macro-force-vars (proc)
    (macro-check-procedure proc 1 (apply proc arg1 . other-args)
      (let ((lst (build-arg-list 2 arg1 other-args)))
        (macro-if-checks
          (if (##fixnum? lst)
            (macro-fail-check-list lst (apply proc arg1 . other-args))
            (##apply proc lst))
          (##apply proc lst))))))

;;;----------------------------------------------------------------------------

;;; Implementation of TCP service register.

(define ##tcp-service-table (##make-table))
(define ##tcp-service-mutex (macro-make-mutex 'tcp-service))
(define ##tcp-service-tgroup (macro-make-tgroup 'tcp-service #f))

(define-prim (##tcp-service-serve server-port thunk tgroup)
  (let loop ()
    (let ((connection-port (##read server-port)))
      (if (##port? connection-port)
          (let ((t
                 (##make-root-thread
                  (lambda ()
                    (thunk)
                    (##close-output-port connection-port)
                    (##read-u8 connection-port) ;; wait for client to close
                    (##close-port connection-port))
                  connection-port ;; name of the thread
                  tgroup
                  connection-port
                  connection-port)))
            (##thread-start! t)
            (loop))
          (##close-port server-port)))))

(define-prim (##tcp-service-update! server-address-and-port-number new-value)
  (macro-mutex-lock! ##tcp-service-mutex #f (macro-current-thread))
  (let ((old-value
         (##table-ref ##tcp-service-table
                      server-address-and-port-number
                      #f)))
    (if old-value
        (let ((server-port (##car old-value))
              (thread (##cdr old-value)))
          (##close-port server-port)
          (##thread-terminate! thread)))
    (if new-value
        (##table-set! ##tcp-service-table
                      server-address-and-port-number
                      new-value)
        (##table-set! ##tcp-service-table
                      server-address-and-port-number))
    (macro-mutex-unlock! ##tcp-service-mutex)))

(define-prim (##tcp-service-register! port-number-or-settings thunk tg tgroup)
  (##process-tcp-server-psettings
   #t
   (lambda (psettings-and-server-address)
     (let* ((psettings
             (##car psettings-and-server-address))
            (server-address
             (##cdr psettings-and-server-address))
            (port-number
             (macro-psettings-port-number psettings))
            (server-address-and-port-number
             (##cons server-address port-number)))
       (##tcp-service-update! server-address-and-port-number
                              #f)
       (##open-tcp-server-aux
        #t
        psettings-and-server-address
        (lambda (server-port)
          (let ((new-thread
                 (##make-root-thread
                  (lambda () (##tcp-service-serve server-port thunk tgroup))
                  server-address-and-port-number
                  ##tcp-service-tgroup
                  ##stdin-port
                  ##stdout-port)))
            (##tcp-service-update! server-address-and-port-number
                                   (##cons server-port new-thread))
            (##thread-start! new-thread)
            (##void)))
        tcp-service-register!
        port-number-or-settings
        thunk
        tg
        (macro-absent-obj))))
   tcp-service-register!
   port-number-or-settings
   thunk
   tg
   (macro-absent-obj)))

(define-prim (tcp-service-register!
              port-number-or-settings
              thunk
              #!optional
              (tg (macro-absent-obj)))
  (macro-force-vars (port-number-or-settings thunk tg)
    (let ((tgroup
           (if (##eq? tg (macro-absent-obj))
               (macro-thread-tgroup (macro-current-thread))
               tg)))
      (macro-check-procedure
       thunk
       2
       (tcp-service-register! port-number-or-settings thunk tg)
       (macro-check-tgroup
        tgroup
        3
        (tcp-service-register! port-number-or-settings thunk tg)
        (##tcp-service-register! port-number-or-settings thunk tg tgroup))))))

(define-prim (##tcp-service-unregister! port-number-or-settings)
  (##process-tcp-server-psettings
   #t
   (lambda (psettings-and-server-address)
     (let* ((psettings
             (##car psettings-and-server-address))
            (server-address
             (##cdr psettings-and-server-address))
            (port-number
             (macro-psettings-port-number psettings))
            (server-address-and-port-number
             (##cons server-address port-number)))
       (##tcp-service-update! server-address-and-port-number #f)
       (##void)))
   tcp-service-unregister!
   port-number-or-settings
   (macro-absent-obj)
   (macro-absent-obj)
   (macro-absent-obj)))

(define-prim (tcp-service-unregister!
              port-number-or-settings)
  (macro-force-vars (port-number-or-settings)
    (##tcp-service-unregister! port-number-or-settings)))

;;;----------------------------------------------------------------------------

;; (##current-user-interrupt-handler) is called on each user interrupt.

(define ##deferred-user-interrupt? #f)

(define (defer-user-interrupts)
   (##declare (not interrupts-enabled))
   (set! ##deferred-user-interrupt? #t)
   (##void))
     
(define ##current-user-interrupt-handler
  (##make-parameter
   defer-user-interrupts
   (lambda (val)
     (macro-check-procedure val 1 (##current-user-interrupt-handler val)
       (let ()
         (##declare (not interrupts-enabled))
         (##declare (not safe)) ;; avoid procedure check on the call
         (let ((int? ##deferred-user-interrupt?))
           (set! ##deferred-user-interrupt? #f)
           (if int?
               (val)))
         val)))))

(define current-user-interrupt-handler
  ##current-user-interrupt-handler)

(define-prim (##user-interrupt!)
  (##declare (not interrupts-enabled))
  (let ((handler (##current-user-interrupt-handler)))
    (if (##procedure? handler)
        (let ()
          (##declare (not safe)) ;; avoid procedure check on the call
          (handler)))))

(##interrupt-vector-set! 0 ##user-interrupt!)

(##thread-startup!)

(##thread-heartbeat-interval-set! (macro-default-heartbeat-interval))

;;;============================================================================
;;(##include "termite/termite.scm")