From e3932d9a8cf3b8d2272cf75d1c40173af48747be Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Thu, 7 Dec 2006 12:51:25 +0000 Subject: [PATCH] 1.0.0.28: more PCL cleanups * WRAPPER-INSTANCE-SLOTS-LAYOUT and WRAPPER-CLASS-SLOTS are a null layer around corresponding %WRAPPER- accessors: rename the accessors without % and remove the macros. * CACHE-LOCK-COUNT unused, deleted. * WRAPPER-OF-MACRO redundant, removed. Use WRAPPER-OF. * new function MAKE-DFUN-REQUIRED-ARGS to factor out a shared idiom as per FIXME. * WITH-HASH-TABLE and WITH-EQ-HASH-TABLE removed: thread unsafe. * Commentary. --- doc/internals-notes/threading-specials | 3 +- src/pcl/braid.lisp | 12 +-- src/pcl/cache.lisp | 125 +++++++++++++++----------------- src/pcl/combin.lisp | 6 +- src/pcl/dfun.lisp | 18 +---- src/pcl/dlisp.lisp | 2 +- src/pcl/low.lisp | 1 - src/pcl/methods.lisp | 2 +- version.lisp-expr | 2 +- 9 files changed, 69 insertions(+), 102 deletions(-) diff --git a/doc/internals-notes/threading-specials b/doc/internals-notes/threading-specials index 70e6c77..d67db3c 100644 --- a/doc/internals-notes/threading-specials +++ b/doc/internals-notes/threading-specials @@ -142,13 +142,13 @@ potentially unsafe: SB-PCL::*CLASS-EQ-SPECIALIZER-METHODS* SB-PCL::*EFFECTIVE-METHOD-CACHE* SB-PCL::*EQL-SPECIALIZER-METHODS* - SB-PCL::*FREE-HASH-TABLES* SB-PCL::*METHOD-FUNCTION-PLIST* SB-PCL::*PV-KEY-TO-PV-TABLE-TABLE* SB-PCL::*PV-TABLE-CACHE-UPDATE-INFO* SB-PCL::*PVS* SB-PCL::*SLOT-NAME-LISTS-INNER* SB-PCL::*SLOT-NAME-LISTS-OUTER* + SB-PCL::*PREVIOUS-NWRAPPERS* debugging / profiling -- low relevance: SB-PCL::*DFUN-COUNT* @@ -205,7 +205,6 @@ SB-PCL::*OPTIMIZE-SPEED* SB-PCL::*PCL-CLASS-BOOT* SB-PCL::*PCL-LOCK* ; protecting the rest SB-PCL::*PCL-PACKAGE* -SB-PCL::*PREVIOUS-NWRAPPERS* SB-PCL::*RAISE-METATYPES-TO-CLASS-P* SB-PCL::*READERS-FOR-THIS-DEFCLASS* SB-PCL::*REBOUND-EFFECTIVE-METHOD-GENSYMS* diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index 6f956ce..7b00490 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -516,16 +516,12 @@ (cons name cpl) wrapper prototype)))))) -(defmacro wrapper-of-macro (x) - `(layout-of ,x)) - -(defun class-of (x) - (wrapper-class* (wrapper-of-macro x))) - -;;; FIXME: We probably don't need both WRAPPER-OF and WRAPPER-OF-MACRO. #-sb-fluid (declaim (inline wrapper-of)) (defun wrapper-of (x) - (wrapper-of-macro x)) + (layout-of x)) + +(defun class-of (x) + (wrapper-class* (wrapper-of x))) (defun eval-form (form) (lambda () (eval form))) diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp index 5381ad0..73b60fd 100644 --- a/src/pcl/cache.lisp +++ b/src/pcl/cache.lisp @@ -124,14 +124,14 @@ (declare (fixnum old-count)) (setf (cache-vector-lock-count ,cache-vector) (if (= old-count most-positive-fixnum) - 1 + 1 (1+ old-count))))))) (deftype field-type () '(mod #.layout-clos-hash-length)) (eval-when (:compile-toplevel :load-toplevel :execute) - (declaim (ftype (function (fixnum) (values (and unsigned-byte fixnum) &optional)) + (declaim (ftype (function (fixnum) (values (and unsigned-byte fixnum) &optional)) power-of-two-ceiling)) (defun power-of-two-ceiling (x) ;; (expt 2 (ceiling (log x 2))) @@ -161,9 +161,6 @@ (overflow nil :type list)) #-sb-fluid (declaim (sb-ext:freeze-type cache)) - -(defmacro cache-lock-count (cache) - `(cache-vector-lock-count (cache-vector ,cache))) ;;;; wrapper cache numbers @@ -219,12 +216,6 @@ (defmacro wrapper-no-of-instance-slots (wrapper) `(layout-length ,wrapper)) -;;; FIXME: Why are these macros? -(defmacro wrapper-instance-slots-layout (wrapper) - `(%wrapper-instance-slots-layout ,wrapper)) -(defmacro wrapper-class-slots (wrapper) - `(%wrapper-class-slots ,wrapper)) - ;;; This is called in BRAID when we are making wrappers for classes ;;; whose slots are not initialized yet, and which may be built-in ;;; classes. We pass in the class name in addition to the class. @@ -357,7 +348,8 @@ (dotimes (i layout-clos-hash-length) (setf (cache-number-vector-ref owrapper i) 0)) - + ;; FIXME: We could save a whopping cons by using (STATE . WRAPPER) + ;; instead (push (setf (layout-invalid owrapper) (list state nwrapper)) new-previous) @@ -461,20 +453,24 @@ (declare (fixnum nkeys)) (if (= nkeys 1) (let* ((line-size (if valuep 2 1)) - (cache-size (if (typep nlines-or-cache-vector 'fixnum) - (* line-size - (power-of-two-ceiling nlines-or-cache-vector)) - (cache-vector-size nlines-or-cache-vector)))) + (cache-size (etypecase nlines-or-cache-vector + (fixnum + (* line-size + (power-of-two-ceiling nlines-or-cache-vector))) + (vector + (cache-vector-size nlines-or-cache-vector))))) (declare (type (and unsigned-byte fixnum) line-size cache-size)) (values (logxor (1- cache-size) (1- line-size)) cache-size line-size (floor cache-size line-size))) (let* ((line-size (power-of-two-ceiling (if valuep (1+ nkeys) nkeys))) - (cache-size (if (typep nlines-or-cache-vector 'fixnum) - (* line-size - (power-of-two-ceiling nlines-or-cache-vector)) - (1- (cache-vector-size nlines-or-cache-vector))))) + (cache-size (etypecase nlines-or-cache-vector + (fixnum + (* line-size + (power-of-two-ceiling nlines-or-cache-vector))) + (vector + (1- (cache-vector-size nlines-or-cache-vector)))))) (declare (fixnum line-size cache-size)) (values (logxor (1- cache-size) (1- line-size)) (1+ cache-size) @@ -496,9 +492,9 @@ (defun compute-primary-cache-location (field mask wrappers) (declare (type field-type field) (fixnum mask)) (if (not (listp wrappers)) - (logand mask + (logand mask (the fixnum (wrapper-cache-number-vector-ref wrappers field))) - (let ((location 0) + (let ((location 0) (i 0)) (declare (fixnum location i)) (dolist (wrapper wrappers) @@ -541,7 +537,7 @@ (dotimes-fixnum (i nkeys) (let* ((wrapper (cache-vector-ref cache-vector (+ i from-location))) (wcn (wrapper-cache-number-vector-ref wrapper field))) - (declare (fixnum wcn)) + (declare (fixnum wcn)) (incf result wcn)) (when (and (not (zerop i)) (zerop (mod i wrapper-cache-number-adds-ok))) @@ -654,53 +650,51 @@ ;;;; symbols because we don't capture any user code in the scope in which ;;;; these symbols are bound. +(declaim (list *dfun-arg-symbols*)) (defvar *dfun-arg-symbols* '(.ARG0. .ARG1. .ARG2. .ARG3.)) (defun dfun-arg-symbol (arg-number) - (or (nth arg-number (the list *dfun-arg-symbols*)) + (or (nth arg-number *dfun-arg-symbols*) (format-symbol *pcl-package* ".ARG~A." arg-number))) +(declaim (list *slot-vector-symbols*)) (defvar *slot-vector-symbols* '(.SLOTS0. .SLOTS1. .SLOTS2. .SLOTS3.)) (defun slot-vector-symbol (arg-number) - (or (nth arg-number (the list *slot-vector-symbols*)) + (or (nth arg-number *slot-vector-symbols*) (format-symbol *pcl-package* ".SLOTS~A." arg-number))) -;; FIXME: There ought to be a good way to factor out the idiom: -;; -;; (dotimes (i (length metatypes)) -;; (push (dfun-arg-symbol i) lambda-list)) -;; -;; used in the following four functions into common code that we can -;; declare inline or something. --njf 2001-12-20 +(declaim (inline make-dfun-required-args)) +(defun make-dfun-required-args (metatypes) + ;; Micro-optimizations 'R Us + (labels ((rec (types i) + (declare (fixnum i)) + (when types + (cons (dfun-arg-symbol i) + (rec (cdr types) (1+ i)))))) + (rec metatypes 0))) + (defun make-dfun-lambda-list (metatypes applyp) - (let ((lambda-list nil)) - (dotimes (i (length metatypes)) - (push (dfun-arg-symbol i) lambda-list)) - (when applyp - ;; Use &MORE arguments to avoid consing up an &REST list that we - ;; might not need at all. See MAKE-EMF-CALL and - ;; INVOKE-EFFECTIVE-METHOD-FUNCTION for the other pieces. - (push '&more lambda-list) - (push '.dfun-more-context. lambda-list) - (push '.dfun-more-count. lambda-list)) - (nreverse lambda-list))) + (let ((required (make-dfun-required-args metatypes))) + (if applyp + (nconc required + ;; Use &MORE arguments to avoid consing up an &REST list + ;; that we might not need at all. See MAKE-EMF-CALL and + ;; INVOKE-EFFECTIVE-METHOD-FUNCTION for the other + ;; pieces. + '(&more .dfun-more-context. .dfun-more-count.)) + required))) (defun make-dlap-lambda-list (metatypes applyp) - (let ((args nil) - (lambda-list nil)) - (dotimes (i (length metatypes)) - (push (dfun-arg-symbol i) args) - (push (dfun-arg-symbol i) lambda-list)) - (when applyp - (push '&more lambda-list) - (push '.more-context. lambda-list) - (push '.more-count. lambda-list)) + (let* ((required (make-dfun-required-args metatypes)) + (lambda-list (if applyp + (append required '(&more .more-context. .more-count.)) + required))) ;; Return the full lambda list, the required arguments, a form ;; that will generate a rest-list, and a list of the &MORE ;; parameters used. - (values (nreverse lambda-list) - (nreverse args) + (values lambda-list + required (when applyp '((sb-c::%listify-rest-args .more-context. @@ -710,11 +704,7 @@ '(.more-context. .more-count.))))) (defun make-emf-call (metatypes applyp fn-variable &optional emf-type) - (let ((required - (let ((required nil)) - (dotimes (i (length metatypes)) - (push (dfun-arg-symbol i) required)) - (nreverse required)))) + (let ((required (make-dfun-required-args metatypes))) `(,(if (eq emf-type 'fast-method-call) 'invoke-effective-method-function-fast 'invoke-effective-method-function) @@ -735,11 +725,8 @@ '(.dfun-more-context. .dfun-more-count.))))) (defun make-fast-method-call-lambda-list (metatypes applyp) - (let ((lambda-list (make-dfun-lambda-list metatypes applyp))) - ;; Reverse order - (push '.next-method-call. lambda-list) - (push '.pv-cell. lambda-list) - lambda-list)) + (list* '.pv-cell. '.next-method-call. + (make-dfun-lambda-list metatypes applyp))) (defmacro with-local-cache-functions ((cache) &body body) @@ -964,7 +951,6 @@ (defun fill-cache (cache wrappers value) ;; FILL-CACHE won't return if WRAPPERS is nil, might as well check.. (aver wrappers) - (or (fill-cache-p nil cache wrappers value) (and (< (ceiling (* (cache-count cache) *cache-expand-threshold*)) (if (= (cache-nkeys cache) 1) @@ -1001,7 +987,6 @@ (setq location (next-location location)))))) (defun probe-cache (cache wrappers &optional default limit-fn) - ;;(declare (values value)) (aver wrappers) (with-local-cache-functions (cache) (let* ((location (compute-primary-cache-location (field) (mask) wrappers)) @@ -1027,6 +1012,7 @@ (unless (or (line-reserved-p i) (not (line-valid-p i nil))) (let ((value (funcall function (line-wrappers i) (line-value i)))) (when set-p + ;; FIXME: Cache modification: should we not be holding a lock? (setf (cache-vector-ref (c-vector) (+ (line-location i) (nkeys))) value))))) (dolist (entry (overflow)) @@ -1053,6 +1039,8 @@ (return t)))))) ;;; returns T or NIL +;;; +;;; FIXME: Deceptive name as this has side-effects. (defun fill-cache-p (forcep cache wrappers value) (with-local-cache-functions (cache) (let* ((location (compute-primary-cache-location (field) (mask) wrappers)) @@ -1071,7 +1059,7 @@ (when (not emptyp) (push (cons (line-wrappers free) (line-value free)) (cache-overflow cache))) - ;;(fill-line free wrappers value) + ;; (fill-line free wrappers value) (let ((line free)) (declare (fixnum line)) (when (line-reserved-p line) @@ -1079,6 +1067,8 @@ (let ((loc (line-location line)) (cache-vector (c-vector))) (declare (fixnum loc) (simple-vector cache-vector)) + ;; FIXME: Cache modifications: should we not be holding + ;; a lock? (cond ((= (nkeys) 1) (setf (cache-vector-ref cache-vector loc) wrappers) (when (valuep) @@ -1094,6 +1084,7 @@ value)))) (maybe-check-cache cache)))))))) +;;; FIXME: Deceptive name as this has side-effects (defun fill-cache-from-cache-p (forcep cache from-cache from-line) (declare (fixnum from-line)) (with-local-cache-functions (cache) diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp index ba3d35a..4fcc2ef 100644 --- a/src/pcl/combin.lisp +++ b/src/pcl/combin.lisp @@ -243,11 +243,7 @@ (declare (ignorable #'%no-primary-method #'%invalid-qualifiers)) ,effective-method))) (mc-args-p - (let* ((required - ;; FIXME: Ick. Shared idiom, too, with stuff in cache.lisp - (let (req) - (dotimes (i (length metatypes) (nreverse req)) - (push (dfun-arg-symbol i) req)))) + (let* ((required (make-dfun-required-args metatypes)) (gf-args (if applyp `(list* ,@required (sb-c::%listify-rest-args diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index c75394c..0e816d0 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -863,21 +863,6 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defvar *new-class* nil) -(defvar *free-hash-tables* (mapcar #'list '(eq equal eql))) - -(defmacro with-hash-table ((table test) &body forms) - `(let* ((.free. (assoc ',test *free-hash-tables*)) - (,table (if (cdr .free.) - (pop (cdr .free.)) - (make-hash-table :test ',test)))) - (multiple-value-prog1 - (progn ,@forms) - (clrhash ,table) - (push ,table (cdr .free.))))) - -(defmacro with-eq-hash-table ((table) &body forms) - `(with-hash-table (,table eq) ,@forms)) - (defun final-accessor-dfun-type (gf) (let ((methods (if (early-gf-p gf) (early-gf-methods gf) @@ -915,7 +900,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 'writer)))) (defun make-final-accessor-dfun (gf type &optional classes-list new-class) - (with-eq-hash-table (table) + (let ((table (make-hash-table :test #'eq))) (multiple-value-bind (table all-index first second size no-class-slots-p) (make-accessor-table gf type table) (if table @@ -1667,6 +1652,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 root))) nil)) +;;; FIXME: Needs a lock. (defvar *effective-method-cache* (make-hash-table :test 'eq)) (defun flush-effective-method-cache (generic-function) diff --git a/src/pcl/dlisp.lisp b/src/pcl/dlisp.lisp index 35433f2..e0d23e7 100644 --- a/src/pcl/dlisp.lisp +++ b/src/pcl/dlisp.lisp @@ -468,7 +468,7 @@ (go ,miss-label)))) (class (when slot (error "can't do a slot reg for this metatype")) - `(wrapper-of-macro ,argument)) + `(wrapper-of ,argument)) ((built-in-instance structure-instance) (when slot (error "can't do a slot reg for this metatype")) `(built-in-or-structure-wrapper diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp index 1a1be86..2025da8 100644 --- a/src/pcl/low.lisp +++ b/src/pcl/low.lisp @@ -67,7 +67,6 @@ ;; to find out, I just overrode the LAYOUT ;; default here. -- WHN 19991204 (invalid nil)) - (:conc-name %wrapper-) (:constructor make-wrapper-internal) (:copier nil)) (instance-slots-layout nil :type list) diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index d0e5c04..849e499 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -1526,7 +1526,7 @@ (update-dfun gf dfun cache info)))))) (defmethod (setf class-name) (new-value class) - (let ((classoid (%wrapper-classoid (class-wrapper class)))) + (let ((classoid (wrapper-classoid (class-wrapper class)))) (if (and new-value (symbolp new-value)) (setf (classoid-name classoid) new-value) (setf (classoid-name classoid) nil))) diff --git a/version.lisp-expr b/version.lisp-expr index f11554e..44c28e5 100644 --- 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.0.27" +"1.0.0.28" -- 1.7.10.4