Skip to content
Snippets Groups Projects
Commit 5a8847ea authored by gerd's avatar gerd
Browse files

(defclass data () ((name :accessor name)))

	(defmethod name :before ((data data)))

	(name (make-instance 'data))
	 => too few args in a call to a method function

	This is caused by standard-reader/writer methods having a
	fast-function, but that's not the one that we should funcall if
	pcl::*inline-methods-in-emfs* is true.  Use the fast-method-call
	mechanism for such methods instead.

	* src/pcl/combin.lisp (inlinable-method-p): New function.
	(make-direct-calls): Removed.
	(memf-test-converter): Add a local function method-key for
	determining the function generator key.
	(memf-code-converter): Add local functions make-call and
	make-calls.  Generate direct calls if inlinable-method-p returns
	true.
parent 1434e8ef
No related branches found
No related tags found
No related merge requests found
...@@ -25,7 +25,7 @@ ...@@ -25,7 +25,7 @@
;;; ************************************************************************* ;;; *************************************************************************
(file-comment (file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/combin.lisp,v 1.20 2003/09/05 23:03:36 gerd Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/combin.lisp,v 1.21 2003/11/05 17:01:18 gerd Exp $")
(in-package "PCL") (in-package "PCL")
...@@ -467,10 +467,22 @@ ...@@ -467,10 +467,22 @@
,@check-applicable-keywords ,@check-applicable-keywords
,body)))))) ,body))))))
;;;
;;; Return true if a fast-method-call to METHOD can be inlined.
;;;
;;; We don't generate funcalls for standard accessor methods because
;;; they have a fast function, but that's not what is actually to be
;;; called. What is called is a closure over MAKE-STD-*-METHOD-FUNCTION.
;;;
(defun inlinable-method-p (method)
(and (eq *boot-state* 'complete)
*inline-methods-in-emfs*
(not (standard-accessor-method-p method))))
;;; ;;;
;;; Return a form for calling METHOD's fast function. METATYPES is a ;;; Return a form for calling METHOD's fast function. METATYPES is a
;;; list of metatypes, whose length is used to figure out the names of ;;; list of metatypes, whose length is used to figure out the names of
;;; required emf parameters. APPLY? true means the method has a &rest ;;; required emf parameters. REST? true means the method has a &rest
;;; arg. CALLABLE-VAR is the name of a closed-over variable ;;; arg. CALLABLE-VAR is the name of a closed-over variable
;;; containing a FAST-METHOD-CALL instance corresponding to the ;;; containing a FAST-METHOD-CALL instance corresponding to the
;;; method invocation. ;;; method invocation.
...@@ -484,27 +496,12 @@ ...@@ -484,27 +496,12 @@
(assert (fboundp fn-name)) (assert (fboundp fn-name))
`(funcall ,fn ,cell ,next ,@req ,@(when rest? `(.dfun-rest-arg.))))) `(funcall ,fn ,cell ,next ,@req ,@(when rest? `(.dfun-rest-arg.)))))
;;;
;;; Return a form for successive calls to the fast functions of
;;; the methods in METHODS. LIST-VAR is the name of a
;;; variable containing a list of FAST-METHOD-CALL structures
;;; corresponding to the method function calls.
;;;
(defun make-direct-calls (methods metatypes rest? list-var)
(collect ((calls))
(dolist (method methods)
(calls `(let ((.call. (pop .list.)))
,(make-direct-call method metatypes rest? '.call.))))
`(let ((.list. ,list-var))
(declare (ignorable .list.))
,@(calls))))
;;; ;;;
;;; Return the list of methods from a CALL-METHOD-LIST form. ;;; Return the list of methods from a CALL-METHOD-LIST form.
;;; ;;;
(defun call-method-list-methods (call-method-list) (defun call-method-list-methods (call-method-list)
(mapcar (lambda (call-method) (cadr call-method)) (loop for call-method-form in (cdr call-method-list)
(cdr call-method-list))) collect (second call-method-form)))
;;; ;;;
;;; Compute a key from FORM. This function is called via the ;;; Compute a key from FORM. This function is called via the
...@@ -515,29 +512,28 @@ ...@@ -515,29 +512,28 @@
;;; key, a previously compiled function can be used. ;;; key, a previously compiled function can be used.
;;; ;;;
(defun memf-test-converter (form gf method-alist-p wrappers-p) (defun memf-test-converter (form gf method-alist-p wrappers-p)
(case (car-safe form) (flet ((method-key (method)
;; (if (inlinable-method-p method)
(call-method (method-function-name method)
(case (get-method-call-type gf form method-alist-p wrappers-p) '.fast-call-method.)))
(fast-method-call (case (car-safe form)
(let ((method (cadr form))) ;;
(if (and (eq *boot-state* 'complete) *inline-methods-in-emfs*) (call-method
(method-function-name method) (if (eq (get-method-call-type gf form method-alist-p wrappers-p)
'.fast-call-method.))) 'fast-method-call)
(t '.call-method.))) (method-key (second form))
;; '.call-method.))
(call-method-list ;;
(case (get-method-list-call-type gf form method-alist-p wrappers-p) (call-method-list
(fast-method-call (if (eq (get-method-list-call-type gf form method-alist-p wrappers-p)
(if (and (eq *boot-state* 'complete) *inline-methods-in-emfs*) 'fast-method-call)
(mapcar #'method-function-name (call-method-list-methods form)) (mapcar #'method-key (call-method-list-methods form))
'.fast-call-method-list.)) '.call-method-list.))
(t '.call-method-list.))) ;;
;; (check-applicable-keywords
(check-applicable-keywords 'check-applicable-keywords)
'check-applicable-keywords) (t
(t (default-test-converter form)))))
(default-test-converter form))))
;;; ;;;
;;; This function is called via the GET-FUNCTION mechanism on forms of ;;; This function is called via the GET-FUNCTION mechanism on forms of
...@@ -545,46 +541,48 @@ ...@@ -545,46 +541,48 @@
;;; lambda. Second value is a list of variable names that become ;;; lambda. Second value is a list of variable names that become
;;; closure variables. ;;; closure variables.
;;; ;;;
(defun memf-code-converter (form gf metatypes applyp method-alist-p (defun memf-code-converter (form gf metatypes rest? method-alist-p
wrappers-p) wrappers-p)
(case (car-safe form) (labels ((make-call (call-type method metatypes rest? callable-var)
;; (if (and (eq call-type 'fast-method-call)
;; (CALL-METHOD <method-object> &optional <next-methods>) (inlinable-method-p method))
(call-method (make-direct-call method metatypes rest? callable-var)
(let ((method (cadr form)) (make-emf-call metatypes rest? callable-var call-type)))
(callable-var (gensym))
(call-type (get-method-call-type gf form method-alist-p (make-calls (call-type methods metatypes rest? list-var)
wrappers-p))) `(let ((.list. ,list-var))
(if (and (eq call-type 'fast-method-call) (declare (ignorable .list.))
(eq *boot-state* 'complete) ,@(loop for method in methods collect
*inline-methods-in-emfs*) `(let ((.call. (pop .list.)))
(values (make-direct-call method metatypes applyp callable-var) ,(make-call call-type method metatypes
(list callable-var)) rest? '.call.))))))
(values (make-emf-call metatypes applyp callable-var call-type) (case (car-safe form)
(list callable-var))))) ;;
;; ;; (CALL-METHOD <method-object> &optional <next-methods>)
;; (CALL-METHOD-LIST <call-method-form>*) (call-method
;; where each CALL-METHOD form is (CALL-METHOD <method>) (let ((method (cadr form))
(call-method-list (callable-var (gensym))
(let ((list-var (gensym)) (call-type (get-method-call-type gf form method-alist-p
(call-type (get-method-list-call-type gf form method-alist-p wrappers-p)))
wrappers-p))) (values (make-call call-type method metatypes rest? callable-var)
(if (and (eq call-type 'fast-method-call) (list callable-var))))
(eq *boot-state* 'complete) ;;
*inline-methods-in-emfs*) ;; (CALL-METHOD-LIST <call-method-form>*)
(let ((methods (call-method-list-methods form))) ;; where each CALL-METHOD form is (CALL-METHOD <method>)
(values (make-direct-calls methods metatypes applyp list-var) (call-method-list
(list list-var))) (let ((list-var (gensym))
(values `(dolist (.tem. ,list-var) (call-type (get-method-list-call-type gf form method-alist-p
,(make-emf-call metatypes applyp '.tem. call-type)) wrappers-p))
(list list-var))))) (methods (call-method-list-methods form)))
;; (values (make-calls call-type methods metatypes rest? list-var)
(check-applicable-keywords (list list-var))))
(values `(check-applicable-keywords .dfun-rest-arg. ;;
.keyargs-start. .valid-keys.) (check-applicable-keywords
'(.keyargs-start. .valid-keys.))) (values `(check-applicable-keywords .dfun-rest-arg.
(t .keyargs-start. .valid-keys.)
(default-code-converter form)))) '(.keyargs-start. .valid-keys.)))
(t
(default-code-converter form)))))
(defun memf-constant-converter (form gf) (defun memf-constant-converter (form gf)
(case (car-safe form) (case (car-safe form)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment