[Sbcl-commits] CVS: sbcl/src/pcl compiler-support.lisp, 1.16, 1.17 slots-boot.lisp, 1.32, 1.33 slots.lisp, 1.26, 1.27

[Nikodemus S. <de...@us...>]

Update of /cvsroot/sbcl/sbcl/src/pcl
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv10321/src/pcl

Modified Files:
	compiler-support.lisp slots-boot.lisp slots.lisp 
Log Message:
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.


Index: compiler-support.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/compiler-support.lisp,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -d -r1.16 -r1.17
--- compiler-support.lisp	2 Dec 2005 22:53:04 -0000	1.16
+++ compiler-support.lisp	12 Jul 2007 17:28:40 -0000	1.17
@@ -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."))))

Index: slots-boot.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/slots-boot.lisp,v
retrieving revision 1.32
retrieving revision 1.33
diff -u -d -r1.32 -r1.33
--- slots-boot.lisp	2 Jun 2007 09:04:16 -0000	1.32
+++ slots-boot.lisp	12 Jul 2007 17:28:40 -0000	1.33
@@ -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))))

Index: slots.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/slots.lisp,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -d -r1.26 -r1.27
--- slots.lisp	7 Nov 2006 10:22:17 -0000	1.26
+++ slots.lisp	12 Jul 2007 17:28:40 -0000	1.27
@@ -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
+