(define callbacks (make-rb-tree fix:= fix:<))
(define callback-height 0)
(define callback-waiters (make-rb-tree fix:= fix:<))

(define (allocate-callback-token procedure)
  (guarantee-procedure-of-arity procedure 1 'ALLOCATE-CALLBACK-TOKEN)
  (without-interrupts
   (lambda ()
     (do ((token 0 (fix:+ token 1)))
         ((not (rb-tree/lookup callbacks token))
          (rb-tree/insert! callbacks token procedure)
          token)
       (assert (fix:< token (largest-fixnum)))))))

(define (release-callback-token token)
  (guarantee-index-fixnum token 'RELEASE-CALLBACK-TOKEN)
  (without-interrupts
   (lambda ()
     (assert (rb-tree/lookup callbacks token))
     (rb-tree/delete! callbacks token))))

(define (call-with-callback-token procedure receiver)
  (let ((token))
    (dynamic-wind
     (let ((entered? #f))
       (lambda ()
         (if entered? (error "Can't re-enter CALL-WITH-CALLBACK-TOKEN."))
         (set! entered? #t)
         (set! token (allocate-callback procedure))
         unspecific)
       (lambda ()
         (receiver token))
       (lambda ()
         (release-callback token))))))

(define (microcode-callback interrupt-enables token argument)
  ;; Bump the height.  Interrupts are blocked so we can safely adjust
  ;; the runtime's callback height.  Since *all* interrupts are
  ;; blocked, we cannot allocate, so use fixnum-only arithmetic in
  ;; these assertions.  (XXX What about just turning on GC interrupts
  ;; straight away?)
  (let ((height
         (let ((h callback-height))
           (assert (fix:< h (largest-fixnum)))
           (set! callback-height (fix:+ h 1))
           h)))
    (assert (fixnum? height))
    (assert (fix:< 0 height))
    (assert (fix:= callback-height (fix:- height 1)))

    ;; Look up the callback, enable interrupts, and apply it.
    (begin0 (let ((procedure (rb-tree/lookup callbacks token)))
              (set-interrupt-enables! interrupt-enables)
              (procedure argument))

      ;; Done.  Wait until we're the highest callback.  Interrupts must
      ;; be off so nobody can change this until we've returned to the
      ;; microcode.
      (set-interrupt-enables! interrupt-mask/gc-ok)
      (if (not (fix:= callback-height height))
          (let ((waiters callback-waiters))
            (assert (not (rb-tree/lookup waiters height)))
            (rb-tree/insert! waiters height (current-thread))
            (do () ((fix:= callback-height height))
              ;; Make sure we're still listed as waiting.
              (assert (eq? (current-thread) (rb-tree/lookup waiters height)))
              ;; Suspension turns interrupts back on.  Once someone
              ;; wakes us, we must turn them back off again before
              ;; testing the height.
              (suspend-current-thread)
              (set-interrupt-enables! interrupt-mask/gc-ok))
            ;; All set.  Remove us from the waiters list.
            (assert (eq? (current-thread) (rb-tree/lookup waiters height)))
            (rb-tree/delete! waiters height)))

      ;; We are now the highest callback.  Signal the callback
      ;; immediately below us, if there is one.  Callbacks further down
      ;; have to wait for the intermediate one to finish anyway.
      (assert (fix:= callback-height height))
      (let ((height* (fix:- callback-height 1)))
        (cond ((rb-tree/lookup callback-waiters height*)
               => (lambda (thread)
                    (signal-thread-event thread #t))))
        (set! callback-height height*)))))