(setf (pvref pv i) (cdr map))))))
(incf param))))))
\f
-(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))
-\f
(defun can-optimize-access (form required-parameters env)
(let ((type (ecase (car form)
(slot-value 'reader)
;; 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))))
(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
`(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
`(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)
(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))
;; 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+)
,(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)))))))
,(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)))))))
(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
(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))
(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)))
when snl
collect w into result
finally (return (if (cdr result) result (car result)))))
+
projects / sbcl.git / blobdiff