1.0.7.14: thread-safe INTERN, EXPORT, &co

 * Modifications to packages grab a global lock. INTERN is the only
   real potential performance bottleneck here, but as long as the
   symbol already exists it doesn't need to get the lock.

   We need a global lock instead of a per-package lock because eg.
   (EXPORT 'FOO::BAR :FOO) and (INTERN "BAR" :ZOT) can conflict, even
   though they operate on different packages.

   Since races should be rare we use a spinlock to avoid making a
   system call for every release.

   Interrupt safety? Probably no. It's likely that you can wedge the
   package system into a bad state if you really try.

diff --git a/src/pcl/compiler-support.lisp b/src/pcl/compiler-support.lisp
index 5cc7d3f..f32755b 100644 (file)
--- a/src/pcl/compiler-support.lisp
+++ b/src/pcl/compiler-support.lisp
@@ -98,3 +98,42 @@
   new-value)
 
 (defsetf sb-pcl::random-documentation sb-pcl::set-random-documentation)
+
+;;;; SLOT-VALUE optimizations
+
+(defknown slot-value (t symbol) t (any))
+(defknown sb-pcl::set-slot-value (t symbol t) t (any))
+
+(defun pcl-boot-state-complete-p ()
+  (eq 'sb-pcl::complete sb-pcl::*boot-state*))
+
+;;; These essentially duplicate what the compiler-macros in slots.lisp
+;;; do, but catch more cases. We retain the compiler-macros since they
+;;; can be used during the build, and because they catch common cases
+;;; slightly more cheaply then the transforms. (Transforms add new
+;;; lambdas, which requires more work by the compiler.)
+
+(deftransform slot-value ((object slot-name) * * :important t)
+  "optimize"
+  (let (c-slot-name)
+    (if (and (pcl-boot-state-complete-p)
+             (constant-lvar-p slot-name)
+             (setf c-slot-name (lvar-value slot-name))
+             (sb-pcl::interned-symbol-p c-slot-name))
+        `(sb-pcl::accessor-slot-value object ',c-slot-name)
+        (give-up-ir1-transform "Slot name is not constant."))))
+
+(deftransform sb-pcl::set-slot-value ((object slot-name new-value)
+                                      (t symbol t) t
+                                      :important t
+                                      ;; see comment in the
+                                      ;; compiler-macro
+                                      :policy (< safety 3))
+  "optimize"
+  (let (c-slot-name)
+    (if (and (pcl-boot-state-complete-p)
+             (constant-lvar-p slot-name)
+             (setf c-slot-name (lvar-value slot-name))
+             (sb-pcl::interned-symbol-p c-slot-name))
+        `(sb-pcl::accessor-set-slot-value object ',c-slot-name new-value)
+        (give-up-ir1-transform "Slot name is not constant."))))

diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp
index 8abdb89..6bef614 100644 (file)
--- a/src/pcl/slots-boot.lisp
+++ b/src/pcl/slots-boot.lisp
@@ -56,9 +56,9 @@
     (setf reader-specializers (mapcar #'find-class reader-specializers))
     (setf writer-specializers (mapcar #'find-class writer-specializers))))
 
-(defmacro accessor-slot-value (object slot-name)
-  (aver (constantp slot-name))
-  (let* ((slot-name (constant-form-value slot-name))
+(defmacro accessor-slot-value (object slot-name &environment env)
+  (aver (constantp slot-name env))
+  (let* ((slot-name (constant-form-value slot-name env))
          (reader-name (slot-reader-name slot-name)))
     `(let ((.ignore. (load-time-value
                       (ensure-accessor 'reader ',reader-name ',slot-name))))
@@ -67,14 +67,14 @@
                  (funcall #',reader-name ,object)))))
 
 (defmacro accessor-set-slot-value (object slot-name new-value &environment env)
-  (aver (constantp slot-name))
+  (aver (constantp slot-name env))
   (setq object (macroexpand object env))
-  (setq slot-name (macroexpand slot-name env))
-  (let* ((slot-name (constant-form-value slot-name))
-         (bindings (unless (or (constantp new-value) (atom new-value))
-                     (let ((object-var (gensym)))
-                       (prog1 `((,object-var ,object))
-                         (setq object object-var)))))
+  (let* ((slot-name (constant-form-value slot-name env))
+         (bind-object (unless (or (constantp new-value env) (atom new-value))
+                        (let* ((object-var (gensym))
+                               (bind `((,object-var ,object))))
+                          (setf object object-var)
+                          bind)))
          (writer-name (slot-writer-name slot-name))
          (form
           `(let ((.ignore.
@@ -84,13 +84,13 @@
             (declare (ignore .ignore.))
             (funcall #',writer-name .new-value. ,object)
             .new-value.)))
-    (if bindings
-        `(let ,bindings ,form)
+    (if bind-object
+        `(let ,bind-object ,form)
         form)))
 
-(defmacro accessor-slot-boundp (object slot-name)
-  (aver (constantp slot-name))
-  (let* ((slot-name (constant-form-value slot-name))
+(defmacro accessor-slot-boundp (object slot-name &environment env)
+  (aver (constantp slot-name env))
+  (let* ((slot-name (constant-form-value slot-name env))
          (boundp-name (slot-boundp-name slot-name)))
     `(let ((.ignore. (load-time-value
                       (ensure-accessor 'boundp ',boundp-name ',slot-name))))

diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp
index aade5b2..b9ee309 100644 (file)
--- a/src/pcl/slots.lisp
+++ b/src/pcl/slots.lisp
@@ -88,9 +88,10 @@
         (values (slot-missing class object slot-name 'slot-value))
         (slot-value-using-class class object slot-definition))))
 
-(define-compiler-macro slot-value (&whole form object slot-name)
-  (if (and (constantp slot-name)
-           (interned-symbol-p (constant-form-value slot-name)))
+(define-compiler-macro slot-value (&whole form object slot-name
+                                   &environment env)
+  (if (and (constantp slot-name env)
+           (interned-symbol-p (constant-form-value slot-name env)))
       `(accessor-slot-value ,object ,slot-name)
       form))
 
@@ -111,9 +112,9 @@
   (set-slot-value object slot-name new-value))
 
 (define-compiler-macro set-slot-value (&whole form object slot-name new-value
-                                              &environment env)
-  (if (and (constantp slot-name)
-           (interned-symbol-p (constant-form-value slot-name))
+                                      &environment env)
+  (if (and (constantp slot-name env)
+           (interned-symbol-p (constant-form-value slot-name env))
            ;; We can't use the ACCESSOR-SET-SLOT-VALUE path in safe
            ;; code, since it'll use the global automatically generated
            ;; accessor, which won't do typechecking. (SLOT-OBJECT
@@ -132,9 +133,10 @@
 
 (setf (gdefinition 'slot-boundp-normal) #'slot-boundp)
 
-(define-compiler-macro slot-boundp (&whole form object slot-name)
-  (if (and (constantp slot-name)
-           (interned-symbol-p (constant-form-value slot-name)))
+(define-compiler-macro slot-boundp (&whole form object slot-name
+                                    &environment env)
+  (if (and (constantp slot-name env)
+           (interned-symbol-p (constant-form-value slot-name env)))
       `(accessor-slot-boundp ,object ,slot-name)
       form))
 
@@ -389,3 +391,4 @@
 (defmethod allocate-instance ((class built-in-class) &rest initargs)
   (declare (ignore initargs))
   (error "Cannot allocate an instance of ~S." class)) ; So sayeth AMOP
+

diff --git a/version.lisp-expr b/version.lisp-expr
index 7583589..5ba19b0 100644 (file)
--- 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.7.15"
+"1.0.7.16"