X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fpcl%2Fvector.lisp;h=2b4f2d21d6e718646e08aba3e5d99a22dd46f6a9;hb=a41e7cf8667de9ae078a8e318e8c5c045cdee87d;hp=902a89e2e3e2a7779c29cc009983415232858ebb;hpb=447477e72bd4fe54e678a28bdcc4a2802797d6ed;p=sbcl.git diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index 902a89e..2b4f2d2 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -306,54 +306,6 @@ (setf (pvref pv i) (cdr map)))))) (incf param)))))) -(defun maybe-expand-accessor-form (form required-parameters slots env) - (let* ((fname (car form)) - #||(len (length form))||# - (gf (if (symbolp fname) - (unencapsulated-fdefinition fname) - (gdefinition fname)))) - (macrolet ((maybe-optimize-reader () - `(let ((parameter - (can-optimize-access1 (cadr form) - required-parameters env))) - (when parameter - (optimize-reader slots parameter gf-name form)))) - (maybe-optimize-writer () - `(let ((parameter - (can-optimize-access1 (caddr form) - required-parameters env))) - (when parameter - (optimize-writer slots parameter gf-name form))))) - (unless (and (consp (cadr form)) - (eq 'instance-accessor-parameter (caadr form))) - (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 - env - slots - calls) - (declare (ignore required-parameters env slots calls)) - (or ; (optimize-reader ...)? - form)) - (defun can-optimize-access (form required-parameters env) (let ((type (ecase (car form) (slot-value 'reader) @@ -427,10 +379,10 @@ ;; 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 + ;; SLOTS. If that mutation isn't done 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)))) @@ -459,9 +411,16 @@ (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)) + (cond ((safe-code-p env) + ;; Don't optimize slot value setting in safe code, since the + ;; optimized version will fail to catch some type errors + ;; (for example when a subclass declares a tighter type for + ;; the slot than a superclass). + `(safe-set-slot-value ,@(cdr form))) + ((parameter-modified-p parameter-name env) + `(accessor-set-slot-value ,@(cdr form))) + (t + optimized-form))) (defun optimize-slot-boundp (slots sparameter form) (if sparameter @@ -504,18 +463,6 @@ `(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) - form)) - -(defun optimize-writer (slots sparameter gf-name form) - (if sparameter - (destructuring-bind (ignore1 ignore2 new-value) form - (declare (ignore ignore1 ignore2)) - (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 @@ -562,84 +509,6 @@ `(instance-boundp ,pv-offset-form ,parameter ,position ',slot-name ',class))))))) -(defun optimize-accessor-call (slots read/write sparameter gf-name new-value) - (let* ((class (if (consp sparameter) (cdr sparameter) *the-class-t*)) - (parameter (if (consp sparameter) (car sparameter) sparameter)) - (parameter-entry (assq parameter slots)) - (name (case read/write - (:read `(reader ,gf-name)) - (:write `(writer ,gf-name)))) - (slot-entry (assoc name (cdr parameter-entry) :test #'equal)) - (position (posq parameter-entry slots)) - (pv-offset-form (list 'pv-offset ''.PV-OFFSET.))) - (unless parameter-entry - (error "slot optimization bewilderment: O-A-C")) - (unless slot-entry - (setq slot-entry (list name)) - (push slot-entry (cdr parameter-entry))) - (push pv-offset-form (cdr slot-entry)) - (ecase read/write - (:read - `(instance-reader ,pv-offset-form ,parameter ,position ,gf-name ',class)) - (:write - `(let ((.new-value. ,new-value)) - (instance-writer ,pv-offset-form ,parameter ,position ,gf-name ',class - .new-value.)))))) - -(defvar *unspecific-arg* '..unspecific-arg..) - -(defun optimize-gf-call-internal (form slots env) - (when (and (consp form) - (eq (car form) 'the)) - (setq form (caddr form))) - (or (and (symbolp form) - (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 (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 (constant-form-value form))) - (if (symbolp form) - form - *unspecific-arg*)) - *unspecific-arg*))) - -(defun optimize-gf-call (slots calls gf-call-form nreq restp env) - (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)) - (if all-args-p - args - required-args)))) - (call-entry (assoc call-spec calls :test #'equal)) - (pv-offset-form (list 'pv-offset ''.PV-OFFSET.))) - (unless (some #'integerp - (let ((spec-args (cdr call-spec))) - (if all-args-p - (ldiff spec-args (nthcdr nreq spec-args)) - spec-args))) - (return-from optimize-gf-call nil)) - (unless call-entry - (setq call-entry (list call-spec)) - (push call-entry (cdr calls))) - (push pv-offset-form (cdr call-entry)) - (if (eq (car call-spec) 'make-instance) - `(funcall (pv-ref .pv. ,pv-offset-form) ,@(cdr gf-call-form)) - `(let ((.emf. (pv-ref .pv. ,pv-offset-form))) - (invoke-effective-method-function .emf. ,restp - ,@required-args ,@(when restp `((list ,@non-required-args))))))))) - (define-walker-template pv-offset) ; These forms get munged by mutate slots. (defmacro pv-offset (arg) arg) (define-walker-template instance-accessor-parameter) @@ -675,10 +544,10 @@ (eq *boot-state* 'complete) (not (slot-accessor-std-p slotd type))))) -(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) +(defmacro instance-read-internal (pv slots pv-offset default &optional kind) + (unless (member kind '(nil :instance :class :default)) + (error "illegal kind argument to ~S: ~S" 'instance-read-internal kind)) + (if (eq kind :default) default (let* ((index (gensym)) (value index)) @@ -696,11 +565,11 @@ ;; to shut it up. (see also mail Rudi ;; Schlatte sbcl-devel 2003-09-21) -- CSR, ;; 2003-11-30 - ,@(when (or (null type) (eq type :instance)) + ,@(when (or (null kind) (eq kind :instance)) `((fixnum (and ,slots ; KLUDGE (clos-slots-ref ,slots ,index))))) - ,@(when (or (null type) (eq type :class)) + ,@(when (or (null kind) (eq kind :class)) `((cons (cdr ,index)))) (t +slot-unbound+))) (if (eq ,value +slot-unbound+) @@ -715,28 +584,21 @@ ,(if (generate-fast-class-slot-access-p class slot-name) :class :instance)))) -(defmacro instance-reader (pv-offset parameter position gf-name class) - (declare (ignore class)) - `(instance-read-internal .pv. ,(slot-vector-symbol position) - ,pv-offset - (,gf-name (instance-accessor-parameter ,parameter)) - :instance)) - (defmacro instance-write-internal (pv slots pv-offset new-value default - &optional type) - (unless (member type '(nil :instance :class :default)) - (error "illegal type argument to ~S: ~S" 'instance-write-internal type)) - (if (eq type :default) + &optional kind) + (unless (member kind '(nil :instance :class :default)) + (error "illegal kind argument to ~S: ~S" 'instance-write-internal kind)) + (if (eq kind :default) default (let* ((index (gensym))) `(locally (declare #.*optimize-speed*) (let ((,index (pvref ,pv ,pv-offset))) (typecase ,index - ,@(when (or (null type) (eq type :instance)) + ,@(when (or (null kind) (eq kind :instance)) `((fixnum (and ,slots (setf (clos-slots-ref ,slots ,index) ,new-value))))) - ,@(when (or (null type) (eq type :class)) + ,@(when (or (null kind) (eq kind :class)) `((cons (setf (cdr ,index) ,new-value)))) (t ,default))))))) @@ -754,37 +616,21 @@ ,(if (generate-fast-class-slot-access-p class slot-name) :class :instance)))) -(defmacro instance-writer (pv-offset - parameter - position - gf-name - class - new-value) - (declare (ignore class)) - `(instance-write-internal .pv. ,(slot-vector-symbol position) - ,pv-offset ,new-value - (,(if (consp gf-name) - (get-setf-fun-name gf-name) - gf-name) - (instance-accessor-parameter ,parameter) - ,new-value) - :instance)) - (defmacro instance-boundp-internal (pv slots pv-offset default - &optional type) - (unless (member type '(nil :instance :class :default)) - (error "illegal type argument to ~S: ~S" 'instance-boundp-internal type)) - (if (eq type :default) + &optional kind) + (unless (member kind '(nil :instance :class :default)) + (error "illegal kind argument to ~S: ~S" 'instance-boundp-internal kind)) + (if (eq kind :default) default (let* ((index (gensym))) `(locally (declare #.*optimize-speed*) (let ((,index (pvref ,pv ,pv-offset))) (typecase ,index - ,@(when (or (null type) (eq type :instance)) + ,@(when (or (null kind) (eq kind :instance)) `((fixnum (not (and ,slots (eq (clos-slots-ref ,slots ,index) +slot-unbound+)))))) - ,@(when (or (null type) (eq type :class)) + ,@(when (or (null kind) (eq kind :class)) `((cons (not (eq (cdr ,index) +slot-unbound+))))) (t ,default))))))) @@ -1109,38 +955,91 @@ (make-method-initargs-form-internal1 initargs (cddr lmf) args lmf-params restp))))) +(defun lambda-list-parameter-names (lambda-list) + ;; Given a valid lambda list, extract the parameter names. + (loop for x in lambda-list + with res = nil + do (unless (member x lambda-list-keywords) + (if (consp x) + (let ((name (car x))) + (if (consp name) + ;; ... ((:BAR FOO) 1) + (push (second name) res) + ;; ... (FOO 1) + (push name res)) + ;; ... (... 1 FOO-P) + (let ((name-p (cddr x))) + (when name-p + (push (car name-p) res)))) + ;; ... FOO + (push x res))) + finally (return res))) + (defun make-method-initargs-form-internal1 (initargs body req-args lmf-params restp) - (multiple-value-bind (outer-decls inner-decls body-sans-decls) - (split-declarations - body req-args (or (getf (cdr lmf-params) :call-next-method-p) - (getf (cdr lmf-params) :setq-p))) - (let* ((rest-arg (when restp '.rest-arg.)) - (args+rest-arg (if restp - (append req-args (list rest-arg)) - req-args))) - `(list* - :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)))) + (let* (;; The lambda-list of the method, minus specifiers + (lambda-list (car lmf-params)) + ;; Names of the parameters that will be in the outermost lambda-list + ;; (and whose bound declarations thus need to be in OUTER-DECLS). + (outer-parameters req-args) + ;; The lambda-list used by BIND-ARGS + (bind-list lambda-list) + (setq-p (getf (cdr lmf-params) :setq-p)) + (auxp (member '&aux bind-list)) + (call-next-method-p (getf (cdr lmf-params) :call-next-method-p))) + ;; Try to use the normal function call machinery instead of BIND-ARGS + ;; binding the arguments, unless: + (unless (or ;; If all arguments are required, BIND-ARGS will be a no-op + ;; in any case. + (and (not restp) (not auxp)) + ;; CALL-NEXT-METHOD wants to use BIND-ARGS, and needs a + ;; list of all non-required arguments. + call-next-method-p) + (setf ;; We don't want a binding for .REST-ARG. + restp nil + ;; Get all the parameters for declaration parsing + outer-parameters (lambda-list-parameter-names lambda-list) + ;; Ensure that BIND-ARGS won't do anything (since + ;; BIND-LIST won't contain any non-required parameters, + ;; and REQ-ARGS will be of an equal length). We still want + ;; to pass BIND-LIST to FAST-LEXICAL-METHOD-FUNCTIONS so + ;; that BIND-FAST-LEXICAL-METHOD-FUNCTIONS can take care + ;; of rebinding SETQd required arguments around the method + ;; body. + bind-list req-args)) + (multiple-value-bind (outer-decls inner-decls body-sans-decls) + (split-declarations + body outer-parameters (or call-next-method-p setq-p)) + (let* ((rest-arg (when restp + '.rest-arg.)) + (fmf-lambda-list (if rest-arg + (append req-args (list '&rest rest-arg)) + (if call-next-method-p + req-args + lambda-list)))) + `(list* + :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)))) + ;; The lambda-list of the FMF + (.pv-cell. .next-method-call. ,@fmf-lambda-list) + ;; 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 + (,bind-list .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 ;;; better. It doesn't really matter, though, because a function @@ -1169,11 +1068,7 @@ (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))))) + (apply fmf pv-cell nmc method-args)))) ;; FIXME: this looks dangerous. (let* ((fname (%fun-name fmf))) (when (and fname (eq (car fname) 'fast-method)) @@ -1199,11 +1094,7 @@ (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)))))) + (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))) @@ -1235,3 +1126,4 @@ when snl collect w into result finally (return (if (cdr result) result (car result))))) +