forked from dmitryvk/sbcl-win32-threads
-
Notifications
You must be signed in to change notification settings - Fork 4
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Conflicts: src/code/filesys.lisp
- Loading branch information
Showing
12 changed files
with
393 additions
and
81 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,91 @@ | ||
| ;;;; -*- Lisp -*- | ||
| ;;;; | ||
| ;;;; This software is part of the SBCL system. See the README file for | ||
| ;;;; more information. | ||
| ;;;; | ||
| ;;;; This software is derived from the CMU CL system, which was | ||
| ;;;; written at Carnegie Mellon University and released into the | ||
| ;;;; public domain. The software is in the public domain and is | ||
| ;;;; provided with absolutely no warranty. See the COPYING and CREDITS | ||
| ;;;; files for more information. | ||
|
|
||
| (in-package :sb-concurrency) | ||
|
|
||
| ;;;; FIXME: On Linux a direct futex-based implementation would be more | ||
| ;;;; efficient. | ||
|
|
||
| (defstruct (gate (:constructor %make-gate) | ||
| (:copier nil) | ||
| (:predicate gatep)) | ||
| "GATE type. Gates are syncronization constructs suitable for making | ||
| multiple threads wait for single event before proceeding. | ||
| Use WAIT-ON-GATE to wait for a gate to open, OPEN-GATE to open one, | ||
| and CLOSE-GATE to close an open gate. GATE-OPEN-P can be used to test | ||
| the state of a gate without blocking." | ||
| (mutex (missing-arg) :type mutex) | ||
| (queue (missing-arg) :type waitqueue) | ||
| (state :closed :type (member :open :closed)) | ||
| (name nil :type (or null simple-string))) | ||
|
|
||
| (setf (documentation 'gatep 'function) | ||
| "Returns true if the argument is a GATE." | ||
| (documentation 'gate-name 'function) | ||
| "Name of a GATE. SETFable.") | ||
|
|
||
| (defmethod print-object ((gate gate) stream) | ||
| (print-unreadable-object (gate stream :type t :identity t) | ||
| (format stream "~@[~S ~]~((~A)~)" | ||
| (gate-name gate) | ||
| (gate-state gate)))) | ||
|
|
||
| (defun make-gate (&key name open) | ||
| "Makes a new gate. Gate will be initially open if OPEN is true, and closed if OPEN | ||
| is NIL (the default.) NAME, if provided, is the name of the gate, used when printing | ||
| the gate." | ||
| (flet ((generate-name (thing) | ||
| (when name | ||
| (format nil "gate ~S's ~A" name thing)))) | ||
| (%make-gate | ||
| :name name | ||
| :mutex (make-mutex :name (generate-name "lock")) | ||
| :queue (make-waitqueue :name (generate-name "condition variable")) | ||
| :state (if open :open :closed)))) | ||
|
|
||
| (defun open-gate (gate) | ||
| "Opens GATE. Returns T if the gate was previously closed, and NIL | ||
| if the gate was already open." | ||
| (declare (gate gate)) | ||
| (let (closed) | ||
| (with-mutex ((gate-mutex gate)) | ||
| (sb-sys:without-interrupts | ||
| (setf closed (eq :closed (gate-state gate)) | ||
| (gate-state gate) :open) | ||
| (condition-broadcast (gate-queue gate)))) | ||
| closed)) | ||
|
|
||
| (defun close-gate (gate) | ||
| "Closes GATE. Returns T if the gate was previously open, and NIL | ||
| if the gate was already closed." | ||
| (declare (gate gate)) | ||
| (let (open) | ||
| (with-mutex ((gate-mutex gate)) | ||
| (setf open (eq :open (gate-state gate)) | ||
| (gate-state gate) :closed)) | ||
| open)) | ||
|
|
||
| (defun wait-on-gate (gate &key timeout) | ||
| "Waits for GATE to open, or TIMEOUT seconds to pass. Returns T | ||
| if the gate was opened in time, and NIL otherwise." | ||
| (declare (gate gate)) | ||
| (with-mutex ((gate-mutex gate)) | ||
| (loop until (eq :open (gate-state gate)) | ||
| do (or (condition-wait (gate-queue gate) (gate-mutex gate) | ||
| :timeout timeout) | ||
| (return-from wait-on-gate nil)))) | ||
| t) | ||
|
|
||
| (defun gate-open-p (gate) | ||
| "Returns true if GATE is open." | ||
| (declare (gate gate)) | ||
| (eq :open (gate-state gate))) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,135 @@ | ||
| ;;;; -*- Lisp -*- | ||
| ;;;; | ||
| ;;;; This software is part of the SBCL system. See the README file for | ||
| ;;;; more information. | ||
| ;;;; | ||
| ;;;; This software is derived from the CMU CL system, which was | ||
| ;;;; written at Carnegie Mellon University and released into the | ||
| ;;;; public domain. The software is in the public domain and is | ||
| ;;;; provided with absolutely no warranty. See the COPYING and CREDITS | ||
| ;;;; files for more information. | ||
|
|
||
| (in-package :sb-concurrency-test) | ||
|
|
||
| (deftest gate.0 | ||
| (let ((gate (make-gate :open t))) | ||
| (values (wait-on-gate gate) | ||
| (close-gate gate) | ||
| (wait-on-gate gate :timeout 0.1))) | ||
| t | ||
| t | ||
| nil) | ||
|
|
||
| #+sb-thread | ||
| (progn | ||
| ;; Create threads waiting until a gate is opened, then open that | ||
| ;; gate and assure that all waiters were waked up. Also make sure | ||
| ;; that interrupting a thread waiting on a gate doesn't make it | ||
| ;; cross the gate if it is closed. | ||
| (deftest gate.1 | ||
| (let* ((gate (make-gate)) | ||
| (marks (make-array 100 :initial-element nil)) | ||
| (threads (loop for i from 0 below (length marks) | ||
| collect (make-thread (lambda (n) | ||
| (wait-on-gate gate) | ||
| (setf (aref marks n) (cons n (aref marks n)))) | ||
| :arguments i))) | ||
| (int-gate (make-gate))) | ||
| (sleep 1) | ||
| (interrupt-thread (car threads) (lambda () | ||
| (unwind-protect | ||
| (when (gate-open-p gate) | ||
| (sb-ext:quit)) | ||
| (open-gate int-gate)))) | ||
| (wait-on-gate int-gate) | ||
| (assert (every #'null marks)) | ||
| (open-gate gate) | ||
| (mapc #'join-thread threads) | ||
| (dotimes (i (length marks)) | ||
| (assert (equal (list i) (aref marks i)))) | ||
| t) | ||
| t) | ||
|
|
||
| ;; Assure that CLOSE-GATE can close a gate while other threads are operating | ||
| ;; through that gate. In particular, assure that no operation is performed | ||
| ;; once the gate is closed. | ||
| (deftest gate.2 | ||
| (let* ((gate (make-gate)) | ||
| (cont (make-gate)) | ||
| (marks (make-array 100 :initial-element nil)) | ||
| (threads (loop for i from 0 below (length marks) | ||
| collect (make-thread (lambda (n) | ||
| (wait-on-gate gate) | ||
| (when (oddp n) | ||
| (sleep 1.0)) | ||
| (wait-on-gate gate) | ||
| (setf (aref marks n) (cons n (aref marks n)))) | ||
| :arguments i)))) | ||
| (open-gate gate) | ||
| (sleep 0.5) | ||
| (close-gate gate) | ||
| (let (odds evens) | ||
| (loop while threads | ||
| do (push (pop threads) evens) | ||
| (push (pop threads) odds)) | ||
| (mapc #'join-thread evens) | ||
| (loop for i from 0 below (length marks) | ||
| do (if (oddp i) | ||
| (assert (not (aref marks i))) | ||
| (assert (equal (list i) (aref marks i))))) | ||
| (open-gate gate) | ||
| (mapc #'join-thread odds) | ||
| (loop for i from 0 below (length marks) | ||
| do (when (oddp i) | ||
| (assert (equal (list i) (aref marks i))))) | ||
| t)) | ||
| t) | ||
|
|
||
| ;; Assures that WAIT-ON-GATE can be interrupted by deadlines. | ||
| (deftest gate-deadline.1 | ||
| (let* ((gate (make-gate)) | ||
| (waiter (make-thread (lambda () | ||
| (block nil | ||
| (handler-bind ((sb-sys:deadline-timeout | ||
| #'(lambda (c) | ||
| (return :deadline)))) | ||
| (sb-sys:with-deadline (:seconds 0.1) | ||
| (wait-on-gate gate)))))))) | ||
| (join-thread waiter)) | ||
| :deadline) | ||
|
|
||
| ;; Assure that WAIT-ON-GATE can be interrupted by deadlines, and resumed from | ||
| ;; the deadline handler. | ||
| (deftest gate-deadline.2 | ||
| (let* ((gate (make-gate)) | ||
| (ready (make-gate)) | ||
| (cancel nil) | ||
| (waiter (make-thread (lambda () | ||
| (block nil | ||
| (handler-bind ((sb-sys:deadline-timeout | ||
| #'(lambda (c) | ||
| (setf cancel t) | ||
| (sb-sys:cancel-deadline c)))) | ||
| (sb-sys:with-deadline (:seconds 0.1) | ||
| (open-gate ready) | ||
| (wait-on-gate gate)))))))) | ||
| (wait-on-gate ready) | ||
| (sleep 1.0) | ||
| (open-gate gate) | ||
| (values (join-thread waiter) cancel)) | ||
| t t) | ||
|
|
||
| (deftest gate-timeout.1 | ||
| (let* ((gate (make-gate)) | ||
| (waiter (make-thread (lambda () | ||
| (wait-on-gate gate :timeout 0.1))))) | ||
| (join-thread waiter)) | ||
| nil) | ||
|
|
||
| (deftest gate-timeout.2 | ||
| (let* ((gate (make-gate)) | ||
| (waiter (make-thread (lambda () | ||
| (open-gate gate) | ||
| (wait-on-gate gate :timeout 0.1))))) | ||
| (join-thread waiter)) | ||
| t)) |
Oops, something went wrong.