Menu
▾
▴
[Sbcl-commits] master: Threadsafe FIND-OR-CREATE-FDEFINITION.
|
From: Douglas K. <sn...@us...> - 2014-03-31 23:55:46
|
The branch "master" has been updated in SBCL:
via d62e48856c70e1cb44ac8770387e6ac03699a432 (commit)
from 8e4105e1a7b2853d797c024b402bb7279d2f6d54 (commit)
- Log -----------------------------------------------------------------
commit d62e48856c70e1cb44ac8770387e6ac03699a432
Author: Douglas Katzman <do...@go...>
Date: Mon Mar 31 19:50:42 2014 -0400
Threadsafe FIND-OR-CREATE-FDEFINITION.
---
package-data-list.lisp-expr | 5 +-
src/code/class.lisp | 4 +-
src/code/fdefinition.lisp | 8 ++--
src/compiler/globaldb.lisp | 32 +++++++++---
src/compiler/info-vector.lisp | 99 ++++++++++++++++++-------------------
tests/info.impure.lisp | 107 +++++++++++++++++++++++++++++++++++++++++
6 files changed, 187 insertions(+), 68 deletions(-)
diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 4baac94..741ee93 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -947,10 +947,9 @@ possibly temporarily, because it might be used internally."
;; should be able to change it without apology.
"*INFO-ENVIRONMENT*"
"CLEAR-INFO"
- "COMPACT-INFO-ENVIRONMENT"
- "DEFINE-INFO-CLASS" "DEFINE-INFO-TYPE"
- "DO-INFO"
+ "DEFINE-INFO-TYPE"
"INFO"
+ "GET-INFO-VALUE-INITIALIZING"
"UPDATE-SYMBOL-INFO"
"MAKE-INFO-ENVIRONMENT"
"FIND-FDEFINITION"
diff --git a/src/code/class.lisp b/src/code/class.lisp
index f977186..47765e4 100644
--- a/src/code/class.lisp
+++ b/src/code/class.lisp
@@ -713,8 +713,8 @@
(let ((real-name (uncross name)))
(cond ((info :type :classoid-cell real-name))
(create
- (sb!c::atomically-get-or-put-symbol-info
- :type :classoid-cell real-name (make-classoid-cell real-name))))))
+ (get-info-value-initializing :type :classoid-cell real-name
+ (make-classoid-cell real-name))))))
(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
diff --git a/src/code/fdefinition.lisp b/src/code/fdefinition.lisp
index db3b296..c24f354 100644
--- a/src/code/fdefinition.lisp
+++ b/src/code/fdefinition.lisp
@@ -65,14 +65,14 @@
(find-or-create-fdefinition name)
(find-fdefinition name)))
+(declaim (ftype (sfunction (t) fdefn) find-or-create-fdefinition))
(defun find-or-create-fdefinition (name)
- ;; Why can't the compiler derive (OR (OR FDEFN NULL) FDEFN) = FDEFN ?
- (declare (values fdefn))
(or (find-fdefinition name)
;; If the name was not legal, FIND-FDEFINITION signals an error,
;; so there is no additional pre-creation check.
- ;; Also FIXME: slight race. No worse than it was though.
- (setf (info :function :definition name) (make-fdefn name))))
+ (let ((name (uncross name)))
+ (get-info-value-initializing :function :definition name
+ (make-fdefn name)))))
(defun maybe-clobber-ftype (name)
(unless (eq :declared (info :function :where-from name))
diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp
index 44a1a2f..34006cf 100644
--- a/src/compiler/globaldb.lisp
+++ b/src/compiler/globaldb.lisp
@@ -163,7 +163,7 @@
(validate-function nil :type (or function null)))
(declaim (freeze-type type-info))
-(defconstant +info-metainfo-type-num+ 63)
+(defconstant +info-metainfo-type-num+ 0)
;; Perform the equivalent of (GET-INFO-VALUE sym +INFO-METAINFO-TYPE-NUM+)
;; but without the AVER that metadata already exists, and bypassing the
@@ -183,14 +183,10 @@
(let ((metainfo (find-type-info class-keyword type-keyword)))
(cond (metainfo) ; Do absolutely positively nothing.
(t
- (when (eql type-num -1)
- ;; The zeroth type is reserved as a tombstone to allow deletion
- ;; from a compact info environment, and 63 is reserved to support
- ;; the implementation of INFO itself without DEFINE-INFO-TYPE
- ;; having claimed a type-num for the machinery's private use.
+ (when (eql type-num -1) ; pick a new type-num
+ ;; The zeroth type-num is reserved for INFO's own private use.
(setq type-num
- (or (position nil *info-types*
- :start 1 :end +info-metainfo-type-num+)
+ (or (position nil *info-types* :start 1)
(error "no more INFO type numbers available"))))
(setf metainfo (make-globaldb-info-metadata
type-num class-keyword type-keyword type-spec)
@@ -392,6 +388,26 @@
(let ((val (type-info-default metainfo)))
(values (if (functionp val) (funcall val name) val) nil))))
+;; Perform the approximate equivalent operations of retrieving
+;; (INFO :CLASS :TYPE NAME), but if no info is found, invoke CREATION-FORM
+;; to produce an object that becomes the value for that piece of info, storing
+;; and returning it. The entire sequence behaves atomically but with a proviso:
+;; the creation form's result may be discarded, and another object returned
+;; instead (presumably) from another thread's execution of the creation form.
+;; If constructing the object has either non-trivial cost, or deleterious
+;; side-effects from making and discarding its result, do NOT use this macro.
+;; A mutex-guarded table would probably be more appropriate in such cases.
+;;
+(def!macro get-info-value-initializing (info-class info-type name creation-form)
+ (with-unique-names (type-number proc)
+ `(let ((,type-number
+ ,(if (and (keywordp info-type) (keywordp info-class))
+ (type-info-number (type-info-or-lose info-class info-type))
+ `(type-info-number
+ (type-info-or-lose ,info-class ,info-type)))))
+ (dx-flet ((,proc () ,creation-form))
+ (%get-info-value-initializing ,name ,type-number #',proc)))))
+
;; Return the fdefn object for NAME, or NIL if there is no fdefn.
;; Signal an error if name isn't valid.
;; Trying to get this to work properly in file 'fdefinition.lisp'
diff --git a/src/compiler/info-vector.lisp b/src/compiler/info-vector.lisp
index a1e707e..6a1223d 100644
--- a/src/compiler/info-vector.lisp
+++ b/src/compiler/info-vector.lisp
@@ -1044,52 +1044,6 @@ This is interpreted as
;; The KEYs remain bound, but they should not be used for anything.
,hairy))))
-;; Perform the approximate equivalent operations of retrieving
-;; (INFO :class :type <name>), but if no info is found, invoke CREATION-FORM
-;; to produce an object that becomes the value for that piece of info,
-;; returning it. The entire sequence behaves atomically with the following
-;; proviso: the creation form's result may be discarded, and another object
-;; returned instead (presumably) from another thread's execution
-;; of that same creation form.
-;;
-;; If constructing the object has either non-trivial cost, or deleterious
-;; side-effects from making and discarding its result, do NOT use this macro.
-;; A mutex-guarded table would probably be more appropriate in such cases.
-;;
-;; INFO-CLASS and -TYPE must be keywords, and NAME must evaluate
-;; to a symbol. [Eventually this will accept generalized names]
-;;
-;; FIXME: these does not really seem to belong in SB-C, but that's where
-;; all the other info stuff is. Maybe SB-INT ?
-;;
-(defmacro atomically-get-or-put-symbol-info
- (info-class info-type name creation-form)
- (let ((type-num (type-info-number
- (type-info-or-lose info-class info-type)))
- (aux-key +no-auxilliary-key+))
- (with-unique-names (proc info-vect index result)
- ;; Concurrent globaldb updates (possibly for unrelated info)
- ;; can force re-execution of this flet, so try to create an
- ;; object one time only, and remember that we did that.
- ;; If CREATION-FORM returns nil - which it shouldn't - the
- ;; form couldbe repeatedly invoked, because there's no
- ;; local state variable such as invoked-creation-form-p.
- `(let (,result)
- (dx-flet ((,proc (,info-vect)
- ;; pre-check
- (let ((,index (packed-info-value-index
- ,info-vect ,aux-key ,type-num)))
- (cond (,index
- (setq ,result (svref ,info-vect ,index))
- nil) ; no update to symbol-info-vector
- (t
- (unless ,result
- (setq ,result ,creation-form))
- (packed-info-insert
- ,info-vect ,aux-key ,type-num ,result))))))
- (update-symbol-info ,name #',proc)
- ,result)))))
-
;; Given Info-Vector VECT, return the fdefn that it contains for its root name,
;; or nil if there is no value. NIL input is acceptable and will return NIL.
(declaim (inline info-vector-fdefinition))
@@ -1192,13 +1146,56 @@ This is interpreted as
(with-globaldb-name (key1 key2) name
:simple
;; UPDATE-SYMBOL-INFO never supplies OLD-INFO as NIL.
- (dx-flet ((update-simple-name (old-info)
- (augment old-info key2)))
- (update-symbol-info key1 #'update-simple-name))
+ (dx-flet ((simple-name (old-info) (augment old-info key2)))
+ (update-symbol-info key1 #'simple-name))
:hairy
;; INFO-PUTHASH supplies NIL for OLD-INFO if NAME was absent.
- (dx-flet ((update-hairy-name (old-info)
+ (dx-flet ((hairy-name (old-info)
(augment (or old-info +nil-packed-infos+)
+no-auxilliary-key+)))
- (info-puthash *info-environment* name #'update-hairy-name)))))
+ (info-puthash *info-environment* name #'hairy-name)))))
new-value)
+
+;; %GET-INFO-VALUE-INITIALIZING is provided as a low-level operation similar
+;; to the above because it does not require info metadata for defaulting,
+;; nor deal with the keyword-based info type designators at all.
+;; In contrast, GET-INFO-VALUE requires metadata.
+;; For this operation to make sense, the objects produced should be permanently
+;; assigned to their name, such as are fdefns and classoid-cells.
+;; Note also that we do not do an initial attempt to read once with INFO,
+;; followed up by a double-checking get-or-set operation. It is assumed that
+;; the user of this already did an initial check, if such is warranted.
+(defun %get-info-value-initializing (name type-number creation-thunk)
+ (when (typep name 'fixnum)
+ (error "~D is not a legal INFO name." name))
+ (let ((name (uncross name))
+ result)
+ (dx-flet ((get-or-set (info-vect aux-key)
+ (let ((index
+ (packed-info-value-index info-vect aux-key type-number)))
+ (cond (index
+ (setq result (svref info-vect index))
+ nil) ; no update to info-vector
+ (t
+ ;; Update conflicts possibly for unrelated type-number
+ ;; can force re-execution. (UNLESS result ...) tries
+ ;; to avoid calling the thunk more than once.
+ (unless result
+ (setq result (funcall creation-thunk)))
+ (packed-info-insert info-vect aux-key type-number
+ result))))))
+ (with-globaldb-name (key1 key2) name
+ :simple
+ ;; UPDATE-SYMBOL-INFO never supplies OLD-INFO as NIL.
+ (dx-flet ((simple-name (old-info) (get-or-set old-info key2)))
+ (update-symbol-info key1 #'simple-name))
+ :hairy
+ ;; INFO-PUTHASH supplies NIL for OLD-INFO if NAME was absent.
+ (dx-flet ((hairy-name (old-info)
+ (or (get-or-set (or old-info +nil-packed-infos+)
+ +no-auxilliary-key+)
+ ;; Return OLD-INFO to elide writeback. Unlike for
+ ;; UPDATE-SYMBOL-INFO, NIL is not a no-op marker.
+ old-info)))
+ (info-puthash *info-environment* name #'hairy-name))))
+ result))
diff --git a/tests/info.impure.lisp b/tests/info.impure.lisp
index 50d9266..3872917 100644
--- a/tests/info.impure.lisp
+++ b/tests/info.impure.lisp
@@ -441,4 +441,111 @@
(aref *make-classoid-cell-callcount* 0)
(length symbols)))))
+;;; test %GET-INFO-VALUE-INITIALIZING using generalized function names
+
+(defun be-an-fdefn-reader (names)
+ (declare (simple-vector names))
+ (let ((result (make-array (length names) :initial-element nil)))
+ (dotimes (iter 3)
+ (loop for i below (length names)
+ do (pushnew (find-fdefinition (aref names i)) (aref result i))))
+ ;; The thread shall observe either nil or an fdefn, and at most one fdefn.
+ (loop for list across result
+ for i from 0
+ do (let ((observed-value (remove nil list)))
+ (if (cdr observed-value)
+ (error "Should not happen: fdefn => ~S" list)
+ (setf (aref result i) (car observed-value)))))
+ result))
+
+(defun be-an-fdefn-writer (names)
+ (declare (simple-vector names))
+ (let ((fdefn-result (make-array (length names) :initial-element nil))
+ (random-result (make-array (length names) :initial-element nil))
+ (n-created 0)
+ (highest-type-num
+ (position-if #'identity sb-c::*info-types* :from-end t)))
+ (loop for name across names
+ for i from 0
+ do (setf (aref fdefn-result i)
+ (get-info-value-initializing
+ :function :definition name
+ (progn (incf n-created) (make-fdefn name))))
+ (dotimes (i (random 3))
+ ;; Set random info for other names to cause CAS failures.
+ ;; Pick an info-type number and give it a random value.
+ ;; Store the random value so that we can assert on it later.
+ ;; Never touch reserved type numbers 0 or 1.
+ (let ((random-name-index (random (length names)))
+ (random-type (+ (random (1- highest-type-num)) 2))
+ (random-value (random most-positive-fixnum)))
+ (push (cons random-type random-value)
+ (aref random-result random-name-index))
+ (sb-c::set-info-value (aref names random-name-index)
+ random-type random-value))))
+ (values n-created fdefn-result random-result)))
+
+(test-util:with-test (:name :get-info-value-initializing
+ :skipped-on (not :sb-thread))
+ ;; Precompute random generalized function names for testing, some of which
+ ;; are "simple" (per the taxonomy of globaldb) and some hairy.
+ (let ((work (coerce (loop repeat 10000
+ nconc (list `(sb-pcl::ctor ,(gensym) ,(gensym))
+ `(defmacro ,(gensym)) ; simple name
+ (gensym))) ; very simple name
+ 'vector))
+ (n-threads 10) readers writers fdefn-results random-results)
+ (dotimes (i (ash n-threads -1))
+ (push (sb-thread:make-thread
+ #'be-an-fdefn-writer :arguments (list work)
+ :name (write-to-string i)) writers))
+ (dotimes (i (ash n-threads -1))
+ (push (sb-thread:make-thread #'be-an-fdefn-reader :arguments (list work))
+ readers))
+ (dolist (thread readers)
+ (push (sb-thread:join-thread thread) fdefn-results))
+ (let ((tot 0))
+ (dolist (thread writers)
+ (multiple-value-bind (n-created fdefn-result random-result)
+ (sb-thread:join-thread thread)
+ (incf tot n-created)
+ (format t "~5D fdefns from ~A~%" n-created
+ (sb-thread:thread-name thread))
+ (push fdefn-result fdefn-results)
+ (push random-result random-results)))
+ (format t "~5D total~%" tot))
+ (let ((aggregate (make-array n-threads)))
+ (dotimes (name-index (length work))
+ (dotimes (thread-num n-threads)
+ (setf (aref aggregate thread-num)
+ (aref (nth thread-num fdefn-results) name-index)))
+ ;; some thread should have observed an fdefn
+ (let ((representative (find-if-not #'null aggregate)))
+ ;; For each thread which observed an fdefn,
+ ;; assert that the cell is EQ to the representative.
+ (dotimes (thread-num n-threads)
+ (awhen (aref aggregate thread-num)
+ (assert (eq it representative)))))))
+ ;; For each name and each info type number that some thread inserted,
+ ;; verify that the info-value is among the set of random values.
+ (dotimes (name-index (length work))
+ (dotimes (type-num 64)
+ ;; some thread says that TYPE-NUM exists for NAME-INDEX
+ (when (some (lambda (output)
+ (assoc type-num (aref output name-index)))
+ random-results)
+ (let ((actual (sb-c::get-info-value (aref work name-index)
+ type-num)))
+ (unless (some (lambda (output)
+ (some (lambda (cell)
+ (and (eq (car cell) type-num)
+ (eql (cdr cell) actual)))
+ (aref output name-index)))
+ random-results)
+ (error "Fail ~S ~S => ~S.~%Choices are ~S"
+ (aref work name-index) type-num actual
+ (mapcar (lambda (output)
+ (aref output name-index))
+ random-results)))))))))
+
;;; success
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|