X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fvector.lisp;h=26cc57056a967776c7b80158c606752ed4f4adff;hb=2217cdb364e8b48c187b085895bb2a5cbdbd9622;hp=b4180e2f782838a1954b5ec892c7aad6507802c7;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index b4180e2..26cc570 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -36,10 +36,10 @@ (defun pv-cache-limit-fn (nlines) (default-limit-fn nlines)) -(defstruct (pv-table - (:predicate pv-tablep) - (:constructor make-pv-table-internal - (slot-name-lists call-list))) +(defstruct (pv-table (:predicate pv-tablep) + (:constructor make-pv-table-internal + (slot-name-lists call-list)) + (:copier nil)) (cache nil :type (or cache null)) (pv-size 0 :type fixnum) (slot-name-lists nil :type list) @@ -63,7 +63,7 @@ (defvar *slot-name-lists-inner* (make-hash-table :test 'equal)) (defvar *slot-name-lists-outer* (make-hash-table :test 'equal)) -;entries in this are lists of (table . pv-offset-list) +;;; Entries in this are lists of (table . pv-offset-list). (defvar *pv-key-to-pv-table-table* (make-hash-table :test 'equal)) (defun intern-pv-table (&key slot-name-lists call-list) @@ -160,18 +160,23 @@ (unless (listp wrappers) (setq wrappers (list wrappers))) (let* ((not-simple-p-cell (list nil)) (elements - (gathering1 (collecting) - (iterate ((slot-names (list-elements slot-name-lists))) + (let ((elements nil)) + (dolist (slot-names slot-name-lists) (when slot-names (let* ((wrapper (pop wrappers)) (std-p (typep wrapper 'wrapper)) (class (wrapper-class* wrapper)) (class-slots (and std-p (wrapper-class-slots wrapper)))) (dolist (slot-name (cdr slot-names)) - (gather1 - (when std-p - (compute-pv-slot slot-name wrapper class - class-slots not-simple-p-cell)))))))))) + ;; Original PCL code had this idiom. why not: + ;; + ;; (WHEN STD-P + ;; (PUSH ...)) ? + (push (when std-p + (compute-pv-slot slot-name wrapper class + class-slots not-simple-p-cell)) + elements))))) + (nreverse elements)))) (if (car not-simple-p-cell) (make-permutation-vector (cons t elements)) (or (gethash elements *pvs*) @@ -182,8 +187,8 @@ (declare (ignore call-list wrappers)) #|| (map 'vector - #'(lambda (call) - (compute-emf-from-wrappers call wrappers)) + (lambda (call) + (compute-emf-from-wrappers call wrappers)) call-list) ||# '#()) @@ -194,18 +199,18 @@ (destructuring-bind (gf-name nreq restp arg-info) call (if (eq gf-name 'make-instance) (error "should not get here") ; there is another mechanism for this. - #'(lambda (&rest args) - (if (not (eq *boot-state* 'complete)) - (apply (gdefinition gf-name) args) - (let* ((gf (gdefinition gf-name)) - (arg-info (arg-info-reader gf)) - (classes '?) - (types '?) - (emf (cache-miss-values-internal gf arg-info - wrappers classes types - 'caching))) - (update-all-pv-tables call wrappers emf) - (invoke-emf emf args)))))))) + (lambda (&rest args) + (if (not (eq *boot-state* 'complete)) + (apply (gdefinition gf-name) args) + (let* ((gf (gdefinition gf-name)) + (arg-info (arg-info-reader gf)) + (classes '?) + (types '?) + (emf (cache-miss-values-internal gf arg-info + wrappers classes types + 'caching))) + (update-all-pv-tables call wrappers emf) + (invoke-emf emf args)))))))) ||# (defun make-permutation-vector (indexes) @@ -250,9 +255,6 @@ (defvar *pv-table-cache-update-info* nil) -;called by: -;(method shared-initialize :after (structure-class t)) -;update-slots (defun update-pv-table-cache-info (class) (let ((slot-names-for-pv-table-update nil) (new-icui nil)) @@ -269,26 +271,26 @@ (std-p (typep cwrapper 'wrapper)) (class-slots (and std-p (wrapper-class-slots cwrapper))) (class-slot-p-cell (list nil)) - (new-values (mapcar #'(lambda (slot-name) - (cons slot-name - (when std-p - (compute-pv-slot - slot-name cwrapper class - class-slots class-slot-p-cell)))) + (new-values (mapcar (lambda (slot-name) + (cons slot-name + (when std-p + (compute-pv-slot + slot-name cwrapper class + class-slots class-slot-p-cell)))) slot-names)) (pv-tables nil)) (dolist (slot-name slot-names) (map-pv-table-references-of slot-name - #'(lambda (pv-table pv-offset-list) - (declare (ignore pv-offset-list)) - (pushnew pv-table pv-tables)))) + (lambda (pv-table pv-offset-list) + (declare (ignore pv-offset-list)) + (pushnew pv-table pv-tables)))) (dolist (pv-table pv-tables) (let* ((cache (pv-table-cache pv-table)) (slot-name-lists (pv-table-slot-name-lists pv-table)) (pv-size (pv-table-pv-size pv-table)) (pv-map (make-array pv-size :initial-element nil))) - (let ((map-index 1)(param-index 0)) + (let ((map-index 1) (param-index 0)) (dolist (slot-name-list slot-name-lists) (dolist (slot-name (cdr slot-name-list)) (let ((a (assoc slot-name new-values))) @@ -297,10 +299,10 @@ (incf map-index)) (incf param-index))) (when cache - (map-cache #'(lambda (wrappers pv-cell) - (setf (car pv-cell) - (update-slots-in-pv wrappers (car pv-cell) - cwrapper pv-size pv-map))) + (map-cache (lambda (wrappers pv-cell) + (setf (car pv-cell) + (update-slots-in-pv wrappers (car pv-cell) + cwrapper pv-size pv-map))) cache)))))) (defun update-slots-in-pv (wrappers pv cwrapper pv-size pv-map) @@ -361,34 +363,24 @@ (optimize-writer slots parameter gf-name form))))) (unless (and (consp (cadr form)) (eq 'instance-accessor-parameter (caadr form))) - (or #|| - (cond ((and (= len 2) (symbolp fname)) - (let ((gf-name (gethash fname *gf-declared-reader-table*))) - (when gf-name - (maybe-optimize-reader)))) - ((= len 3) - (let ((gf-name (gethash fname *gf-declared-writer-table*))) - (when gf-name - (maybe-optimize-writer))))) - ||# - (when (and (eq *boot-state* 'complete) - (generic-function-p gf)) - (let ((methods (generic-function-methods gf))) - (when methods - (let* ((gf-name (generic-function-name gf)) - (arg-info (gf-arg-info gf)) - (metatypes (arg-info-metatypes arg-info)) - (nreq (length metatypes)) - (applyp (arg-info-applyp arg-info))) - (when (null applyp) - (cond ((= nreq 1) - (when (some #'standard-reader-method-p methods) - (maybe-optimize-reader))) - ((and (= nreq 2) - (consp gf-name) - (eq (car gf-name) 'setf)) - (when (some #'standard-writer-method-p methods) - (maybe-optimize-writer)))))))))))))) + (when (and (eq *boot-state* 'complete) + (generic-function-p gf)) + (let ((methods (generic-function-methods gf))) + (when methods + (let* ((gf-name (generic-function-name gf)) + (arg-info (gf-arg-info gf)) + (metatypes (arg-info-metatypes arg-info)) + (nreq (length metatypes)) + (applyp (arg-info-applyp arg-info))) + (when (null applyp) + (cond ((= nreq 1) + (when (some #'standard-reader-method-p methods) + (maybe-optimize-reader))) + ((and (= nreq 2) + (consp gf-name) + (eq (car gf-name) 'setf)) + (when (some #'standard-writer-method-p methods) + (maybe-optimize-writer))))))))))))) (defun optimize-generic-function-call (form required-parameters @@ -396,26 +388,7 @@ slots calls) (declare (ignore required-parameters env slots calls)) - (or (and (eq (car form) 'make-instance) - (expand-make-instance-form form)) - #|| - (maybe-expand-accessor-form form required-parameters slots env) - (let* ((fname (car form)) - (len (length form)) - (gf (if (symbolp fname) - (and (fboundp fname) - (unencapsulated-fdefinition fname)) - (and (gboundp fname) - (gdefinition fname)))) - (gf-name (and (fsc-instance-p gf) - (if (early-gf-p gf) - (early-gf-name gf) - (generic-function-name gf))))) - (when gf-name - (multiple-value-bind (nreq restp) - (get-generic-function-info gf) - (optimize-gf-call slots calls form nreq restp env)))) - ||# + (or ; (optimize-reader ...)? form)) (defun can-optimize-access (form required-parameters env) @@ -427,39 +400,37 @@ (slot-name (eval (caddr form)))) ; known to be constant (can-optimize-access1 var required-parameters env type slot-name))) -;;; FIXME: This looks like an internal helper function for CAN-OPTIMIZE-ACCESS, -;;; and it is used that way, but -;;; it's also called bare from several places in the code. Perhaps -;;; the two functions should be renamed fo CAN-OPTIMIZE-ACCESS-FOR-FORM -;;; and CAN-OPTIMIZE-ACCESS-FOR-VAR. If so, I'd just as soon use keyword +;;; FIXME: This looks like an internal helper function for +;;; CAN-OPTIMIZE-ACCESS, and it is used that way, but it's also called +;;; bare from several places in the code. Perhaps the two functions +;;; should be renamed CAN-OPTIMIZE-ACCESS-FOR-FORM and +;;; CAN-OPTIMIZE-ACCESS-FOR-VAR. If so, I'd just as soon use keyword ;;; args instead of optional ones, too. (defun can-optimize-access1 (var required-parameters env &optional type slot-name) (when (and (consp var) (eq 'the (car var))) - ;; FIXME: We should assert list of length 3 here. Or maybe we should just - ;; define EXTRACT-THE, replace the whole + ;; FIXME: We should assert list of length 3 here. Or maybe we + ;; should just define EXTRACT-THE, replace the whole ;; (WHEN ..) ;; form with ;; (AWHEN (EXTRACT-THE VAR) ;; (SETF VAR IT)) - ;; and then use EXTRACT-THE similarly to clean up the other tests against - ;; 'THE scattered through the PCL code. + ;; and then use EXTRACT-THE similarly to clean up the other tests + ;; against 'THE scattered through the PCL code. (setq var (caddr var))) (when (symbolp var) - (let* ((rebound? (caddr (variable-declaration 'variable-rebinding - var - env))) + (let* ((rebound? (caddr (var-declaration '%variable-rebinding var env))) (parameter-or-nil (car (memq (or rebound? var) required-parameters)))) (when parameter-or-nil - (let* ((class-name (caddr (variable-declaration 'class - parameter-or-nil - env))) + (let* ((class-name (caddr (var-declaration '%class + parameter-or-nil + env))) (class (find-class class-name nil))) (when (or (not (eq *boot-state* 'complete)) (and class (not (class-finalized-p class)))) (setq class nil)) - (when (and class-name (not (eq class-name 't))) + (when (and class-name (not (eq class-name t))) (when (or (null type) (not (and class (memq *the-class-structure-object* @@ -490,19 +461,21 @@ (defun optimize-slot-boundp (slots sparameter form) (if sparameter (destructuring-bind - ;; FIXME: In CMU CL ca. 19991205, this binding list had a fourth - ;; element in it, NEW-VALUE. It's hard to see how that could possibly - ;; be right, since SLOT-BOUNDP has no NEW-VALUE. Since it was causing - ;; a failure in building PCL for SBCL, so I changed it to match the - ;; definition of SLOT-BOUNDP (and also to match the list used in the - ;; similar OPTIMIZE-SLOT-VALUE, above). However, I'm weirded out by - ;; this, since this is old code which has worked for ages to build - ;; PCL for CMU CL, so it's hard to see why it should need a patch - ;; like this in order to build PCL for SBCL. I'd like to return to - ;; this and find a test case which exercises this function both in - ;; CMU CL, to see whether it's really a previously-unexercised bug or - ;; whether I've misunderstood something (and, presumably, patched it - ;; wrong). + ;; FIXME: In CMU CL ca. 19991205, this binding list had a + ;; fourth element in it, NEW-VALUE. It's hard to see how + ;; that could possibly be right, since SLOT-BOUNDP has no + ;; NEW-VALUE. Since it was causing a failure in building PCL + ;; for SBCL, so I changed it to match the definition of + ;; SLOT-BOUNDP (and also to match the list used in the + ;; similar OPTIMIZE-SLOT-VALUE, above). However, I'm weirded + ;; out by this, since this is old code which has worked for + ;; ages to build PCL for CMU CL, so it's hard to see why it + ;; should need a patch like this in order to build PCL for + ;; SBCL. I'd like to return to this and find a test case + ;; which exercises this function both in CMU CL, to see + ;; whether it's really a previously-unexercised bug or + ;; whether I've misunderstood something (and, presumably, + ;; patched it wrong). (slot-boundp-symbol instance slot-name-form) form (declare (ignore slot-boundp-symbol instance)) @@ -526,10 +499,10 @@ (optimize-accessor-call slots :write sparameter gf-name new-value)) form)) -;;; The SLOTS argument is an alist, the CAR of each entry is the name of -;;; a required parameter to the function. The alist is in order, so the -;;; position of an entry in the alist corresponds to the argument's position -;;; in the lambda list. +;;; The SLOTS argument is an alist, the CAR of each entry is the name +;;; of a required parameter to the function. The alist is in order, so +;;; the position of an entry in the alist corresponds to the +;;; argument's position in the lambda list. (defun optimize-instance-access (slots read/write sparameter @@ -549,13 +522,13 @@ ,parameter) ,new-value)) (:boundp - 'T))) + t))) (let* ((parameter-entry (assq parameter slots)) (slot-entry (assq slot-name (cdr parameter-entry))) (position (posq parameter-entry slots)) (pv-offset-form (list 'pv-offset ''.PV-OFFSET.))) (unless parameter-entry - (error "internal error in slot optimization")) + (bug "slot optimization bewilderment: O-I-A")) (unless slot-entry (setq slot-entry (list slot-name)) (push slot-entry (cdr parameter-entry))) @@ -583,7 +556,7 @@ (position (posq parameter-entry slots)) (pv-offset-form (list 'pv-offset ''.PV-OFFSET.))) (unless parameter-entry - (error "internal error in slot optimization")) + (error "slot optimization bewilderment: O-A-C")) (unless slot-entry (setq slot-entry (list name)) (push slot-entry (cdr parameter-entry))) @@ -603,13 +576,15 @@ (eq (car form) 'the)) (setq form (caddr form))) (or (and (symbolp form) - (let* ((rebound? (caddr (variable-declaration 'variable-rebinding - form env))) + (let* ((rebound? (caddr (var-declaration '%variable-rebinding + form + env))) (parameter-or-nil (car (assq (or rebound? form) slots)))) (when parameter-or-nil - (let* ((class-name (caddr (variable-declaration - 'class parameter-or-nil env)))) - (when (and class-name (not (eq class-name 't))) + (let* ((class-name (caddr (var-declaration 'class + parameter-or-nil + env)))) + (when (and class-name (not (eq class-name t))) (position parameter-or-nil slots :key #'car)))))) (if (constantp form) (let ((form (eval form))) @@ -619,14 +594,14 @@ *unspecific-arg*))) (defun optimize-gf-call (slots calls gf-call-form nreq restp env) - (unless (eq (car gf-call-form) 'make-instance) ; needs more work + (unless (eq (car gf-call-form) 'make-instance) ; XXX needs more work (let* ((args (cdr gf-call-form)) (all-args-p (eq (car gf-call-form) 'make-instance)) (non-required-args (nthcdr nreq args)) (required-args (ldiff args non-required-args)) (call-spec (list (car gf-call-form) nreq restp - (mapcar #'(lambda (form) - (optimize-gf-call-internal form slots env)) + (mapcar (lambda (form) + (optimize-gf-call-internal form slots env)) (if all-args-p args required-args)))) @@ -653,8 +628,8 @@ (define-walker-template instance-accessor-parameter) (defmacro instance-accessor-parameter (x) x) -;; It is safe for these two functions to be wrong. -;; They just try to guess what the most likely case will be. +;;; It is safe for these two functions to be wrong. They just try to +;;; guess what the most likely case will be. (defun generate-fast-class-slot-access-p (class-form slot-name-form) (let ((class (and (constantp class-form) (eval class-form))) (slot-name (and (constantp slot-name-form) (eval slot-name-form)))) @@ -662,7 +637,7 @@ (standard-class-p class) (not (eq class *the-class-t*)) ; shouldn't happen, though. (let ((slotd (find-slot-definition class slot-name))) - (and slotd (classp (slot-definition-allocation slotd))))))) + (and slotd (eq :class (slot-definition-allocation slotd))))))) (defun skip-fast-slot-access-p (class-form slot-name-form type) (let ((class (and (constantp class-form) (eval class-form))) @@ -671,7 +646,9 @@ (standard-class-p class) (not (eq class *the-class-t*)) ; shouldn't happen, though. (let ((slotd (find-slot-definition class slot-name))) - (and slotd (skip-optimize-slot-value-by-class-p class slot-name type)))))) + (and slotd (skip-optimize-slot-value-by-class-p class + slot-name + type)))))) (defun skip-optimize-slot-value-by-class-p (class slot-name type) (let ((slotd (find-slot-definition class slot-name))) @@ -682,19 +659,19 @@ (defmacro instance-read-internal (pv slots pv-offset default &optional type) (unless (member type '(nil :instance :class :default)) (error "illegal type argument to ~S: ~S" 'instance-read-internal type)) - (if (eq type ':default) + (if (eq type :default) default (let* ((index (gensym)) (value index)) `(locally (declare #.*optimize-speed*) (let ((,index (pvref ,pv ,pv-offset))) (setq ,value (typecase ,index - ,@(when (or (null type) (eq type ':instance)) - `((fixnum (%instance-ref ,slots ,index)))) - ,@(when (or (null type) (eq type ':class)) + ,@(when (or (null type) (eq type :instance)) + `((fixnum (clos-slots-ref ,slots ,index)))) + ,@(when (or (null type) (eq type :class)) `((cons (cdr ,index)))) - (t ',*slot-unbound*))) - (if (eq ,value ',*slot-unbound*) + (t +slot-unbound+))) + (if (eq ,value +slot-unbound+) ,default ,value)))))) @@ -704,7 +681,7 @@ `(instance-read-internal .pv. ,(slot-vector-symbol position) ,pv-offset (accessor-slot-value ,parameter ,slot-name) ,(if (generate-fast-class-slot-access-p class slot-name) - ':class ':instance)))) + :class :instance)))) (defmacro instance-reader (pv-offset parameter position gf-name class) (declare (ignore class)) @@ -717,15 +694,16 @@ &optional type) (unless (member type '(nil :instance :class :default)) (error "illegal type argument to ~S: ~S" 'instance-write-internal type)) - (if (eq type ':default) + (if (eq type :default) default (let* ((index (gensym))) `(locally (declare #.*optimize-speed*) (let ((,index (pvref ,pv ,pv-offset))) (typecase ,index - ,@(when (or (null type) (eq type ':instance)) - `((fixnum (setf (%instance-ref ,slots ,index) ,new-value)))) - ,@(when (or (null type) (eq type ':class)) + ,@(when (or (null type) (eq type :instance)) + `((fixnum (setf (clos-slots-ref ,slots ,index) + ,new-value)))) + ,@(when (or (null type) (eq type :class)) `((cons (setf (cdr ,index) ,new-value)))) (t ,default))))))) @@ -741,7 +719,7 @@ ,pv-offset ,new-value (accessor-set-slot-value ,parameter ,slot-name ,new-value) ,(if (generate-fast-class-slot-access-p class slot-name) - ':class ':instance)))) + :class :instance)))) (defmacro instance-writer (pv-offset parameter @@ -753,7 +731,7 @@ `(instance-write-internal .pv. ,(slot-vector-symbol position) ,pv-offset ,new-value (,(if (consp gf-name) - (get-setf-function-name gf-name) + (get-setf-fun-name gf-name) gf-name) (instance-accessor-parameter ,parameter) ,new-value) @@ -763,17 +741,18 @@ &optional type) (unless (member type '(nil :instance :class :default)) (error "illegal type argument to ~S: ~S" 'instance-boundp-internal type)) - (if (eq type ':default) + (if (eq type :default) default (let* ((index (gensym))) `(locally (declare #.*optimize-speed*) (let ((,index (pvref ,pv ,pv-offset))) (typecase ,index - ,@(when (or (null type) (eq type ':instance)) - `((fixnum (not (eq (%instance-ref ,slots ,index) - ',*slot-unbound*))))) - ,@(when (or (null type) (eq type ':class)) - `((cons (not (eq (cdr ,index) ',*slot-unbound*))))) + ,@(when (or (null type) (eq type :instance)) + `((fixnum (not (and ,slots + (eq (clos-slots-ref ,slots ,index) + +slot-unbound+)))))) + ,@(when (or (null type) (eq type :class)) + `((cons (not (eq (cdr ,index) +slot-unbound+))))) (t ,default))))))) (defmacro instance-boundp (pv-offset parameter position slot-name class) @@ -782,27 +761,29 @@ `(instance-boundp-internal .pv. ,(slot-vector-symbol position) ,pv-offset (accessor-slot-boundp ,parameter ,slot-name) ,(if (generate-fast-class-slot-access-p class slot-name) - ':class ':instance)))) + :class :instance)))) ;;; This magic function has quite a job to do indeed. ;;; -;;; The careful reader will recall that contains all of the optimized -;;; slot access forms produced by OPTIMIZE-INSTANCE-ACCESS. Each of these is -;;; a call to either INSTANCE-READ or INSTANCE-WRITE. +;;; The careful reader will recall that contains all of the +;;; optimized slot access forms produced by OPTIMIZE-INSTANCE-ACCESS. +;;; Each of these is a call to either INSTANCE-READ or INSTANCE-WRITE. ;;; -;;; At the time these calls were produced, the first argument was specified as -;;; the symbol .PV-OFFSET.; what we have to do now is convert those pv-offset -;;; arguments into the actual number that is the correct offset into the pv. +;;; At the time these calls were produced, the first argument was +;;; specified as the symbol .PV-OFFSET.; what we have to do now is +;;; convert those pv-offset arguments into the actual number that is +;;; the correct offset into the pv. ;;; -;;; But first, oh but first, we sort a bit so that for each argument we -;;; have the slots in alphabetical order. This canonicalizes the PV-TABLE's a -;;; bit and will hopefully lead to having fewer PV's floating around. Even if -;;; the gain is only modest, it costs nothing. +;;; But first, oh but first, we sort a bit so that for each +;;; argument we have the slots in alphabetical order. This +;;; canonicalizes the PV-TABLE's a bit and will hopefully lead to +;;; having fewer PV's floating around. Even if the gain is only +;;; modest, it costs nothing. (defun slot-name-lists-from-slots (slots calls) (multiple-value-bind (slots calls) (mutate-slots-and-calls slots calls) (let* ((slot-name-lists - (mapcar #'(lambda (parameter-entry) - (cons nil (mapcar #'car (cdr parameter-entry)))) + (mapcar (lambda (parameter-entry) + (cons nil (mapcar #'car (cdr parameter-entry)))) slots)) (call-list (mapcar #'car calls))) @@ -810,22 +791,22 @@ (dolist (arg (cdr call)) (when (integerp arg) (setf (car (nth arg slot-name-lists)) t)))) - (setq slot-name-lists (mapcar #'(lambda (r+snl) - (when (or (car r+snl) (cdr r+snl)) - r+snl)) + (setq slot-name-lists (mapcar (lambda (r+snl) + (when (or (car r+snl) (cdr r+snl)) + r+snl)) slot-name-lists)) (let ((cvt (apply #'vector (let ((i -1)) - (mapcar #'(lambda (r+snl) - (when r+snl (incf i))) + (mapcar (lambda (r+snl) + (when r+snl (incf i))) slot-name-lists))))) - (setq call-list (mapcar #'(lambda (call) - (cons (car call) - (mapcar #'(lambda (arg) - (if (integerp arg) - (svref cvt arg) - arg)) - (cdr call)))) + (setq call-list (mapcar (lambda (call) + (cons (car call) + (mapcar (lambda (arg) + (if (integerp arg) + (svref cvt arg) + arg)) + (cdr call)))) call-list))) (values slot-name-lists call-list)))) @@ -880,41 +861,43 @@ (symbol-or-cons-lessp (car a) (car b)))))))) (defun sort-slots (slots) - (mapcar #'(lambda (parameter-entry) - (cons (car parameter-entry) - (sort (cdr parameter-entry) ;slot entries - #'symbol-or-cons-lessp - :key #'car))) + (mapcar (lambda (parameter-entry) + (cons (car parameter-entry) + (sort (cdr parameter-entry) ;slot entries + #'symbol-or-cons-lessp + :key #'car))) slots)) (defun sort-calls (calls) (sort calls #'symbol-or-cons-lessp :key #'car)) -;;; This needs to work in terms of metatypes and also needs to work for -;;; automatically generated reader and writer functions. -;;; -- Automatically generated reader and writer functions use this stuff too. +;;;; This needs to work in terms of metatypes and also needs to work +;;;; for automatically generated reader and writer functions. +;;;; Automatically generated reader and writer functions use this +;;;; stuff too. (defmacro pv-binding ((required-parameters slot-name-lists pv-table-symbol) &body body) - (with-gathering ((slot-vars (collecting)) - (pv-parameters (collecting))) - (iterate ((slots (list-elements slot-name-lists)) - (required-parameter (list-elements required-parameters)) - (i (interval :from 0))) - (when slots - (gather required-parameter pv-parameters) - (gather (slot-vector-symbol i) slot-vars))) - `(pv-binding1 (.pv. .calls. ,pv-table-symbol ,pv-parameters ,slot-vars) + (let (slot-vars pv-parameters) + (loop for slots in slot-name-lists + for required-parameter in required-parameters + for i from 0 + do (when slots + (push required-parameter pv-parameters) + (push (slot-vector-symbol i) slot-vars))) + `(pv-binding1 (.pv. .calls. ,pv-table-symbol + ,(nreverse pv-parameters) ,(nreverse slot-vars)) ,@body))) (defmacro pv-binding1 ((pv calls pv-table-symbol pv-parameters slot-vars) &body body) `(pv-env (,pv ,calls ,pv-table-symbol ,pv-parameters) - (let (,@(mapcar #'(lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p))) - slot-vars pv-parameters)) + (let (,@(mapcar (lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p))) + slot-vars pv-parameters)) ,@body))) -;This gets used only when the default make-method-lambda is overriden. +;;; This gets used only when the default MAKE-METHOD-LAMBDA is +;;; overridden. (defmacro pv-env ((pv calls pv-table-symbol pv-parameters) &rest forms) `(let* ((.pv-table. ,pv-table-symbol) @@ -928,19 +911,31 @@ ,pv ,calls ,@forms)) -(defvar *non-variable-declarations* - ;; FIXME: VALUES was in this list, conditionalized with #+CMU, but - ;; I don't *think* CMU CL had, or SBCL has, VALUES declarations. If - ;; SBCL doesn't have 'em, VALUES should probably be removed from this list. - '(values method-name method-lambda-list - optimize ftype inline notinline)) - -(defvar *variable-declarations-with-argument* - '(class +(defvar *non-var-declarations* + ;; FIXME: VALUES was in this list, conditionalized with #+CMU, but I + ;; don't *think* CMU CL had, or SBCL has, VALUES declarations. If + ;; SBCL doesn't have 'em, VALUES should probably be removed from + ;; this list. + '(values + %method-name + %method-lambda-list + optimize + ftype + inline + notinline)) + +(defvar *var-declarations-with-arg* + '(%class type)) -(defvar *variable-declarations-without-argument* - '(ignore ignorable special dynamic-extent +(defvar *var-declarations-without-arg* + '(ignore + ignorable special dynamic-extent + ;; FIXME: Possibly this entire list and variable could go away. + ;; If not, certainly we should remove all these built-in typenames + ;; from the list, and replace them with a test for "is it a type + ;; name?" (CLTL1 allowed only built-in type names as declarations, + ;; but ANSI CL allows any type name as a declaration.) array atom base-char bignum bit bit-vector character compiled-function complex cons double-float extended-char fixnum float function hash-table integer @@ -950,7 +945,9 @@ stream string symbol t unsigned-byte vector)) (defun split-declarations (body args calls-next-method-p) - (let ((inner-decls nil) (outer-decls nil) decl) + (let ((inner-decls nil) + (outer-decls nil) + decl) (loop (when (null body) (return nil)) (setq decl (car body)) (unless (and (consp decl) @@ -959,51 +956,88 @@ (dolist (form (cdr decl)) (when (consp form) (let ((declaration-name (car form))) - (if (member declaration-name *non-variable-declarations*) + (if (member declaration-name *non-var-declarations*) (push `(declare ,form) outer-decls) (let ((arg-p (member declaration-name - *variable-declarations-with-argument*)) + *var-declarations-with-arg*)) (non-arg-p (member declaration-name - *variable-declarations-without-argument*)) + *var-declarations-without-arg*)) (dname (list (pop form))) (inners nil) (outers nil)) (unless (or arg-p non-arg-p) - ;; FIXME: This warning should probably go away now - ;; that we're not trying to be portable between - ;; different CLTL1 hosts the way PCL was. + ;; FIXME: This warning, and perhaps the + ;; various *VAR-DECLARATIONS-FOO* and/or + ;; *NON-VAR-DECLARATIONS* variables, + ;; could probably go away now that we're not + ;; trying to be portable between different + ;; CLTL1 hosts the way PCL was. (Note that to + ;; do this right, we need to be able to handle + ;; user-defined (DECLAIM (DECLARATION FOO)) + ;; stuff.) (warn "The declaration ~S is not understood by ~S.~@ Please put ~S on one of the lists ~S,~%~S, or~%~S.~@ (Assuming it is a variable declaration without argument)." declaration-name 'split-declarations declaration-name - '*non-variable-declarations* - '*variable-declarations-with-argument* - '*variable-declarations-without-argument*) - (push declaration-name - *variable-declarations-without-argument*)) + '*non-var-declarations* + '*var-declarations-with-arg* + '*var-declarations-without-arg*) + (push declaration-name *var-declarations-without-arg*)) (when arg-p (setq dname (append dname (list (pop form))))) - (dolist (var form) - (if (member var args) - ;; Quietly remove IGNORE declarations on args when - ;; a next-method is involved, to prevent compiler - ;; warns about ignored args being read. - (unless (and calls-next-method-p - (eq (car dname) 'ignore)) - (push var outers)) - (push var inners))) - (when outers - (push `(declare (,@dname ,@outers)) outer-decls)) - (when inners - (push `(declare (,@dname ,@inners)) inner-decls))))))) + (case (car dname) + (%class (push `(declare (,@dname ,@form)) inner-decls)) + (t + (dolist (var form) + (if (member var args) + ;; Quietly remove IGNORE declarations + ;; on args when a next-method is + ;; involved, to prevent compiler + ;; warnings about ignored args being + ;; read. + (unless (and calls-next-method-p + (eq (car dname) 'ignore)) + (push var outers)) + (push var inners))) + (when outers + (push `(declare (,@dname ,@outers)) outer-decls)) + (when inners + (push + `(declare (,@dname ,@inners)) + inner-decls))))))))) (setq body (cdr body))) (values outer-decls inner-decls body))) +;;; Pull a name out of the %METHOD-NAME declaration in the function +;;; body given, or return NIL if no %METHOD-NAME declaration is found. +(defun body-method-name (body) + (multiple-value-bind (real-body declarations documentation) + (parse-body body nil) + (declare (ignore documentation real-body)) + (let ((name-decl (get-declaration '%method-name declarations))) + (and name-decl + (destructuring-bind (name) name-decl + name))))) + +;;; Convert a lambda expression containing a SB-PCL::%METHOD-NAME +;;; declaration (which is a naming style internal to PCL) into an +;;; SB-INT:NAMED-LAMBDA expression (which is a naming style used +;;; throughout SBCL, understood by the main compiler); or if there's +;;; no SB-PCL::%METHOD-NAME declaration, then just return the original +;;; lambda expression. +(defun name-method-lambda (method-lambda) + (let ((method-name (body-method-name (cddr method-lambda)))) + (if method-name + `(named-lambda ,method-name ,(rest method-lambda)) + method-lambda))) + (defun make-method-initargs-form-internal (method-lambda initargs env) (declare (ignore env)) - (let (method-lambda-args lmf lmf-params) + (let (method-lambda-args + lmf ; becomes body of function + lmf-params) (if (not (and (= 3 (length method-lambda)) (= 2 (length (setq method-lambda-args (cadr method-lambda)))) (consp (setq lmf (third method-lambda))) @@ -1012,78 +1046,90 @@ (cadr (setq lmf-params (cadr lmf)))) (eq (cadr method-lambda-args) (caddr lmf-params)))) - `(list* :function #',method-lambda + `(list* :function ,(name-method-lambda method-lambda) ',initargs) (let* ((lambda-list (car lmf-params)) - (nreq 0)(restp nil)(args nil)) + (nreq 0) + (restp nil) + (args nil)) (dolist (arg lambda-list) (when (member arg '(&optional &rest &key)) - (setq restp t)(return nil)) - (when (eq arg '&aux) (return nil)) - (incf nreq)(push arg args)) + (setq restp t) + (return nil)) + (when (eq arg '&aux) + (return nil)) + (incf nreq) + (push arg args)) (setq args (nreverse args)) - (setf (getf (getf initargs ':plist) ':arg-info) (cons nreq restp)) + (setf (getf (getf initargs :plist) :arg-info) (cons nreq restp)) (make-method-initargs-form-internal1 initargs (cddr lmf) args lmf-params restp))))) (defun make-method-initargs-form-internal1 (initargs body req-args lmf-params restp) - (multiple-value-bind (outer-decls inner-decls body) + (multiple-value-bind (outer-decls inner-decls body-sans-decls) (split-declarations body req-args (getf (cdr lmf-params) :call-next-method-p)) (let* ((rest-arg (when restp '.rest-arg.)) (args+rest-arg (if restp (append req-args (list rest-arg)) req-args))) - `(list* :fast-function - #'(lambda (.pv-cell. .next-method-call. ,@args+rest-arg) - ,@outer-decls - .pv-cell. .next-method-call. - (macrolet ((pv-env ((pv calls pv-table-symbol pv-parameters) - &rest forms) - (declare (ignore pv-table-symbol pv-parameters)) - `(let ((,pv (car .pv-cell.)) - (,calls (cdr .pv-cell.))) - (declare ,(make-pv-type-declaration pv) - ,(make-calls-type-declaration calls)) - ,pv ,calls - ,@forms))) - (fast-lexical-method-functions - (,(car lmf-params) .next-method-call. ,req-args ,rest-arg - ,@(cdddr lmf-params)) - ,@inner-decls - ,@body))) + `(list* + :fast-function + (named-lambda + ,(or (body-method-name body) '.method.) ; function name + (.pv-cell. .next-method-call. ,@args+rest-arg) ; function args + ;; body of the function + (declare (ignorable .pv-cell. .next-method-call.)) + ,@outer-decls + (macrolet ((pv-env ((pv calls pv-table-symbol pv-parameters) + &rest forms) + (declare (ignore pv-table-symbol + pv-parameters)) + `(let ((,pv (car .pv-cell.)) + (,calls (cdr .pv-cell.))) + (declare ,(make-pv-type-declaration pv) + ,(make-calls-type-declaration calls)) + ,pv ,calls + ,@forms))) + (fast-lexical-method-functions + (,(car lmf-params) .next-method-call. ,req-args ,rest-arg + ,@(cdddr lmf-params)) + ,@inner-decls + ,@body-sans-decls))) ',initargs)))) -;;; Use arrays and hash tables and the fngen stuff to make this much better. It -;;; doesn't really matter, though, because a function returned by this will get -;;; called only when the user explicitly funcalls a result of method-function. -;;; BUT, this is needed to make early methods work. +;;; Use arrays and hash tables and the fngen stuff to make this much +;;; better. It doesn't really matter, though, because a function +;;; returned by this will get called only when the user explicitly +;;; funcalls a result of method-function. BUT, this is needed to make +;;; early methods work. (defun method-function-from-fast-function (fmf) (declare (type function fmf)) (let* ((method-function nil) (pv-table nil) - (arg-info (method-function-get fmf ':arg-info)) + (arg-info (method-function-get fmf :arg-info)) (nreq (car arg-info)) (restp (cdr arg-info))) (setq method-function - #'(lambda (method-args next-methods) - (unless pv-table - (setq pv-table (method-function-pv-table fmf))) - (let* ((pv-cell (when pv-table - (get-method-function-pv-cell - method-function method-args pv-table))) - (nm (car next-methods)) - (nms (cdr next-methods)) - (nmc (when nm - (make-method-call :function (if (std-instance-p nm) - (method-function nm) - nm) - :call-method-args (list nms))))) - (if restp - (let* ((rest (nthcdr nreq method-args)) - (args (ldiff method-args rest))) - (apply fmf pv-cell nmc (nconc args (list rest)))) - (apply fmf pv-cell nmc method-args))))) + (lambda (method-args next-methods) + (unless pv-table + (setq pv-table (method-function-pv-table fmf))) + (let* ((pv-cell (when pv-table + (get-method-function-pv-cell + method-function method-args pv-table))) + (nm (car next-methods)) + (nms (cdr next-methods)) + (nmc (when nm + (make-method-call + :function (if (std-instance-p nm) + (method-function nm) + nm) + :call-method-args (list nms))))) + (if restp + (let* ((rest (nthcdr nreq method-args)) + (args (ldiff method-args rest))) + (apply fmf pv-cell nmc (nconc args (list rest)))) + (apply fmf pv-cell nmc method-args))))) (let* ((fname (method-function-get fmf :name)) (name `(,(or (get (car fname) 'method-sym) (setf (get (car fname) 'method-sym) @@ -1092,7 +1138,7 @@ (intern (subseq str 5) *pcl-package*) (car fname))))) ,@(cdr fname)))) - (set-function-name method-function name)) + (set-fun-name method-function name)) (setf (method-function-get method-function :fast-function) fmf) method-function)) @@ -1109,52 +1155,24 @@ (pv-table-lookup pv-table (pv-wrappers-from-pv-args pv-parameters))) (defun pv-wrappers-from-pv-args (&rest args) - (let* ((nkeys (length args)) - (pv-wrappers (make-list nkeys)) - w - (w-t pv-wrappers)) - (dolist (arg args) - (setq w (wrapper-of arg)) - (unless (eq 't (wrapper-state w)) ; FIXME: should be INVALID-WRAPPER-P - (setq w (check-wrapper-validity arg))) - (setf (car w-t) w)) - (setq w-t (cdr w-t)) - (when (= nkeys 1) (setq pv-wrappers (car pv-wrappers))) - pv-wrappers)) + (let (wrappers) + (dolist (arg args (if (cdr wrappers) (nreverse wrappers) (car wrappers))) + (let ((wrapper (wrapper-of arg))) + (push (if (invalid-wrapper-p wrapper) + (check-wrapper-validity wrapper) + wrapper) + wrappers))))) (defun pv-wrappers-from-all-args (pv-table args) - (let ((nkeys 0) - (slot-name-lists (pv-table-slot-name-lists pv-table))) - (dolist (sn slot-name-lists) - (when sn (incf nkeys))) - (let* ((pv-wrappers (make-list nkeys)) - (pv-w-t pv-wrappers)) - (dolist (sn slot-name-lists) - (when sn - (let* ((arg (car args)) - (w (wrapper-of arg))) - (unless w ; CAN-OPTIMIZE-ACCESS prevents this from happening. - (error "error in PV-WRAPPERS-FROM-ALL-ARGS")) - (setf (car pv-w-t) w) - (setq pv-w-t (cdr pv-w-t)))) - (setq args (cdr args))) - (when (= nkeys 1) (setq pv-wrappers (car pv-wrappers))) - pv-wrappers))) + (loop for snl in (pv-table-slot-name-lists pv-table) and arg in args + when snl + collect (wrapper-of arg) into wrappers + finally (return (if (cdr wrappers) wrappers (car wrappers))))) +;;; Return the subset of WRAPPERS which is used in the cache +;;; of PV-TABLE. (defun pv-wrappers-from-all-wrappers (pv-table wrappers) - (let ((nkeys 0) - (slot-name-lists (pv-table-slot-name-lists pv-table))) - (dolist (sn slot-name-lists) - (when sn (incf nkeys))) - (let* ((pv-wrappers (make-list nkeys)) - (pv-w-t pv-wrappers)) - (dolist (sn slot-name-lists) - (when sn - (let ((w (car wrappers))) - (unless w ; CAN-OPTIMIZE-ACCESS prevents this from happening. - (error "error in PV-WRAPPERS-FROM-ALL-WRAPPERS")) - (setf (car pv-w-t) w) - (setq pv-w-t (cdr pv-w-t)))) - (setq wrappers (cdr wrappers))) - (when (= nkeys 1) (setq pv-wrappers (car pv-wrappers))) - pv-wrappers))) + (loop for snl in (pv-table-slot-name-lists pv-table) and w in wrappers + when snl + collect w into result + finally (return (if (cdr result) result (car result)))))