From: Nikodemus S. <de...@us...> - 2007-07-12 17:28:46
|
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 + |