From 6e58b9c402e25e5f3b5a00a88c16460e87d214dc Mon Sep 17 00:00:00 2001 From: Juanjo Garcia-Ripoll Date: Wed, 25 Apr 2012 17:23:23 +0200 Subject: [PATCH] The method combination slot in a generic function is now precomputed using FIND-METHOD-COMBINATION. --- src/CHANGELOG | 3 +++ src/clos/combin.lsp | 41 ++++++++++++++++++++++++++++++----------- src/clos/generic.lsp | 13 ++++--------- src/clos/kernel.lsp | 5 +++-- 4 files changed, 40 insertions(+), 22 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index 9c011365f..fff9f5220 100755 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -74,6 +74,9 @@ ECL 12.2.2: - When reinitializing a class instance, ECL would not remove the class from its former superclasses. + - The method combination slot of a generic function is now precomputed by + using FIND-METHOD-COMBINATION in SHARED-INITIALIZE. + ;;; Local Variables: *** ;;; mode:text *** ;;; fill-column:79 *** diff --git a/src/clos/combin.lsp b/src/clos/combin.lsp index 100683426..3f675e3fa 100644 --- a/src/clos/combin.lsp +++ b/src/clos/combin.lsp @@ -128,7 +128,6 @@ (funcall (first primary) .combined-method-args. (rest primary))))) (defun standard-compute-effective-method (gf methods) - (declare (si::c-local)) (let* ((before ()) (primary ()) (after ()) @@ -185,12 +184,32 @@ ;; and it outputs an anonymous function which is the effective method. ;; -(defparameter *method-combinations* '()) +#+threads +(defparameter *method-combinations-lock* (mp:make-lock :name 'find-method-combination)) +(defparameter *method-combinations* (make-hash-table :size 32 :test 'eq)) + +(defun search-method-combination (name) + (mp:with-lock (*method-combinations-lock*) + (or (gethash name *method-combinations*) + (error "~A does not name a method combination" name)))) (defun install-method-combination (name function) - (setf (getf *method-combinations* name) function) + (mp:with-lock (*method-combinations-lock*) + (setf (gethash name *method-combinations*) function)) name) +(defun method-combination-object-p (o) + (and (listp o) + (= (length o) 3) + (eq (first o) + (mp:with-lock (*method-combinations-lock*) + (gethash (third o) *method-combinations*))))) + +(defun find-method-combination (gf method-combination-type-name method-combination-options) + (list (search-method-combination method-combination-type-name) + method-combination-options + method-combination-type-name)) + (defun define-simple-method-combination (name &key documentation identity-with-one-argument (operator name)) @@ -302,19 +321,19 @@ ;;; (defun std-compute-effective-method (gf method-combination applicable-methods) - (let* ((method-combination-name (car method-combination)) - (method-combination-args (cdr method-combination))) - (if (eq method-combination-name 'STANDARD) - (standard-compute-effective-method gf applicable-methods) - (apply (or (getf *method-combinations* method-combination-name) - (error "~S is not a valid method combination object" - method-combination)) + (let* ((method-combination-function (first method-combination)) + (method-combination-args (second method-combination))) + (if method-combination-args + (apply method-combination-function gf applicable-methods - method-combination-args)))) + method-combination-args) + (funcall method-combination-function + gf applicable-methods)))) ;; ;; These method combinations are bytecompiled, for simplicity. ;; +(install-method-combination 'standard 'standard-compute-effective-method) (eval '(progn (define-method-combination progn :identity-with-one-argument t) (define-method-combination and :identity-with-one-argument t) diff --git a/src/clos/generic.lsp b/src/clos/generic.lsp index 6d1ef400b..007904119 100644 --- a/src/clos/generic.lsp +++ b/src/clos/generic.lsp @@ -120,7 +120,6 @@ (argument-precedence-order nil a-o-p) (documentation nil) (declarations nil) - method-combination (method-class (find-class 'method)) ) (declare (ignore initargs slot-names)) @@ -142,14 +141,6 @@ :format-arguments (list documentation) :datum documentation :expected-type '(or null string))) - (unless (or (null method-combination) - (and (listp method-combination) - (member (first method-combination) *method-combinations*))) - (error 'simple-type-error - :format-control "Not a valid method combination, ~A" - :format-arguments (list method-combination) - :datum method-combination - :expected-type 'list)) (unless (si::subclassp method-class (find-class 'method)) (error 'simple-type-error :format-control "Not a valid method class, ~A" @@ -167,6 +158,10 @@ (simple-program-error "Cannot replace the lambda list of ~A with ~A because it is incongruent with some of the methods" gfun lambda-list))) (call-next-method) + (let ((combination (generic-function-method-combination gfun))) + (unless (method-combination-object-p combination) + (setf (generic-function-method-combination gfun) + (find-method-combination gfun (first combination) (rest combination))))) (when (and l-l-p (not a-o-p)) (setf (generic-function-argument-precedence-order gfun) (lambda-list-required-arguments lambda-list))) diff --git a/src/clos/kernel.lsp b/src/clos/kernel.lsp index 0b96f9799..845bf2fef 100644 --- a/src/clos/kernel.lsp +++ b/src/clos/kernel.lsp @@ -126,7 +126,7 @@ :accessor generic-function-name) (spec-list :initform nil :accessor generic-function-spec-list) (method-combination - :initarg :method-combination :initform '(standard) + :initarg :method-combination :initform '(standard-compute-effective-method nil standard) :accessor generic-function-method-combination) (lambda-list :initarg :lambda-list :accessor generic-function-lambda-list) @@ -253,7 +253,8 @@ (si::instance-sig-set gfun) (setf (generic-function-name gfun) name (generic-function-lambda-list gfun) lambda-list - (generic-function-method-combination gfun) '(standard) + (generic-function-method-combination gfun) + (find-method-combination gfun 'standard nil) (generic-function-methods gfun) nil (generic-function-spec-list gfun) nil (generic-function-dependents gfun) nil)