X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fvector.lisp;h=c2103e9c6f2e526ea1bda533b4e2fe09fe4db151;hb=22a6702974b7d6ff4e8f2b3b7b5ff446fc632de0;hp=47e4c9cabed288f41cc025508e119446a16f3d77;hpb=5f3793d28fad2c311506151b236104c0696fd540;p=sbcl.git diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index 47e4c9c..c2103e9 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -47,15 +47,18 @@ #-sb-fluid (declaim (sb-ext:freeze-type pv-table)) -(defvar *initial-pv-table* (make-pv-table-internal nil nil)) - -; help new slot-value-using-class methods affect fast iv access -(defvar *all-pv-table-list* nil) +;;; FIXME: The comment below seem to indicate that this was intended +;;; to be actually used, however, it isn't anymore, and was commented +;;; out at 0.9.13.47. Also removed was code in MAKE-PV-TABLE that +;;; pushed each new PV-TABLE onto this list. --NS 2006-06-18 +;;; +;;; help new slot-value-using-class methods affect fast iv access +;;; +;;; (defvar *all-pv-table-list* nil) +(declaim (inline make-pv-table)) (defun make-pv-table (&key slot-name-lists call-list) - (let ((pv-table (make-pv-table-internal slot-name-lists call-list))) - (push pv-table *all-pv-table-list*) - pv-table)) + (make-pv-table-internal slot-name-lists call-list)) (defun make-pv-table-type-declaration (var) `(type pv-table ,var)) @@ -79,18 +82,19 @@ (setq new-p t) (make-pv-table :slot-name-lists snl :call-list cl)))))) - (let ((pv-table (outer (mapcar #'inner (cons call-list slot-name-lists))))) - (when new-p - (let ((pv-index 1)) - (dolist (slot-name-list slot-name-lists) - (dolist (slot-name (cdr slot-name-list)) - (note-pv-table-reference slot-name pv-index pv-table) - (incf pv-index))) - (dolist (gf-call call-list) - (note-pv-table-reference gf-call pv-index pv-table) - (incf pv-index)) - (setf (pv-table-pv-size pv-table) pv-index))) - pv-table)))) + (let ((pv-table + (outer (mapcar #'inner (cons call-list slot-name-lists))))) + (when new-p + (let ((pv-index 1)) + (dolist (slot-name-list slot-name-lists) + (dolist (slot-name (cdr slot-name-list)) + (note-pv-table-reference slot-name pv-index pv-table) + (incf pv-index))) + (dolist (gf-call call-list) + (note-pv-table-reference gf-call pv-index pv-table) + (incf pv-index)) + (setf (pv-table-pv-size pv-table) pv-index))) + pv-table)))) (defun note-pv-table-reference (ref pv-offset pv-table) (let ((entry (gethash ref *pv-key-to-pv-table-table*))) @@ -238,8 +242,6 @@ (defun make-pv-type-declaration (var) `(type simple-vector ,var)) -(defvar *empty-pv* #()) - (defmacro pvref (pv index) `(svref ,pv ,index)) @@ -912,20 +914,32 @@ (declare (ignorable ,@(mapcar #'identity slot-vars))) ,@body))) -;;; This gets used only when the default MAKE-METHOD-LAMBDA is +;;; This will only be visible in PV-ENV when the default MAKE-METHOD-LAMBDA is ;;; overridden. -(defmacro pv-env ((pv calls pv-table-symbol pv-parameters) +(define-symbol-macro pv-env-environment overridden) + +(defmacro pv-env (&environment env + (pv calls pv-table-symbol pv-parameters) &rest forms) - `(let* ((.pv-table. ,pv-table-symbol) - (.pv-cell. (pv-table-lookup-pv-args .pv-table. ,@pv-parameters)) - (,pv (car .pv-cell.)) - (,calls (cdr .pv-cell.))) - (declare ,(make-pv-type-declaration pv)) - (declare ,(make-calls-type-declaration calls)) - ,@(when (symbolp pv-table-symbol) - `((declare (special ,pv-table-symbol)))) - ,pv ,calls - ,@forms)) + ;; Decide which expansion to use based on the state of the PV-ENV-ENVIRONMENT + ;; symbol-macrolet. + (if (eq (macroexpand 'pv-env-environment env) 'default) + `(let ((,pv (car .pv-cell.)) + (,calls (cdr .pv-cell.))) + (declare ,(make-pv-type-declaration pv) + ,(make-calls-type-declaration calls)) + ,pv ,calls + ,@forms) + `(let* ((.pv-table. ,pv-table-symbol) + (.pv-cell. (pv-table-lookup-pv-args .pv-table. ,@pv-parameters)) + (,pv (car .pv-cell.)) + (,calls (cdr .pv-cell.))) + (declare ,(make-pv-type-declaration pv)) + (declare ,(make-calls-type-declaration calls)) + ,@(when (symbolp pv-table-symbol) + `((declare (special ,pv-table-symbol)))) + ,pv ,calls + ,@forms))) (defvar *non-var-declarations* ;; FIXME: VALUES was in this list, conditionalized with #+CMU, but I @@ -1099,27 +1113,10 @@ (list (cons 'fast-method (body-method-name body)))) (.pv-cell. .next-method-call. ,@args+rest-arg) ; function args ;; body of the function - (declare (ignorable .pv-cell. .next-method-call.)) + (declare (ignorable .pv-cell. .next-method-call.) + (disable-package-locks pv-env-environment)) ,@outer-decls - (declare (disable-package-locks pv-env)) - (macrolet (;; If :PV-TABLE-SYMBOL isn't in the plist, the PV-ENV - ;; macro defined here will never get expanded. To - ;; speed up compilation of CLOS code, don't emit it - ;; in the first place. - ,@(when (getf (cdr lmf-params) :pv-env-p) - `((pv-env - ((pv calls pv-table-symbol pv-parameters) - &rest forms) - (declare (ignore pv-table-symbol - pv-parameters)) - (declare (enable-package-locks pv-env)) - `(let ((,pv (car .pv-cell.)) - (,calls (cdr .pv-cell.))) - (declare ,(make-pv-type-declaration pv) - ,(make-calls-type-declaration calls)) - ,pv ,calls - ,@forms))))) - (declare (enable-package-locks pv-env)) + (symbol-macrolet ((pv-env-environment default)) (fast-lexical-method-functions (,(car lmf-params) .next-method-call. ,req-args ,rest-arg ,@(cdddr lmf-params))