(let ((pv-table
(outer (mapcar #'inner (cons call-list slot-name-lists)))))
(when new-p
- (let ((pv-index 1))
+ (let ((pv-index 0))
(dolist (slot-name-list slot-name-lists)
(dolist (slot-name (cdr slot-name-list))
(note-pv-table-reference slot-name pv-index pv-table)
(maphash function entry)))
ref)
\f
-(defvar *pvs* (make-hash-table :test 'equal))
-
(defun optimize-slot-value-by-class-p (class slot-name type)
(or (not (eq *boot-state* 'complete))
(let ((slotd (find-slot-definition class slot-name)))
(and slotd
(slot-accessor-std-p slotd type)))))
-(defun compute-pv-slot (slot-name wrapper class class-slots class-slot-p-cell)
+(defun compute-pv-slot (slot-name wrapper class class-slots)
(if (symbolp slot-name)
(when (optimize-slot-value-by-class-p class slot-name 'all)
(or (instance-slot-index wrapper slot-name)
- (let ((cell (assq slot-name class-slots)))
- (when cell
- (setf (car class-slot-p-cell) t)
- cell))))
+ (assq slot-name class-slots)))
(when (consp slot-name)
- (dolist (type '(reader writer) nil)
- (when (eq (car slot-name) type)
- (return
- (let* ((gf-name (cadr slot-name))
- (gf (gdefinition gf-name))
- (location (when (eq *boot-state* 'complete)
- (accessor-values1 gf type class))))
- (when (consp location)
- (setf (car class-slot-p-cell) t))
- location)))))))
+ (case (first slot-name)
+ ((reader writer)
+ (when (eq *boot-state* 'complete)
+ (let ((gf (gdefinition (second slot-name))))
+ (when (generic-function-p gf)
+ (accessor-values1 gf (first slot-name) class)))))
+ (t (bug "Don't know how to deal with ~S in ~S"
+ slot-name 'compute-pv-slots))))))
(defun compute-pv (slot-name-lists wrappers)
- (unless (listp wrappers) (setq wrappers (list wrappers)))
- (let* ((not-simple-p-cell (list nil))
- (elements
- (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))
- ;; 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*)
- (setf (gethash elements *pvs*)
- (make-permutation-vector (cons nil elements)))))))
+ (unless (listp wrappers)
+ (setq wrappers (list wrappers)))
+ (let (elements)
+ (dolist (slot-names slot-name-lists
+ (make-permutation-vector (nreverse elements)))
+ (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))
+ (push (if std-p
+ (compute-pv-slot slot-name wrapper class class-slots)
+ nil)
+ elements)))))))
(defun compute-calls (call-list wrappers)
(declare (ignore call-list wrappers))
(let* ((cwrapper (class-wrapper class))
(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))))
- slot-names))
+ (new-values
+ (mapcar
+ (lambda (slot-name)
+ (cons slot-name
+ (if std-p
+ (compute-pv-slot slot-name cwrapper class class-slots)
+ nil)))
+ slot-names))
(pv-tables nil))
(dolist (slot-name slot-names)
(map-pv-table-references-of
(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 0) (param-index 0))
(dolist (slot-name-list slot-name-lists)
(dolist (slot-name (cdr slot-name-list))
(let ((a (assoc slot-name new-values)))
(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)))
+ (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)
- (if (not (if (atom wrappers)
- (eq cwrapper wrappers)
- (dolist (wrapper wrappers nil)
- (when (eq wrapper cwrapper)
- (return t)))))
- pv
- (let* ((old-intern-p (listp (pvref pv 0)))
- (new-pv (if old-intern-p
- (copy-pv pv)
- pv))
- (new-intern-p t))
- (if (atom wrappers)
- (dotimes-fixnum (i pv-size)
- (when (consp (let ((map (svref pv-map i)))
- (if map
- (setf (pvref new-pv i) (cdr map))
- (pvref new-pv i))))
- (setq new-intern-p nil)))
- (let ((param 0))
- (dolist (wrapper wrappers)
- (when (eq wrapper cwrapper)
- (dotimes-fixnum (i pv-size)
- (when (consp (let ((map (svref pv-map i)))
- (if (and map (= (car map) param))
- (setf (pvref new-pv i) (cdr map))
- (pvref new-pv i))))
- (setq new-intern-p nil))))
- (incf param))))
- (when new-intern-p
- (setq new-pv (let ((list-pv (coerce pv 'list)))
- (or (gethash (cdr list-pv) *pvs*)
- (setf (gethash (cdr list-pv) *pvs*)
- (if old-intern-p
- new-pv
- (make-permutation-vector list-pv)))))))
- new-pv)))
+ (if (atom wrappers)
+ (when (eq cwrapper wrappers)
+ (dotimes-fixnum (i pv-size)
+ (let ((map (svref pv-map i)))
+ (when map
+ (aver (= (car map) 0))
+ (setf (pvref pv i) (cdr map))))))
+ (when (memq cwrapper wrappers)
+ (let ((param 0))
+ (dolist (wrapper wrappers)
+ (when (eq wrapper cwrapper)
+ (dotimes-fixnum (i pv-size)
+ (let ((map (svref pv-map i)))
+ (when (and map (= (car map) param))
+ (setf (pvref pv i) (cdr map))))))
+ (incf param))))))
\f
(defun maybe-expand-accessor-form (form required-parameters slots env)
(let* ((fname (car form))
(optimize-slot-value-by-class-p class slot-name type))
(cons parameter-or-nil (or class class-name)))))))))
+;;; Check whether the binding of the named variable is modified in the
+;;; method body.
+(defun parameter-modified-p (parameter-name env)
+ (let ((modified-variables (macroexpand '%parameter-binding-modified env)))
+ (memq parameter-name modified-variables)))
+
(defun optimize-slot-value (slots sparameter form)
(if sparameter
- (destructuring-bind (ignore1 ignore2 slot-name-form) form
- (declare (ignore ignore1 ignore2))
- (let ((slot-name (eval slot-name-form)))
- (optimize-instance-access slots :read sparameter slot-name nil)))
+ (let ((optimized-form
+ (destructuring-bind (ignore1 ignore2 slot-name-form) form
+ (declare (ignore ignore1 ignore2))
+ (let ((slot-name (eval slot-name-form)))
+ (optimize-instance-access slots :read sparameter
+ slot-name nil)))))
+ ;; We don't return the optimized form directly, since there's
+ ;; still a chance that we'll find out later on that the
+ ;; optimization should not have been done, for example due to
+ ;; the walker encountering a SETQ on SPARAMETER later on in
+ ;; the body [ see for example clos.impure.lisp test with :name
+ ;; ((:setq :method-parameter) slot-value)) ]. Instead we defer
+ ;; the decision until the compiler macroexpands
+ ;; OPTIMIZED-SLOT-VALUE.
+ ;;
+ ;; Note that we must still call OPTIMIZE-INSTANCE-ACCESS at
+ ;; this point (instead of when expanding
+ ;; OPTIMIZED-SLOT-VALUE), since it mutates the structure of
+ ;; SLOTS. If that mutation isn't done while during the
+ ;; walking, MAKE-METHOD-LAMBDA-INTERNAL won't wrap a correct
+ ;; PV-BINDING form around the body, and compilation will fail.
+ ;; -- JES, 2006-09-18
+ `(optimized-slot-value ,form ,(car sparameter) ,optimized-form))
`(accessor-slot-value ,@(cdr form))))
+(defmacro optimized-slot-value (form parameter-name optimized-form
+ &environment env)
+ ;; Either use OPTIMIZED-FORM or fall back to the safe
+ ;; ACCESSOR-SLOT-VALUE.
+ (if (parameter-modified-p parameter-name env)
+ `(accessor-slot-value ,@(cdr form))
+ optimized-form))
+
(defun optimize-set-slot-value (slots sparameter form)
(if sparameter
- (destructuring-bind (ignore1 ignore2 slot-name-form new-value) form
- (declare (ignore ignore1 ignore2))
- (let ((slot-name (eval slot-name-form)))
- (optimize-instance-access slots
- :write
- sparameter
- slot-name
- new-value)))
+ (let ((optimized-form
+ (destructuring-bind (ignore1 ignore2 slot-name-form new-value) form
+ (declare (ignore ignore1 ignore2))
+ (let ((slot-name (eval slot-name-form)))
+ (optimize-instance-access slots
+ :write
+ sparameter
+ slot-name
+ new-value)))))
+ ;; See OPTIMIZE-SLOT-VALUE
+ `(optimized-set-slot-value ,form ,(car sparameter) ,optimized-form))
`(accessor-set-slot-value ,@(cdr form))))
+(defmacro optimized-set-slot-value (form parameter-name optimized-form
+ &environment env)
+ (if (parameter-modified-p parameter-name env)
+ `(accessor-set-slot-value ,@(cdr form))
+ optimized-form))
+
(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).
- (slot-boundp-symbol instance slot-name-form)
- form
- (declare (ignore slot-boundp-symbol instance))
- (let ((slot-name (eval slot-name-form)))
- (optimize-instance-access slots
- :boundp
- sparameter
- slot-name
- nil)))
+ (let ((optimized-form
+ (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).
+ (slot-boundp-symbol instance slot-name-form)
+ form
+ (declare (ignore slot-boundp-symbol instance))
+ (let ((slot-name (eval slot-name-form)))
+ (optimize-instance-access slots
+ :boundp
+ sparameter
+ slot-name
+ nil)))))
+ ;; See OPTIMIZE-SLOT-VALUE
+ `(optimized-slot-boundp ,form ,(car sparameter) ,optimized-form))
`(accessor-slot-boundp ,@(cdr form))))
+(defmacro optimized-slot-boundp (form parameter-name optimized-form
+ &environment env)
+ (if (parameter-modified-p parameter-name env)
+ `(accessor-slot-boundp ,@(cdr form))
+ optimized-form))
+
(defun optimize-reader (slots sparameter gf-name form)
(if sparameter
(optimize-accessor-call slots :read sparameter gf-name nil)
(defun mutate-slots-and-calls (slots calls)
(let ((sorted-slots (sort-slots slots))
(sorted-calls (sort-calls (cdr calls)))
- (pv-offset 0)) ; index 0 is for info
+ (pv-offset -1))
(dolist (parameter-entry sorted-slots)
(dolist (slot-entry (cdr parameter-entry))
(incf pv-offset)
;;;; Automatically generated reader and writer functions use this
;;;; stuff too.
-(defmacro pv-binding ((required-parameters slot-name-lists pv-table-symbol)
+(defmacro pv-binding ((required-parameters slot-name-lists pv-table-form)
&body body)
(let (slot-vars pv-parameters)
(loop for slots in slot-name-lists
do (when slots
(push required-parameter pv-parameters)
(push (slot-vector-symbol i) slot-vars)))
- `(pv-binding1 (.pv. .calls. ,pv-table-symbol
+ `(pv-binding1 (.pv. .calls. ,pv-table-form
,(nreverse pv-parameters) ,(nreverse slot-vars))
,@body)))
-(defmacro pv-binding1 ((pv calls pv-table-symbol pv-parameters slot-vars)
+(defmacro pv-binding1 ((pv calls pv-table-form pv-parameters slot-vars)
&body body)
- `(pv-env (,pv ,calls ,pv-table-symbol ,pv-parameters)
+ `(pv-env (,pv ,calls ,pv-table-form ,pv-parameters)
(let (,@(mapcar (lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p)))
slot-vars pv-parameters))
(declare (ignorable ,@(mapcar #'identity slot-vars)))
(define-symbol-macro pv-env-environment overridden)
(defmacro pv-env (&environment env
- (pv calls pv-table-symbol pv-parameters)
+ (pv calls pv-table-form pv-parameters)
&rest forms)
;; Decide which expansion to use based on the state of the PV-ENV-ENVIRONMENT
;; symbol-macrolet.
,(make-calls-type-declaration calls))
,pv ,calls
,@forms)
- `(let* ((.pv-table. ,pv-table-symbol)
+ `(let* ((.pv-table. ,pv-table-form)
(.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)))
+ (declare ,(make-pv-type-declaration pv))
+ (declare ,(make-calls-type-declaration calls))
+ ,pv ,calls
+ ,@forms)))
(defvar *non-var-declarations*
;; FIXME: VALUES was in this list, conditionalized with #+CMU, but I
(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)))))
(append req-args (list rest-arg))
req-args)))
`(list*
- :fast-function
- (,(if (body-method-name body) 'named-lambda 'lambda)
- ,@(when (body-method-name body)
- ;; function name
- (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.)
- (disable-package-locks pv-env-environment))
- ,@outer-decls
- (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)))
+ :function
+ (let* ((fmf (,(if (body-method-name body) 'named-lambda 'lambda)
+ ,@(when (body-method-name body)
+ ;; function name
+ (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.)
+ (disable-package-locks pv-env-environment))
+ ,@outer-decls
+ (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))))
+ (mf (%make-method-function fmf nil)))
+ (set-funcallable-instance-function
+ mf (method-function-from-fast-function fmf ',(getf initargs 'plist)))
+ mf)
',initargs))))
;;; Use arrays and hash tables and the fngen stuff to make this much
;;; 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)
+(defun method-function-from-fast-function (fmf plist)
(declare (type function fmf))
- (let* ((method-function nil) (pv-table nil)
- (arg-info (method-function-get fmf :arg-info))
+ (let* ((method-function nil)
+ (calls (getf plist :call-list))
+ (snl (getf plist :slot-name-lists))
+ (pv-table (when (or calls snl)
+ (intern-pv-table :call-list calls :slot-name-lists snl)))
+ (arg-info (getf plist :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)))
+ (get-pv-cell method-args pv-table)))
(nm (car next-methods))
(nms (cdr next-methods))
(nmc (when nm
(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 (cons 'slow-method (cdr fname))))
- (set-fun-name method-function name))
- (setf (method-function-get method-function :fast-function) fmf)
+ ;; FIXME: this looks dangerous.
+ (let* ((fname (%fun-name fmf)))
+ (when (and fname (eq (car fname) 'fast-method))
+ (set-fun-name method-function (cons 'slow-method (cdr fname)))))
method-function))
-(defun get-method-function-pv-cell (method-function
- method-args
- &optional pv-table)
- (let ((pv-table (or pv-table (method-function-pv-table method-function))))
- (when pv-table
- (let ((pv-wrappers (pv-wrappers-from-all-args pv-table method-args)))
- (when pv-wrappers
- (pv-table-lookup pv-table pv-wrappers))))))
+;;; this is similar to the above, only not quite. Only called when
+;;; the MOP is heavily involved. Not quite parallel to
+;;; METHOD-FUNCTION-FROM-FAST-METHOD-FUNCTION, because we can close
+;;; over the actual PV-CELL in this case.
+(defun method-function-from-fast-method-call (fmc)
+ (let* ((fmf (fast-method-call-function fmc))
+ (pv-cell (fast-method-call-pv-cell fmc))
+ (arg-info (fast-method-call-arg-info fmc))
+ (nreq (car arg-info))
+ (restp (cdr arg-info)))
+ (lambda (method-args next-methods)
+ (let* ((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))))))
+
+(defun get-pv-cell (method-args pv-table)
+ (let ((pv-wrappers (pv-wrappers-from-all-args pv-table method-args)))
+ (when pv-wrappers
+ (pv-table-lookup pv-table pv-wrappers))))
(defun pv-table-lookup-pv-args (pv-table &rest pv-parameters)
(pv-table-lookup pv-table (pv-wrappers-from-pv-args pv-parameters)))
projects / sbcl.git / blobdiff