From 085501b44cc1cbdd9e260139d30b383372ddd1b8 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sat, 7 Apr 2007 13:58:57 +0000 Subject: [PATCH] 1.0.4.39: get rid of hardcoded mutex and spinlock slot indexes * DEFINE-STRUCTURE-SLOT-COMPARE-AND-EXCHANGE can be used to define nice wrappers for %INSTANCE-SLOT-CONDITIONAL using just the structure and slot name. Note to self: it would probably make sense to give something along these lines for users to use as well, so that they can implement lockless algorithms in lisp. * DEFINE-STRUCTURE-SLOT-ADDRESSOR does the same for getting the slot address. * SB-PCL::GET-STRUCTURE-DD moved to host and renamed SB-KERNEL:FIND-DEFSTRUCT-DESCRIPTION. * SB-THREAD now uses SB-KERNEL. (threads.impure.lisp currently fail, but not due to this) --- package-data-list.lisp-expr | 8 +++- src/code/defstruct.lisp | 53 ++++++++++++++++++++++++ src/code/target-defstruct.lisp | 1 + src/code/target-thread.lisp | 89 +++++++++++++++++++--------------------- src/pcl/env.lisp | 4 +- src/pcl/low.lisp | 11 ++--- src/pcl/std-class.lisp | 3 +- version.lisp-expr | 2 +- 8 files changed, 113 insertions(+), 58 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index f4c0ad6..8645a54 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1232,6 +1232,8 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "DECODE-DOUBLE-FLOAT" #!+long-float "DECODE-LONG-FLOAT" "DECODE-SINGLE-FLOAT" + "DEFINE-STRUCTURE-SLOT-ADDRESSOR" + "DEFINE-STRUCTURE-SLOT-COMPARE-AND-EXCHANGE" "DEFINED-FTYPE-MATCHES-DECLARED-FTYPE-P" "!DEFSTRUCT-WITH-ALTERNATE-METACLASS" "DESCEND-INTO" "DISPLACED-TO-ARRAY-TOO-SMALL-ERROR" @@ -1244,7 +1246,9 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "EXTENDED-CHAR-P" "FAILED-%WITH-ARRAY-DATA" "FDEFINITION-OBJECT" "FDOCUMENTATION" "FILENAME" - "FIND-AND-INIT-OR-CHECK-LAYOUT" "FLOAT-EXPONENT" + "FIND-AND-INIT-OR-CHECK-LAYOUT" + "FIND-DEFSTRUCT-DESCRIPTION" + "FLOAT-EXPONENT" "FLOAT-FORMAT-DIGITS" "FLOAT-FORMAT-NAME" "FLOAT-FORMAT-MAX" "FLOAT-INT-EXPONENT" "FLOATING-POINT-EXCEPTION" "FORM" "FORMAT-CONTROL" @@ -1637,7 +1641,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." #s(sb-cold:package-data :name "SB!THREAD" - :use ("CL" "SB!ALIEN" "SB!INT" "SB!SYS") + :use ("CL" "SB!ALIEN" "SB!INT" "SB!SYS" "SB!KERNEL") :doc "public (but low-level): native thread support" :export ("*CURRENT-THREAD*" "THREAD" "MAKE-THREAD" "THREAD-NAME" "THREAD-ALIVE-P" diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index a3dbf1e..e4f6fb2 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -1725,4 +1725,57 @@ (inherits (inherits-for-structure dd))) (%compiler-defstruct dd inherits))) +;;; finding these beasts +(defun find-defstruct-description (name &optional (errorp t)) + (let ((info (layout-info (classoid-layout (find-classoid name errorp))))) + (if (defstruct-description-p info) + info + (when errorp + (error "No DEFSTRUCT-DESCRIPTION for ~S." name))))) + +(defun structure-slot-index (type slot-name &optional (errorp t)) + (let ((slotd (find slot-name + (dd-slots (find-defstruct-description type)) + :key #'dsd-name))) + (if slotd + (dsd-index slotd) + (when errorp + (error "No slot named ~S in ~S." slot-name type))))) + +;;; Used internally, but it would be nice to provide something +;;; like this for users as well. +#!+sb-thread +(defmacro define-structure-slot-compare-and-exchange + (name &key structure slot) + (let* ((dd (find-defstruct-description structure t)) + (slotd (when dd (find slot (dd-slots dd) :key #'dsd-name))) + (type (when slotd (dsd-type slotd))) + (index (when slotd (dsd-index slotd)))) + (unless index + (error "Slot ~S not found in ~S." slot structure)) + `(progn + (declaim (inline ,name)) + (defun ,name (instance old new) + (declare (type ,structure instance) + (type ,type new)) + (sb!vm::%instance-set-conditional instance ,index old new))))) + +;;; Ditto +#!+sb-thread +(defmacro define-structure-slot-addressor (name &key structure slot) + (let* ((dd (find-defstruct-description structure t)) + (slotd (when dd (find slot (dd-slots dd) :key #'dsd-name))) + (index (when slotd (dsd-index slotd)))) + (unless index + (error "Slot ~S not found in ~S." slot structure)) + `(progn + (declaim (inline ,name)) + (defun ,name (instance) + (declare (type ,structure instance) (optimize speed)) + (sb!ext:truly-the + sb!vm:word + (+ (sb!kernel:get-lisp-obj-address instance) + (- (* ,(+ sb!vm:instance-slots-offset index) sb!vm:n-word-bytes) + sb!vm:instance-pointer-lowtag))))))) + (/show0 "code/defstruct.lisp end of file") diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp index 810ebce..d41ff7a 100644 --- a/src/code/target-defstruct.lisp +++ b/src/code/target-defstruct.lisp @@ -601,5 +601,6 @@ :datum x :expected-type (classoid-name (layout-classoid layout)))) (values)) + (/show0 "target-defstruct.lisp end of file") diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 513acf6..c719833 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -19,7 +19,7 @@ ;;; set the doc here because in early-thread FDOCUMENTATION is not ;;; available, yet #!+sb-doc -(setf (sb!kernel:fdocumentation '*current-thread* 'variable) +(setf (fdocumentation '*current-thread* 'variable) "Bound in each thread to the thread itself.") (defstruct (thread (:constructor %make-thread)) @@ -35,7 +35,7 @@ in future versions." (result-lock (make-mutex :name "thread result lock"))) #!+sb-doc -(setf (sb!kernel:fdocumentation 'thread-name 'function) +(setf (fdocumentation 'thread-name 'function) "The name of the thread. Setfable.") (def!method print-object ((thread thread) stream) @@ -143,7 +143,7 @@ in future versions." (defmacro with-lutex-address ((name lutex) &body body) `(let ((,name ,lutex)) (with-pinned-objects (,name) - (let ((,name (sb!kernel:get-lisp-obj-address ,name))) + (let ((,name (get-lisp-obj-address ,name))) ,@body)))) (defun make-lutex () @@ -182,31 +182,33 @@ in future versions." (sb!vm::current-thread-offset-sap n)) ;;;; spinlocks +#!+sb-thread +(define-structure-slot-compare-and-exchange + compare-and-exchange-spinlock-value + :structure spinlock + :slot value) (declaim (inline get-spinlock release-spinlock)) -;;; The bare 2 here and below are offsets of the slots in the struct. -;;; There ought to be some better way to get these numbers (defun get-spinlock (spinlock) (declare (optimize (speed 3) (safety 0)) #!-sb-thread - (ignore spinlock new-value)) + (ignore spinlock)) ;; %instance-set-conditional can test for 0 (which is a fixnum) and ;; store any value #!+sb-thread - (loop until - (eql (sb!vm::%instance-set-conditional spinlock 2 0 1) 0)) + (compare-and-exchange-spinlock-value spinlock 0 1) t) (defun release-spinlock (spinlock) (declare (optimize (speed 3) (safety 0)) #!-sb-thread (ignore spinlock)) ;; %instance-set-conditional cannot compare arbitrary objects - ;; meaningfully, so - ;; (sb!vm::%instance-set-conditional spinlock 2 our-value 0) + ;; meaningfully, so (compare-and-exchange-spinlock-value our-value 0) ;; does not work for bignum thread ids. #!+sb-thread - (sb!vm::%instance-set spinlock 2 0)) + (setf (spinlock-value spinlock) 0) + nil) (defmacro with-spinlock ((spinlock) &body body) (sb!int:with-unique-names (lock got-it) @@ -222,28 +224,28 @@ in future versions." ;;;; mutexes #!+sb-doc -(setf (sb!kernel:fdocumentation 'make-mutex 'function) +(setf (fdocumentation 'make-mutex 'function) "Create a mutex." - (sb!kernel:fdocumentation 'mutex-name 'function) + (fdocumentation 'mutex-name 'function) "The name of the mutex. Setfable." - (sb!kernel:fdocumentation 'mutex-value 'function) + (fdocumentation 'mutex-value 'function) "The value of the mutex. NIL if the mutex is free. Setfable.") #!+(and sb-thread (not sb-lutex)) (progn - (declaim (inline mutex-value-address)) - (defun mutex-value-address (mutex) - (declare (optimize (speed 3))) - (sb!ext:truly-the - sb!vm:word - (+ (sb!kernel:get-lisp-obj-address mutex) - (- (* 3 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag))))) + (define-structure-slot-addressor mutex-value-address + :structure mutex + :slot value) + (define-structure-slot-compare-and-exchange + compare-and-exchange-mutex-value + :structure mutex + :slot value)) (defun get-mutex (mutex &optional (new-value *current-thread*) (wait-p t)) #!+sb-doc "Acquire MUTEX, setting it to NEW-VALUE or some suitable default -value if NIL. If WAIT-P is non-NIL and the mutex is in use, sleep -until it is available" +value if NIL. If WAIT-P is non-NIL and the mutex is in use, sleep +until it is available." (declare (type mutex mutex) (optimize (speed 3))) (/show0 "Entering GET-MUTEX") (unless new-value @@ -273,13 +275,13 @@ until it is available" (let (old) (loop (unless - (setf old (sb!vm::%instance-set-conditional mutex 2 nil - new-value)) + (setf old + (compare-and-exchange-mutex-value mutex nil new-value)) (return t)) (unless wait-p (return nil)) (with-pinned-objects (mutex old) (futex-wait (mutex-value-address mutex) - (sb!kernel:get-lisp-obj-address old))))))) + (get-lisp-obj-address old))))))) (defun release-mutex (mutex) #!+sb-doc @@ -313,18 +315,13 @@ this mutex." (%make-waitqueue :name name)) #!+sb-doc -(setf (sb!kernel:fdocumentation 'waitqueue-name 'function) +(setf (fdocumentation 'waitqueue-name 'function) "The name of the waitqueue. Setfable.") #!+(and sb-thread (not sb-lutex)) -(progn - (declaim (inline waitqueue-data-address)) - (defun waitqueue-data-address (waitqueue) - (declare (optimize (speed 3))) - (sb!ext:truly-the - sb!vm:word - (+ (sb!kernel:get-lisp-obj-address waitqueue) - (- (* 3 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag))))) +(define-structure-slot-addressor waitqueue-data-address + :structure waitqueue + :slot data) (defun condition-wait (queue mutex) #!+sb-doc @@ -358,7 +355,7 @@ time we reacquire MUTEX and return to the caller." ;; Ergo, no lost wakeup (with-pinned-objects (queue me) (futex-wait (waitqueue-data-address queue) - (sb!kernel:get-lisp-obj-address me)))) + (get-lisp-obj-address me)))) ;; If we are interrupted while waiting, we should do these things ;; before returning. Ideally, in the case of an unhandled signal, ;; we should do them before entering the debugger, but this is @@ -414,7 +411,7 @@ time we reacquire MUTEX and return to the caller." "Create a semaphore with the supplied COUNT." (%make-semaphore :name name :count count)) -(setf (sb!kernel:fdocumentation 'semaphore-name 'function) +(setf (fdocumentation 'semaphore-name 'function) "The name of the semaphore. Setfable.") (defun wait-on-semaphore (sem) @@ -633,9 +630,9 @@ around and can be retrieved by JOIN-THREAD." ;; least accessible to users to secure their own libraries. ;; --njf, 2006-07-15 (let ((*current-thread* thread) - (sb!kernel::*restart-clusters* nil) - (sb!kernel::*handler-clusters* nil) - (sb!kernel::*condition-restarts* nil) + (*restart-clusters* nil) + (*handler-clusters* nil) + (*condition-restarts* nil) (sb!impl::*step-out* nil) ;; internal printer variables (sb!impl::*previous-case* nil) @@ -679,7 +676,7 @@ around and can be retrieved by JOIN-THREAD." (with-pinned-objects (initial-function) (let ((os-thread (%create-thread - (sb!kernel:get-lisp-obj-address initial-function)))) + (get-lisp-obj-address initial-function)))) (when (zerop os-thread) (error "Can't create a new thread")) (wait-on-semaphore setup-sem) @@ -695,7 +692,7 @@ around and can be retrieved by JOIN-THREAD." (join-thread-error-thread c))))) #!+sb-doc -(setf (sb!kernel:fdocumentation 'join-thread-error-thread 'function) +(setf (fdocumentation 'join-thread-error-thread 'function) "The thread that we failed to join.") (defun join-thread (thread &key (default nil defaultp)) @@ -725,7 +722,7 @@ return DEFAULT if given or else signal JOIN-THREAD-ERROR." (interrupt-thread-error-thread c))))) #!+sb-doc -(setf (sb!kernel:fdocumentation 'interrupt-thread-error-thread 'function) +(setf (fdocumentation 'interrupt-thread-error-thread 'function) "The thread that was not interrupted.") (defmacro with-interruptions-lock ((thread) &body body) @@ -805,7 +802,7 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated" (* sb!vm:n-word-bytes index)))) (if (eql tl-val sb!vm::no-tls-value-marker-widetag) (sb!vm::symbol-global-value symbol) - (sb!kernel:make-lisp-obj tl-val)))) + (make-lisp-obj tl-val)))) (defun sb!vm::locked-symbol-global-value-add (symbol-name delta) (sb!vm::locked-symbol-global-value-add symbol-name delta)) @@ -813,11 +810,11 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated" ;;; Stepping (defun thread-stepping () - (sb!kernel:make-lisp-obj + (make-lisp-obj (sap-ref-word (current-thread-sap) (* sb!vm::thread-stepping-slot sb!vm:n-word-bytes)))) (defun (setf thread-stepping) (value) (setf (sap-ref-word (current-thread-sap) (* sb!vm::thread-stepping-slot sb!vm:n-word-bytes)) - (sb!kernel:get-lisp-obj-address value))) + (get-lisp-obj-address value))) diff --git a/src/pcl/env.lisp b/src/pcl/env.lisp index eba61b2..0a63836 100644 --- a/src/pcl/env.lisp +++ b/src/pcl/env.lisp @@ -170,7 +170,9 @@ (let ((value (slot-value-using-class class object slot))) (if (typep object 'structure-object) ;; low-level but less noisy initializer form - (let* ((dd (get-structure-dd (class-name class))) + ;; FIXME: why not go class->layout->info == dd? + (let* ((dd (find-defstruct-description + (class-name class))) (dsd (find slot-name (dd-slots dd) :key #'dsd-name))) (inits `(,(slot-setter-lambda-form dd dsd) diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp index 2025da8..4ace205 100644 --- a/src/pcl/low.lisp +++ b/src/pcl/low.lisp @@ -305,11 +305,8 @@ ;;; The definition of STRUCTURE-TYPE-P was moved to early-low.lisp. -(defun get-structure-dd (type) - (layout-info (classoid-layout (find-classoid type)))) - (defun structure-type-included-type-name (type) - (let ((include (dd-include (get-structure-dd type)))) + (let ((include (dd-include (find-defstruct-description type)))) (if (consp include) (car include) include))) @@ -317,8 +314,8 @@ (defun structure-type-slot-description-list (type) (nthcdr (length (let ((include (structure-type-included-type-name type))) (and include - (dd-slots (get-structure-dd include))))) - (dd-slots (get-structure-dd type)))) + (dd-slots (find-defstruct-description include))))) + (dd-slots (find-defstruct-description type)))) (defun structure-slotd-name (slotd) (dsd-name slotd)) @@ -331,7 +328,7 @@ (defun structure-slotd-writer-function (type slotd) (if (dsd-read-only slotd) - (let ((dd (get-structure-dd type))) + (let ((dd (find-defstruct-description type))) (coerce (slot-setter-lambda-form dd slotd) 'function)) (fdefinition `(setf ,(dsd-accessor-name slotd))))) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index e01d9a8..6b09912 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -617,7 +617,8 @@ (values defstruct-form constructor reader-names writer-names))) (defun make-defstruct-allocation-function (class) - (let ((dd (get-structure-dd (class-name class)))) + ;; FIXME: Why don't we go class->layout->info == dd + (let ((dd (find-defstruct-description (class-name class)))) (lambda () (sb-kernel::%make-instance-with-layout (sb-kernel::compiler-layout-or-lose (dd-name dd)))))) diff --git a/version.lisp-expr b/version.lisp-expr index 8c8ff16..b1e1205 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.4.38" +"1.0.4.39" -- 1.7.10.4