[armedbear-cvs] r12184 - trunk/abcl/src/org/armedbear/lisp
Erik Huelsmann
ehuelsmann at common-lisp.net
Sat Oct 10 12:15:23 UTC 2009
Author: ehuelsmann
Date: Sat Oct 10 08:15:20 2009
New Revision: 12184
Log:
Replace "cons + compile" with "use closure" where ever possible.
This should mean a performance increase.
Modified:
trunk/abcl/src/org/armedbear/lisp/clos.lisp
Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sat Oct 10 08:15:20 2009
@@ -872,10 +872,8 @@
(setf (classes-to-emf-table gf) (make-hash-table :test #'equal))
(%init-eql-specializations gf (collect-eql-specializer-objects gf))
(set-funcallable-instance-function
- gf
- (make-closure `(lambda (&rest args)
- (initial-discriminating-function ,gf args))
- nil))
+ gf #'(lambda (&rest args)
+ (initial-discriminating-function gf args)))
;; FIXME Do we need to warn on redefinition somewhere else?
(let ((*warn-on-redefinition* nil))
(setf (fdefinition (%generic-function-name gf)) gf))
@@ -1210,130 +1208,135 @@
(defun std-compute-discriminating-function (gf)
(let ((code
- (cond ((and (= (length (generic-function-methods gf)) 1)
- (typep (car (generic-function-methods gf)) 'standard-reader-method))
-;; (sys::%format t "standard reader function ~S~%" (generic-function-name gf))
- (make-closure
- (let* ((method (%car (generic-function-methods gf)))
- (class (car (%method-specializers method)))
- (slot-name (reader-method-slot-name method)))
- `(lambda (arg)
- (declare (optimize speed))
- (let* ((layout (std-instance-layout arg))
- (location (get-cached-slot-location ,gf layout)))
- (unless location
- (unless (simple-typep arg ,class)
- ;; FIXME no applicable method
- (error 'simple-type-error
- :datum arg
- :expected-type ,class))
- (setf location (slow-reader-lookup ,gf layout ',slot-name)))
- (if (consp location)
- ;; Shared slot.
- (cdr location)
- (standard-instance-access arg location)))))
- nil))
- (t
- (let* ((emf-table (classes-to-emf-table gf))
- (number-required (length (gf-required-args gf)))
- (lambda-list (%generic-function-lambda-list gf))
- (exact (null (intersection lambda-list
- '(&rest &optional &key
- &allow-other-keys &aux)))))
- (make-closure
- (cond ((= number-required 1)
- (if exact
- (cond ((and (eq (generic-function-method-combination gf) 'standard)
- (= (length (generic-function-methods gf)) 1))
- (let* ((method (%car (generic-function-methods gf)))
- (specializer (car (%method-specializers method)))
- (function (or (%method-fast-function method)
- (%method-function method))))
- (if (eql-specializer-p specializer)
- (let ((specializer-object (eql-specializer-object specializer)))
- `(lambda (arg)
- (declare (optimize speed))
- (if (eql arg ',specializer-object)
- (funcall ,function arg)
- (no-applicable-method ,gf (list arg)))))
- `(lambda (arg)
- (declare (optimize speed))
- (unless (simple-typep arg ,specializer)
- ;; FIXME no applicable method
- (error 'simple-type-error
- :datum arg
- :expected-type ,specializer))
- (funcall ,function arg)))))
- (t
- `(lambda (arg)
- (declare (optimize speed))
- (let* ((specialization (%get-arg-specialization ,gf arg))
- (emfun (or (gethash1 specialization ,emf-table)
- (slow-method-lookup-1 ,gf arg specialization))))
- (if emfun
- (funcall emfun (list arg))
- (apply #'no-applicable-method ,gf (list arg)))))
- ))
- `(lambda (&rest args)
- (declare (optimize speed))
- (unless (>= (length args) 1)
- (error 'program-error
- :format-control "Not enough arguments for generic function ~S."
- :format-arguments (list (%generic-function-name ,gf))))
- (let ((emfun (get-cached-emf ,gf args)))
- (if emfun
- (funcall emfun args)
- (slow-method-lookup ,gf args))))))
- ((= number-required 2)
- (if exact
- `(lambda (arg1 arg2)
- (declare (optimize speed))
- (let* ((args (list arg1 arg2))
- (emfun (get-cached-emf ,gf args)))
- (if emfun
- (funcall emfun args)
- (slow-method-lookup ,gf args))))
- `(lambda (&rest args)
- (declare (optimize speed))
- (unless (>= (length args) 2)
- (error 'program-error
- :format-control "Not enough arguments for generic function ~S."
- :format-arguments (list (%generic-function-name ,gf))))
- (let ((emfun (get-cached-emf ,gf args)))
- (if emfun
- (funcall emfun args)
- (slow-method-lookup ,gf args))))))
- ((= number-required 3)
- (if exact
- `(lambda (arg1 arg2 arg3)
- (declare (optimize speed))
- (let* ((args (list arg1 arg2 arg3))
- (emfun (get-cached-emf ,gf args)))
- (if emfun
- (funcall emfun args)
- (slow-method-lookup ,gf args))))
- `(lambda (&rest args)
- (declare (optimize speed))
- (unless (>= (length args) 3)
- (error 'program-error
- :format-control "Not enough arguments for generic function ~S."
- :format-arguments (list (%generic-function-name ,gf))))
- (let ((emfun (get-cached-emf ,gf args)))
- (if emfun
- (funcall emfun args)
- (slow-method-lookup ,gf args))))))
- (t
- `(lambda (&rest args)
- (declare (optimize speed))
- (unless (,(if exact '= '>=) (length args) ,number-required)
- (error 'program-error
- :format-control "Not enough arguments for generic function ~S."
- :format-arguments (list (%generic-function-name ,gf))))
- (let ((emfun (get-cached-emf ,gf args)))
- (if emfun
- (funcall emfun args)
- (slow-method-lookup ,gf args))))))
- nil))))))
+ (cond
+ ((and (= (length (generic-function-methods gf)) 1)
+ (typep (car (generic-function-methods gf)) 'standard-reader-method))
+ ;; (sys::%format t "standard reader function ~S~%" (generic-function-name gf))
+
+ (let* ((method (%car (generic-function-methods gf)))
+ (class (car (%method-specializers method)))
+ (slot-name (reader-method-slot-name method)))
+ #'(lambda (arg)
+ (declare (optimize speed))
+ (let* ((layout (std-instance-layout arg))
+ (location (get-cached-slot-location gf layout)))
+ (unless location
+ (unless (simple-typep arg class)
+ ;; FIXME no applicable method
+ (error 'simple-type-error
+ :datum arg
+ :expected-type class))
+ (setf location (slow-reader-lookup gf layout slot-name)))
+ (if (consp location)
+ ;; Shared slot.
+ (cdr location)
+ (standard-instance-access arg location))))))
+
+ (t
+ (let* ((emf-table (classes-to-emf-table gf))
+ (number-required (length (gf-required-args gf)))
+ (lambda-list (%generic-function-lambda-list gf))
+ (exact (null (intersection lambda-list
+ '(&rest &optional &key
+ &allow-other-keys &aux)))))
+ (cond
+ ((= number-required 1)
+ (if exact
+ (cond
+ ((and (eq (generic-function-method-combination gf) 'standard)
+ (= (length (generic-function-methods gf)) 1))
+ (let* ((method (%car (generic-function-methods gf)))
+ (specializer (car (%method-specializers method)))
+ (function (or (%method-fast-function method)
+ (%method-function method))))
+ (if (eql-specializer-p specializer)
+ (let ((specializer-object (eql-specializer-object specializer)))
+ #'(lambda (arg)
+ (declare (optimize speed))
+ (if (eql arg specializer-object)
+ (funcall function arg)
+ (no-applicable-method gf (list arg)))))
+ #'(lambda (arg)
+ (declare (optimize speed))
+ (unless (simple-typep arg specializer)
+ ;; FIXME no applicable method
+ (error 'simple-type-error
+ :datum arg
+ :expected-type specializer))
+ (funcall function arg)))))
+ (t
+ #'(lambda (arg)
+ (declare (optimize speed))
+ (let* ((specialization
+ (%get-arg-specialization gf arg))
+ (emfun (or (gethash1 specialization
+ emf-table)
+ (slow-method-lookup-1
+ gf arg specialization))))
+ (if emfun
+ (funcall emfun (list arg))
+ (apply #'no-applicable-method gf (list arg)))))
+ ))
+ #'(lambda (&rest args)
+ (declare (optimize speed))
+ (unless (>= (length args) 1)
+ (error 'program-error
+ :format-control "Not enough arguments for generic function ~S."
+ :format-arguments (list (%generic-function-name gf))))
+ (let ((emfun (get-cached-emf gf args)))
+ (if emfun
+ (funcall emfun args)
+ (slow-method-lookup gf args))))))
+ ((= number-required 2)
+ (if exact
+ #'(lambda (arg1 arg2)
+ (declare (optimize speed))
+ (let* ((args (list arg1 arg2))
+ (emfun (get-cached-emf gf args)))
+ (if emfun
+ (funcall emfun args)
+ (slow-method-lookup gf args))))
+ #'(lambda (&rest args)
+ (declare (optimize speed))
+ (unless (>= (length args) 2)
+ (error 'program-error
+ :format-control "Not enough arguments for generic function ~S."
+ :format-arguments (list (%generic-function-name gf))))
+ (let ((emfun (get-cached-emf gf args)))
+ (if emfun
+ (funcall emfun args)
+ (slow-method-lookup gf args))))))
+ ((= number-required 3)
+ (if exact
+ #'(lambda (arg1 arg2 arg3)
+ (declare (optimize speed))
+ (let* ((args (list arg1 arg2 arg3))
+ (emfun (get-cached-emf gf args)))
+ (if emfun
+ (funcall emfun args)
+ (slow-method-lookup gf args))))
+ #'(lambda (&rest args)
+ (declare (optimize speed))
+ (unless (>= (length args) 3)
+ (error 'program-error
+ :format-control "Not enough arguments for generic function ~S."
+ :format-arguments (list (%generic-function-name gf))))
+ (let ((emfun (get-cached-emf gf args)))
+ (if emfun
+ (funcall emfun args)
+ (slow-method-lookup gf args))))))
+ (t
+ (make-closure
+ `(lambda (&rest args)
+ (declare (optimize speed))
+ (unless (,(if exact '= '>=) (length args) ,number-required)
+ (error 'program-error
+ :format-control "Not enough arguments for generic function ~S."
+ :format-arguments (list (%generic-function-name ,gf))))
+ (let ((emfun (get-cached-emf ,gf args)))
+ (if emfun
+ (funcall emfun args)
+ (slow-method-lookup ,gf args)))) nil))))))))
(when (and (fboundp 'autocompile)
(not (autoloadp 'compile)))
@@ -1472,52 +1475,55 @@
(setf around (car arounds))
(when (null primaries)
(error "No primary methods for the generic function ~S." gf))
- (cond (around
- (let ((next-emfun
- (funcall
- (if (eq (class-of gf) (find-class 'standard-generic-function))
- #'std-compute-effective-method-function
- #'compute-effective-method-function)
- gf (remove around methods))))
- (setf emf-form
-;; `(lambda (args)
-;; (funcall ,(%method-function around) args ,next-emfun))
- (generate-emf-lambda (%method-function around) next-emfun)
- )))
- ((eq mc-name 'standard)
- (let* ((next-emfun (compute-primary-emfun (cdr primaries)))
- (befores (remove-if-not #'before-method-p methods))
- (reverse-afters
- (reverse (remove-if-not #'after-method-p methods))))
- (setf emf-form
- (cond ((and (null befores) (null reverse-afters))
- (if (%method-fast-function (car primaries))
- (ecase (length (gf-required-args gf))
- (1
- `(lambda (args)
- (declare (optimize speed))
- (funcall ,(%method-fast-function (car primaries)) (car args))))
- (2
- `(lambda (args)
- (declare (optimize speed))
- (funcall ,(%method-fast-function (car primaries))
- (car args)
- (cadr args)))))
-;; `(lambda (args)
-;; (declare (optimize speed))
-;; (funcall ,(%method-function (car primaries)) args ,next-emfun))
- (generate-emf-lambda (%method-function (car primaries))
- next-emfun)
- ))
- (t
- `(lambda (args)
- (declare (optimize speed))
- (dolist (before ',befores)
- (funcall (%method-function before) args nil))
- (multiple-value-prog1
- (funcall (%method-function ,(car primaries)) args ,next-emfun)
- (dolist (after ',reverse-afters)
- (funcall (%method-function after) args nil)))))))))
+ (cond
+ (around
+ (let ((next-emfun
+ (funcall
+ (if (eq (class-of gf) (find-class 'standard-generic-function))
+ #'std-compute-effective-method-function
+ #'compute-effective-method-function)
+ gf (remove around methods))))
+ (setf emf-form
+;;; `(lambda (args)
+;;; (funcall ,(%method-function around) args ,next-emfun))
+ (generate-emf-lambda (%method-function around) next-emfun)
+ )))
+ ((eq mc-name 'standard)
+ (let* ((next-emfun (compute-primary-emfun (cdr primaries)))
+ (befores (remove-if-not #'before-method-p methods))
+ (reverse-afters
+ (reverse (remove-if-not #'after-method-p methods))))
+ (setf emf-form
+ (cond
+ ((and (null befores) (null reverse-afters))
+ (let ((fast-function (%method-fast-function (car primaries))))
+
+ (if fast-function
+ (ecase (length (gf-required-args gf))
+ (1
+ #'(lambda (args)
+ (declare (optimize speed))
+ (funcall fast-function (car args))))
+ (2
+ #'(lambda (args)
+ (declare (optimize speed))
+ (funcall fast-function (car args) (cadr args)))))
+ ;; `(lambda (args)
+ ;; (declare (optimize speed))
+ ;; (funcall ,(%method-function (car primaries)) args ,next-emfun))
+ (generate-emf-lambda (%method-function (car primaries))
+ next-emfun))))
+ (t
+ (let ((method-function (%method-function (car primaries))))
+
+ #'(lambda (args)
+ (declare (optimize speed))
+ (dolist (before befores)
+ (funcall (%method-function before) args nil))
+ (multiple-value-prog1
+ (funcall method-function args next-emfun)
+ (dolist (after reverse-afters)
+ (funcall (%method-function after) args nil))))))))))
(t
(let ((mc-obj (get mc-name 'method-combination-object)))
(unless mc-obj
@@ -1539,9 +1545,9 @@
(coerce-to-function emf-form))))
(defun generate-emf-lambda (method-function next-emfun)
- `(lambda (args)
- (declare (optimize speed))
- (funcall ,method-function args ,next-emfun)))
+ #'(lambda (args)
+ (declare (optimize speed))
+ (funcall method-function args next-emfun)))
;;; compute an effective method function from a list of primary methods:
More information about the armedbear-cvs
mailing list