X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fvector.lisp;h=c2103e9c6f2e526ea1bda533b4e2fe09fe4db151;hb=01e9e8c568777d6480699e6cb3947f38c3bed350;hp=7c307f0d0242699592ab074883f808d316fc1f7a;hpb=81ce38f2e03e4f569d7a95bb18efb25bb16fc269;p=sbcl.git diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index 7c307f0..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)) @@ -586,7 +588,7 @@ (when (and class-name (not (eq class-name t))) (position parameter-or-nil slots :key #'car)))))) (if (constantp form) - (let ((form (eval form))) + (let ((form (constant-form-value form))) (if (symbolp form) form *unspecific-arg*)) @@ -630,8 +632,9 @@ ;;; 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)))) + (let ((class (and (constantp class-form) (constant-form-value class-form))) + (slot-name (and (constantp slot-name-form) + (constant-form-value slot-name-form)))) (and (eq *boot-state* 'complete) (standard-class-p class) (not (eq class *the-class-t*)) ; shouldn't happen, though. @@ -639,8 +642,9 @@ (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))) - (slot-name (and (constantp slot-name-form) (eval slot-name-form)))) + (let ((class (and (constantp class-form) (constant-form-value class-form))) + (slot-name (and (constantp slot-name-form) + (constant-form-value slot-name-form)))) (and (eq *boot-state* 'complete) (standard-class-p class) (not (eq class *the-class-t*)) ; shouldn't happen, though. @@ -910,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 @@ -1097,24 +1113,13 @@ (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 ((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)) - (fast-lexical-method-functions - (,(car lmf-params) .next-method-call. ,req-args ,rest-arg - ,@(cdddr lmf-params)) + (symbol-macrolet ((pv-env-environment default)) + (fast-lexical-method-functions + (,(car lmf-params) .next-method-call. ,req-args ,rest-arg + ,@(cdddr lmf-params)) ,@inner-decls ,@body-sans-decls))) ',initargs))))