diff --git a/code/x86-vm.lisp b/code/x86-vm.lisp index 46dbf7e61351d63b11118b41eb34c05c75119f43..cf6ca23d850937bf5f451079d9dfc2eda0bbaa59 100644 --- a/code/x86-vm.lisp +++ b/code/x86-vm.lisp @@ -7,12 +7,15 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/x86-vm.lisp,v 1.14 1998/03/21 08:12:06 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/x86-vm.lisp,v 1.15 1999/03/26 15:57:00 dtc Exp $") ;;; ;;; ********************************************************************** ;;; ;;; This file contains the X86 specific runtime stuff. ;;; +;;; Code movement fixups by Douglas T. Crosher, 1997. +;;; Thread support by Douglas T. Crosher, 1999. +;;; (in-package "X86") (use-package "SYSTEM") @@ -453,14 +456,6 @@ ;;; exits. (defvar *alien-stack*) -;;; -(defun kernel::%instance-set-conditional (object slot test-value new-value) - (declare (type instance object) - (type index slot)) - "Atomically compare object's slot value to test-value and if EQ store - new-value in the slot. The original value of the slot is returned." - (kernel::%instance-set-conditional object slot test-value new-value)) - ;;; Support for the MT19937 random number generator. The update ;;; function is implemented as an assembly routine. This definition is ;;; transformed to a call to this routine allowing its use in byte @@ -469,3 +464,112 @@ (defun random-mt19937 (state) (declare (type (simple-array (unsigned-byte 32) (627)) state)) (random-mt19937 state)) + + +;;;; Useful definitions for writing thread safe code. + +(in-package "KERNEL") + +(export '(atomic-push-symbol-value atomic-pop-symbol-value + atomic-pusha atomic-pushd atomic-push-vector)) + +(defun %instance-set-conditional (object slot test-value new-value) + (declare (type instance object) + (type index slot)) + "Atomically compare object's slot value to test-value and if EQ store + new-value in the slot. The original value of the slot is returned." + (%instance-set-conditional object slot test-value new-value)) + +(defun set-symbol-value-conditional (symbol test-value new-value) + (declare (type symbol symbol)) + "Atomically compare symbol's value to test-value and if EQ store + new-value in symbol's value slot and return the original value." + (set-symbol-value-conditional symbol test-value new-value)) + +(defun rplaca-conditional (cons test-value new-value) + (declare (type cons cons)) + "Atomically compare the car of CONS to test-value and if EQ store + new-value its car and return the original value." + (rplaca-conditional cons test-value new-value)) + +(defun rplacd-conditional (cons test-value new-value) + (declare (type cons cons)) + "Atomically compare the cdr of CONS to test-value and if EQ store + new-value its cdr and return the original value." + (rplacd-conditional cons test-value new-value)) + +(defun data-vector-set-conditional (vector index test-value new-value) + (declare (type simple-vector vector)) + "Atomically compare an element of vector to test-value and if EQ store + new-value the element and return the original value." + (data-vector-set-conditional vector index test-value new-value)) + +(defmacro atomic-push-symbol-value (val symbol) + "Thread safe push of val onto the list in the symbol global value." + (ext:once-only ((n-val val)) + (let ((new-list (gensym)) + (old-list (gensym))) + `(let ((,new-list (cons ,n-val nil))) + (loop + (let ((,old-list ,symbol)) + (setf (cdr ,new-list) ,old-list) + (when (eq (set-symbol-value-conditional + ',symbol ,old-list ,new-list) + ,old-list) + (return ,new-list)))))))) + +(defmacro atomic-pop-symbol-value (symbol) + "Thread safe pop from the list in the symbol global value." + (let ((new-list (gensym)) + (old-list (gensym))) + `(loop + (let* ((,old-list ,symbol) + (,new-list (cdr ,old-list))) + (when (eq (set-symbol-value-conditional + ',symbol ,old-list ,new-list) + ,old-list) + (return (car ,old-list))))))) + +(defmacro atomic-pusha (val cons) + "Thread safe push of val onto the list in the car of cons." + (once-only ((n-val val) + (n-cons cons)) + (let ((new-list (gensym)) + (old-list (gensym))) + `(let ((,new-list (cons ,n-val nil))) + (loop + (let ((,old-list (car ,n-cons))) + (setf (cdr ,new-list) ,old-list) + (when (eq (rplaca-conditional ,n-cons ,old-list ,new-list) + ,old-list) + (return ,new-list)))))))) + +(defmacro atomic-pushd (val cons) + "Thread safe push of val onto the list in the cdr of cons." + (once-only ((n-val val) + (n-cons cons)) + (let ((new-list (gensym)) + (old-list (gensym))) + `(let ((,new-list (cons ,n-val nil))) + (loop + (let ((,old-list (cdr ,n-cons))) + (setf (cdr ,new-list) ,old-list) + (when (eq (rplacd-conditional ,n-cons ,old-list ,new-list) + ,old-list) + (return ,new-list)))))))) + +(defmacro atomic-push-vector (val vect index) + "Thread safe push of val onto the list in the vector element." + (once-only ((n-val val) + (n-vect vect) + (n-index index)) + (let ((new-list (gensym)) + (old-list (gensym))) + `(let ((,new-list (cons ,n-val nil))) + (loop + (let ((,old-list (svref ,n-vect ,n-index))) + (setf (cdr ,new-list) ,old-list) + (when (eq (data-vector-set-conditional + ,n-vect ,n-index ,old-list ,new-list) + ,old-list) + (return ,new-list))))))))