Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Initial import

  • Loading branch information...
commit be93a07e882abe168e94376c9780e9b50b933859 0 parents
@afeinberg authored
1  README
@@ -0,0 +1 @@
+Port of some parts of java.util.concurrent (jsr166) to sbcl
15 src/af-concurrency.asd
@@ -0,0 +1,15 @@
+(asdf:defsystem :af-concurrency
+ :description "Concurrency utility library."
+ :author "Alex Feinberg <alex@strlen.net>"
+ :maintainer "Alex Feinberg <alex@strlen.net>"
+ :version "0.0.1"
+ :license "MIT"
+ :depends-on (:af-concurrency.util :af-concurrency.blocking)
+ :pathname ""
+ :components ((:file "pkgdcl")))
+
+(defmethod perform ((o test-op) (c (eql (find-system :af-concurrency))))
+ (oos 'test-op :af-concurrency.tests))
+
+(defmethod operation-done-p ((o test-op) (c (eql (find-system :af-concurrency))))
+ nil)
10 src/af-concurrency.atomic.asd
@@ -0,0 +1,10 @@
+(asdf:defsystem :af-concurrency.atomic
+ :description "Atomic operations using memory barries and cas"
+ :author "Alex Feinberg <alex@strlen.net>"
+ :maintainer "Alex Feinberg <alex@strlen.net>"
+ :version "0.0.1"
+ :license "MIT"
+ :pathname "atomic/"
+ :components
+ ((:file "pkgdcl")
+ (:file "atomic-boolean" :depends-on ("pkgdcl"))))
11 src/af-concurrency.blocking.asd
@@ -0,0 +1,11 @@
+(asdf:defsystem :af-concurrency.blocking
+ :description "Blocking concurrency utilities"
+ :author "Alex Feinberg <alex@strlen.net>"
+ :maintainer "Alex Feinberg <alex@strlen.net>"
+ :version "0.0.1"
+ :license "MIT"
+ :depends-on (:af-concurrency.util)
+ :pathname "blocking/"
+ :components
+ ((:file "pkgdcl")
+ (:file "blocking-queue" :depends-on ("pkgdcl"))))
11 src/af-concurrency.util.asd
@@ -0,0 +1,11 @@
+(asdf:defsystem :af-concurrency.util
+ :description "Generic utilities"
+ :author "Alex Feinberg <alex@strlen.net>"
+ :maintainer "Alex Feinberg <alex@strlen.net>"
+ :version "0.0.1"
+ :license "MIT"
+ :pathname "util/"
+ :components
+ ((:file "pkgdcl")
+ (:file "queue" :depends-on ("pkgdcl"))))
+
34 src/atomic/atomic-boolean.lisp
@@ -0,0 +1,34 @@
+(in-package :af-concurrency.atomic)
+
+(defmacro bool->int (b)
+ `(if ,b
+ 1
+ 0))
+
+(defmacro int->bool (i)
+ `(= 1 ,i))
+
+(defun make-atomic-boolean (&optional (initial nil))
+ (list
+ (bool->int initial)))
+
+(defun atomic-boolean-get (ab)
+ (barrier (:memory)
+ (int->bool (car ab))))
+
+(defun atomic-boolean-set (new-value ab)
+ (barrier (:memory)
+ (setf (car ab)
+ (bool->int new-value))))
+
+(defun atomic-boolean-cas (expect update ab)
+ (let ((e (bool->int expect))
+ (u (bool->int update)))
+ (= e (compare-and-swap (car ab) e u))))
+
+(defun atomic-boolean-get-and-set (new-value ab)
+ (loop
+ for current = (atomic-boolean-get ab)
+ when (atomic-boolean-cas current new-value ab)
+ return current))
+
10 src/atomic/pkgdcl.lisp
@@ -0,0 +1,10 @@
+(in-package :common-lisp-user)
+
+(defpackage :af-concurrency.atomic
+ (:use :cl :sb-thread :sb-ext)
+ (:export
+ :make-atomic-boolean
+ :atomic-boolean-get
+ :atomic-boolean-set
+ :atomic-boolean-cas
+ :atomic-boolean-get-and-set))
76 src/blocking/blocking-queue.lisp
@@ -0,0 +1,76 @@
+(in-package :af-concurrency.blocking)
+
+(defgeneric take (q)
+ (:documentation "Retrieves and removes head of the queue, waiting if
+needed until an element becomes available."))
+
+(defgeneric put (obj q)
+ (:documentation "Inserts the specified element into this queue, waiting
+if needed for space to become available"))
+
+(defgeneric blocking-queue-empty-p (q)
+ (:documentation "Return true if this queue contains no elements."))
+
+(defgeneric remaining-capacity (q)
+ (:documentation "Return the number of additional elements that this queue
+can ideally (in absence of resource constraints) accept without blocking, or
+-1 if there is no intrinisic limit."))
+
+(defclass list-blocking-queue ()
+ ((cond-empty
+ :initform (make-waitqueue))
+ (cond-full
+ :initform (make-waitqueue))
+ (queue-mutex
+ :initform (make-mutex :name "queue lock"))
+ (queue
+ :initform (af/make-queue))
+ (size
+ :initform 0)
+ (capacity
+ :initarg :capacity
+ :initform -1)))
+
+(defun make-list-blocking-queue (&optional capacity)
+ (if capacity
+ (make-instance 'list-blocking-queue :capacity capacity)
+ (make-instance 'list-blocking-queue)))
+
+(defmethod take ((q list-blocking-queue))
+ (with-slots (cond-empty cond-full queue-mutex queue size capacity) q
+ (let ((val
+ (with-mutex (queue-mutex)
+ (loop
+ (unless (= size 0) (return))
+ (condition-wait cond-empty queue-mutex))
+ (decf size)
+ (af/dequeue queue))))
+ (condition-broadcast cond-full)
+ val)))
+
+(defmethod put (o (q list-blocking-queue))
+ (with-slots (cond-empty cond-full queue-mutex queue size capacity) q
+ (let ((val
+ (with-mutex (queue-mutex)
+ (loop
+ (unless (= size capacity) (return))
+ (condition-wait cond-full queue-mutex))
+ (incf size)
+ (af/enqueue o queue))))
+ (condition-broadcast cond-empty)
+ val)))
+
+(defmethod remaining-capacity ((q list-blocking-queue))
+ (with-slots (queue-mutex capacity size) q
+ (with-mutex (queue-mutex)
+ (if (not (= -1 capacity))
+ (- capacity size)
+ -1))))
+
+(defmethod blocking-queue-empty-p ((q list-blocking-queue))
+ (with-slots (queue-mutex size) q
+ (with-mutex (queue-mutex)
+ (= size 0))))
+
+
+
18 src/blocking/pkgdcl.lisp
@@ -0,0 +1,18 @@
+(in-package :common-lisp-user)
+
+(defpackage :af-concurrency.blocking
+ (:use
+ :cl
+ :sb-thread
+ :sb-ext
+ :af-concurrency.util)
+ (:export
+ ;; Classes
+ :list-blocking-queue
+ ;; Methods
+ :take
+ :put
+ :blocking-queue-empty-p
+ :remaining-capacity
+ ;; Functions
+ :make-list-blocking-queue))
4 src/pkgdcl.lisp
@@ -0,0 +1,4 @@
+(in-package :common-lisp-user)
+
+(defpackage :af-concurrency
+ (:use :cl :sb-thread :sb-ext))
9 src/util/pkgdcl.lisp
@@ -0,0 +1,9 @@
+(in-package :common-lisp-user)
+
+(defpackage :af-concurrency.util
+ (:use :cl :sb-thread :sb-ext)
+ (:export
+ ;; Functions
+ :af/make-queue
+ :af/enqueue
+ :af/dequeue))
16 src/util/queue.lisp
@@ -0,0 +1,16 @@
+(in-package :af-concurrency.util)
+
+(defun af/make-queue () (cons nil nil))
+
+(defun af/enqueue (o q)
+ (if (null (car q))
+ (setf (cdr q) (setf (car q) (list o)))
+ (setf (cdr (cdr q)) (list o)
+ (cdr q) (cdr (cdr q))))
+ (car q))
+
+(defun af/dequeue (q)
+ (let ((val (pop (car q))))
+ (when (null (car q))
+ (setf (cdr q) nil))
+ val))
21 tests/af-concurrency-tests.asd
@@ -0,0 +1,21 @@
+(asdf:defsystem :af-concurrency-tests
+ :description "Concurrency test suite."
+ :author "Alex Feinberg <alex@strlen.net>"
+ :version "0.0.1"
+ :license "MIT"
+ :depends-on (:fiveam :af-concurrency)
+ :components
+ ((:file "pkgdcl")
+ (:file "defsuites" :depends-on ("pkgdcl"))
+ (:file "utils" :depends-on ("pkgdcl" "defsuites"))
+ (:file "blocking" :depends-on ("pkgdcl" "defsuites"))
+ (:file "atomic" :depends-on ("pkgdcl" "defsuites"))))
+
+(defmethod perform ((o test-op)
+ (c (eql (find-system :af-concurrency-tests))))
+ (operate 'load-op :af-concurrency-tests)
+ (funcall (intern (symbol-name '#:run!) '#:5am) :af-concurrency))
+
+(defmethod operation-done-p ((o test-op)
+ (c (eql (find-system :af-concurrency-tests))))
+ nil)
25 tests/atomic.lisp
@@ -0,0 +1,25 @@
+(in-package :af-concurrency-tests)
+
+(in-suite :af-concurrency.atomic)
+
+(test atomic-boolean-test
+ (let* ((keep-running (make-atomic-boolean t))
+ (toggle-switch (make-atomic-boolean nil))
+ (thread-1 (make-thread
+ (lambda ()
+ (loop
+ (unless (atomic-boolean-get keep-running)
+ (return))))))
+ (thread-2 (make-thread
+ (lambda ()
+ (loop
+ when (atomic-boolean-cas nil t toggle-switch)
+ return
+ (atomic-boolean-get-and-set nil keep-running))))))
+ (atomic-boolean-set t toggle-switch)
+ (join-thread thread-2)
+ (join-thread thread-1)
+ (is
+ (and
+ (eq t (atomic-boolean-get toggle-switch))
+ (eq nil (atomic-boolean-get keep-running))))))
29 tests/blocking.lisp
@@ -0,0 +1,29 @@
+(in-package :af-concurrency-tests)
+
+(in-suite :af-concurrency.blocking)
+
+(test block-when-empty-test
+ "Queue should block when empty"
+ (let* ((seen nil)
+ (q (make-list-blocking-queue))
+ ;; Consumer
+ (consumer-thread
+ (make-thread
+ (lambda ()
+ (setf seen (loop
+ for i from 1 to 10
+ collect (take q))))))
+ ;; Producer
+ (producer-thread
+ (make-thread
+ (lambda ()
+ (loop
+ for i from 1 to 10
+ do (put i q))))))
+ (join-thread producer-thread)
+ (join-thread consumer-thread)
+ (is (equal (loop
+ for i from 1 to 10
+ collect i)
+ seen))))
+
10 tests/defsuites.lisp
@@ -0,0 +1,10 @@
+(in-package :af-concurrency-tests)
+
+(def-suite :af-concurrency
+ :description "Main test suite for af-concurrency")
+
+(def-suite :af-concurrency.util :in :af-concurrency)
+
+(def-suite :af-concurrency.blocking :in :af-concurrency)
+
+(def-suite :af-concurrency.atomic :in :af-concurrency)
11 tests/pkgdcl.lisp
@@ -0,0 +1,11 @@
+(in-package :common-lisp-user)
+
+(defpackage :af-concurrency-tests
+ (:use :cl
+ :sb-thread
+ :sb-ext
+ :5am
+ :af-concurrency
+ :af-concurrency.blocking
+ :af-concurrency.util
+ :af-concurrency.atomic))
17 tests/utils.lisp
@@ -0,0 +1,17 @@
+(in-package :af-concurrency-tests)
+
+(in-suite :af-concurrency.util)
+
+(test af-queue-test
+ "Test the queue"
+ (let ((q (af/make-queue)))
+ (loop
+ for i from 1 to 10
+ do (af/enqueue i q))
+ (is (equal
+ (loop
+ for i from 1 to 10
+ collect (af/dequeue q))
+ (loop
+ for i from 1 to 10
+ collect i)))))
Please sign in to comment.
Something went wrong with that request. Please try again.