contrib/sb-concurrency/queue.lisp

   1 ;;;; Written by James M. Lawrence for SBCL.
   2 ;;;; API and docstrings by Nikodemus Siivola.
   3 ;;;;
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; This software is derived from the CMU CL system, which was written at
   8 ;;;; Carnegie Mellon University and released into the public domain. The
   9 ;;;; software is in the public domain and is provided with absolutely no
  10 ;;;; warranty. See the COPYING and CREDITS files for more information.
  11
  12 ;;; Singly-linked queue with compare-and-swap operations.
  13 ;;;
  14 ;;; The following invariants hold except during updates:
  15 ;;;
  16 ;;;   (car (queue-head queue)) == +dummy+
  17 ;;;
  18 ;;;   (cdr (queue-tail queue)) == nil
  19 ;;;
  20 ;;;   If the queue is empty, (queue-head queue) == (queue-tail queue).
  21 ;;;
  22 ;;;   If the queue is non-empty, (cadr (queue-head queue)) is the next
  23 ;;;   value to be dequeued and (car (queue-tail queue)) is the most
  24 ;;;   recently enqueued value.
  25 ;;;
  26 ;;; The CDR of a discarded node is set to +DEAD-END+. This flag must
  27 ;;; be checked at each traversal.
  28
  29 (in-package :sb-concurrency)
  30
  31 (defconstant +dummy+ '.dummy.)
  32 (defconstant +dead-end+ '.dead-end.)
  33
  34 (declaim (inline %make-queue))
  35 (defstruct (queue (:constructor %make-queue (head tail name))
  36                   (:copier nil)
  37                   (:predicate queuep))
  38   "Lock-free thread safe FIFO queue.
  39
  40 Use ENQUEUE to add objects to the queue, and DEQUEUE to remove them."
  41   (head (error "No HEAD.") :type cons)
  42   (tail (error "No TAIL.") :type cons)
  43   (name nil))
  44 (declaim (sb-ext:freeze-type queue))
  45
  46 (setf (documentation 'queuep 'function)
  47       "Returns true if argument is a QUEUE, NIL otherwise."
  48       (documentation 'queue-name 'function)
  49       "Name of a QUEUE. Can be assigned to using SETF. Queue names
  50 can be arbitrary printable objects, and need not be unique.")
  51
  52 (declaim (ftype (sfunction (&key (:name t)
  53                                  (:initial-contents sequence)) queue)
  54                 make-queue))
  55 (defun make-queue (&key name initial-contents)
  56   "Returns a new QUEUE with NAME and contents of the INITIAL-CONTENTS
  57 sequence enqueued."
  58   (let* ((dummy (cons +dummy+ nil))
  59          (queue (%make-queue dummy dummy name)))
  60     (flet ((enc-1 (x)
  61              (enqueue x queue)))
  62       (declare (dynamic-extent #'enc-1))
  63       (map nil #'enc-1 initial-contents))
  64     queue))
  65
  66
  67 (declaim (ftype (sfunction (t queue) t) enqueue))
  68 (defun enqueue (value queue)
  69   "Adds VALUE to the end of QUEUE. Returns VALUE."
  70   ;; Attempt CAS, repeat upon failure. Upon success update QUEUE-TAIL.
  71   (declare (optimize speed))
  72   (let ((new (cons value nil)))
  73     (loop (when (eq nil (sb-ext:compare-and-swap (cdr (queue-tail queue))
  74                                                  nil new))
  75             (setf (queue-tail queue) new)
  76             (return value)))))
  77
  78 (declaim (ftype (sfunction (queue) (values t boolean)) dequeue))
  79 (defun dequeue (queue)
  80   "Retrieves the oldest value in QUEUE and returns it as the primary value,
  81 and T as secondary value. If the queue is empty, returns NIL as both primary
  82 and secondary value."
  83   ;; Attempt to CAS QUEUE-HEAD with the next node, repeat upon
  84   ;; failure. Upon success, clear the discarded node and set the CAR
  85   ;; of QUEUE-HEAD to +DUMMY+.
  86   (declare (optimize speed))
  87   (loop (let* ((head (queue-head queue))
  88                (next (cdr head)))
  89           ;; NEXT could be +DEAD-END+, whereupon we try again.
  90           (typecase next
  91             (null (return (values nil nil)))
  92             (cons (when (eq head (sb-ext:compare-and-swap (queue-head queue)
  93                                                           head next))
  94                     (let ((value (car next)))
  95                       ;; Clear the CDR, otherwise the conservative GC could
  96                       ;; hoard long lists. (car head) is always +dummy+.
  97                       (setf (cdr head) +dead-end+
  98                             (car next) +dummy+)
  99                       (return (values value t)))))))))
 100
 101 (defun try-walk-queue (fun queue)
 102   ;; This isn't /quite/ as bad as it looks. We're in danger of needing
 103   ;; to restart only as long as we're close to the head of the queue.
 104   (let ((node (queue-head queue)))
 105     (loop
 106        (let ((value (car node)))
 107          (unless (eq value +dummy+)
 108            (funcall fun value)))
 109        (setf node (cdr node))
 110        (cond ((eq node +dead-end+)
 111               (return nil))
 112              ((null node)
 113               (return t))))))
 114
 115 (declaim (ftype (sfunction (queue) list) list-queue-contents))
 116 (defun list-queue-contents (queue)
 117   "Returns the contents of QUEUE as a list without removing them from the
 118 QUEUE. Mainly useful for manual examination of queue state, as the list may be
 119 out of date by the time it is returned, and concurrent dequeue operations may
 120 in the worse case force the queue-traversal to be restarted several times."
 121   (tagbody
 122    :retry
 123      (collect ((result))
 124        (unless (try-walk-queue (lambda (elem) (result elem)) queue)
 125          (go :retry))
 126        (return-from list-queue-contents (result)))))
 127
 128 (declaim (ftype (sfunction (queue) unsigned-byte) queue-count))
 129 (defun queue-count (queue)
 130   "Returns the number of objects in QUEUE. Mainly useful for manual
 131 examination of queue state, and in PRINT-OBJECT methods: inefficient as it
 132 must walk the entire queue."
 133   (tagbody
 134    :retry
 135      (let ((count 0))
 136        (unless (try-walk-queue (lambda (elem)
 137                                  (declare (ignore elem))
 138                                  (incf count))
 139                                queue)
 140          (go :retry))
 141        (return-from queue-count count))))
 142
 143 (declaim (ftype (sfunction (queue) boolean) queue-empty-p))
 144 (defun queue-empty-p (queue)
 145   "Returns T if QUEUE is empty, NIL otherwise."
 146   (null (cdr (queue-head queue))))
 147
 148 ;;; Experimental support for compiling in the background.
 149 ;;; The use-case is that you have some functions which you'll need later,
 150 ;;; but want to pass them around now as compiled-functions without waiting
 151 ;;; for COMPILE. If the timing is right, the compiler will be done by the time
 152 ;;; of the call to such functions, but if not, that's OK - it just works.
 153 #+sb-thread
 154 (progn
 155   (define-load-time-global *compilation-queue* (make-queue :name "compiler"))
 156
 157   (defun run-background-compile (&aux compiled)
 158     (loop
 159      (let ((item (dequeue *compilation-queue*)))
 160        (unless item (return compiled))
 161        (setq compiled t)
 162        (let ((fin (elt (the (simple-vector 3) item) 0))
 163              (lexpr (elt item 1)))
 164          (multiple-value-bind (compiled-function warnings errors) (compile nil lexpr)
 165            (declare (ignore warnings))
 166            ;; It's OK for a closure's raw addr slot to point directly to an address
 167            ;; within a code blob, but I'm not sure if it's legal in a funinstance.
 168            ;; Probably need to tweak the GC to allow it. Then we would bypass
 169            ;; the embedded trampoline for anonymous call; the caller would jump
 170            ;; directly to where the call is intended to end up.
 171            (setf (sb-kernel:%funcallable-instance-fun fin)
 172                  (if errors
 173                      (lambda (&rest args)
 174                        (declare (ignore args))
 175                        (error "Compiling ~S failed" fin))
 176                      (lambda (&rest args)
 177                        (apply compiled-function args))))
 178            (open-gate (elt item 2)))))))
 179
 180   (setq sb-impl::*bg-compiler-function*
 181         (lambda ()
 182           (let ((result1 (sb-c::default-compiler-worker))
 183                 (result2 (run-background-compile)))
 184             (or result1 result2))))
 185
 186   (defun promise-compile (lexpr)
 187     ;;   Dynamic      Immobile
 188     ;;   -------      --------
 189     ;;   header       header+layout
 190     ;;   trampoline   trampoline -----\
 191     ;;   layout       machine code   <--
 192     ;;   impl-fun     machine code
 193     ;;   unused       impl-fun
 194     ;;   unused
 195     ;; The constant 1 here is ok for #+ or #- immobile-space.
 196     (let ((fin (sb-kernel:%make-funcallable-instance 1))
 197           (gate (make-gate)))
 198       (sb-kernel:%set-fun-layout fin (sb-kernel:find-layout 'function))
 199       (sb-vm::write-funinstance-prologue fin)
 200       (setf (sb-kernel:%funcallable-instance-fun fin)
 201             (lambda (&rest args)
 202               (wait-on-gate gate)
 203               (apply fin args)))
 204       (enqueue (vector fin lexpr gate) *compilation-queue*)
 205       (sb-impl::finalizer-thread-notify 0)
 206       fin)))