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
+
|