267 lines
8.8 KiB
Common Lisp
267 lines
8.8 KiB
Common Lisp
;; clos.lisp -- CLOS benchmarking code
|
|
;;
|
|
;; Author: Eric Marsden <emarsden@laas.fr>
|
|
;; Time-stamp: <2004-03-10 emarsden>
|
|
;; 20030203 james.anderson@setf.de changes to distinguish first from
|
|
;; successive passes
|
|
;;
|
|
;;
|
|
;; This file does some benchmarking of CLOS functionality. It creates
|
|
;; a class hierarchy of the form
|
|
;;
|
|
;; class-0-0
|
|
;; / | \
|
|
;; / | \
|
|
;; / | \
|
|
;; class-0-1 class-1-1 . class-2-1
|
|
;; | / | . . / |
|
|
;; | / . | . / |
|
|
;; | / . | / |
|
|
;; class-0-2 class-1-2 class-2-2
|
|
;;
|
|
;;
|
|
;; where the shape of the hierarchy is controlled by the parameters
|
|
;; +HIERARCHY-DEPTH+ and +HIERARCHY-WIDTH+. Note that classes to the
|
|
;; left of the diagram have more superclasses than those to the right.
|
|
;; It then defines methods specializing on each class (simple methods,
|
|
;; after methods and AND-type method combination), and
|
|
;; INITIALIZE-INSTANCE methods. The code measures the speed of
|
|
;;
|
|
;; - creation of the class hierarchy (time taken to compile and
|
|
;; execute the DEFCLASS forms)
|
|
;;
|
|
;; - instance creation
|
|
;;
|
|
;; - method definition (time taken to compile and execute the
|
|
;; DEFMETHOD forms)
|
|
;;
|
|
;; - execution of "simple" method invocations, both with and
|
|
;; without :after methods
|
|
;;
|
|
;; - execution of "complex" method invocations (using AND-type
|
|
;; method combination)
|
|
;;
|
|
;;
|
|
;; This code is probably not representative of real usage of CLOS, but
|
|
;; should give an idea of the speed of a particular CLOS
|
|
;; implementation.
|
|
;;
|
|
;; Note: warnings about undefined accessors and types are normal when
|
|
;; compiling this code.
|
|
|
|
|
|
(in-package :cl-bench.clos)
|
|
|
|
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(defconstant +hierarchy-depth+ 10)
|
|
(defconstant +hierarchy-width+ 5))
|
|
|
|
|
|
;; the level-0 hierarchy
|
|
(defclass class-0-0 () ())
|
|
|
|
(defvar *instances* (make-array +hierarchy-width+ :element-type 'class-0-0))
|
|
|
|
(when (fboundp 'simple-method) (fmakunbound 'simple-method))
|
|
(when (fboundp 'complex-method) (fmakunbound 'complex-method))
|
|
|
|
(defgeneric simple-method (a b))
|
|
|
|
(defmethod simple-method ((self class-0-0) other) other)
|
|
|
|
#-(or poplog)
|
|
(defgeneric complex-method (a b &rest rest)
|
|
(:method-combination and))
|
|
|
|
#-(or poplog)
|
|
(defmethod complex-method and ((self class-0-0) other &rest rest)
|
|
(declare (ignore rest))
|
|
other)
|
|
|
|
(defmacro make-class-name (depth width)
|
|
(with-standard-io-syntax
|
|
`(intern (format nil "CLASS-~d-~d" ,depth ,width))))
|
|
|
|
(defmacro make-attribute-name (depth width)
|
|
(with-standard-io-syntax
|
|
`(intern (format nil "ATTRIBUTE-~d-~d" ,depth ,width))))
|
|
|
|
(defmacro make-initarg-name (depth width)
|
|
(with-standard-io-syntax
|
|
`(intern (format nil "INITARG-~d-~d" ,depth ,width) :keyword)))
|
|
|
|
(defmacro make-accessor-name (depth width)
|
|
(with-standard-io-syntax
|
|
`(intern (format nil "GET-ATTRIBUTE-~d-~d" ,depth ,width))))
|
|
|
|
(defmacro class-definition (depth width)
|
|
`(defclass ,(make-class-name depth width)
|
|
,(loop :for w :from width :below +hierarchy-width+
|
|
:collect (make-class-name (1- depth) w))
|
|
(( ,(make-attribute-name depth width)
|
|
:initarg ,(make-initarg-name depth width)
|
|
:initform (* ,depth ,width)
|
|
:accessor ,(make-accessor-name depth width)))))
|
|
|
|
(defmacro init-instance-definition (depth width)
|
|
`(defmethod initialize-instance :after ((self ,(make-class-name depth width)) &rest initargs)
|
|
(declare (ignore initargs))
|
|
(incf (,(make-accessor-name depth width) self))))
|
|
|
|
(defmacro simple-method-definition (depth width)
|
|
`(defmethod simple-method ((self ,(make-class-name depth width))
|
|
(n number))
|
|
(* n (call-next-method) (,(make-accessor-name depth width) self))))
|
|
|
|
(defmacro complex-method-definition (depth width)
|
|
`(defmethod complex-method and ((self ,(make-class-name depth width))
|
|
(n number) &rest rest)
|
|
(declare (ignore rest))
|
|
(,(make-accessor-name depth width) self)))
|
|
|
|
(defmacro after-method-definition (depth width)
|
|
`(defmethod simple-method :after ((self ,(make-class-name depth width))
|
|
(n number))
|
|
(setf (,(make-accessor-name depth width) self) ,(* depth width width))))
|
|
|
|
(defun defclass-forms ()
|
|
(let (forms)
|
|
(loop :for width :to +hierarchy-width+ :do
|
|
(push `(defclass ,(make-class-name 1 width) (class-0-0) ()) forms))
|
|
(loop :for dpth :from 2 :to +hierarchy-depth+ :do
|
|
(loop :for wdth :to +hierarchy-width+ :do
|
|
(push `(class-definition ,dpth ,wdth) forms)
|
|
(push `(init-instance-definition ,dpth ,wdth) forms)))
|
|
(nreverse forms)))
|
|
|
|
(defun defmethod-forms ()
|
|
(let (forms)
|
|
(loop :for dpth :from 2 to +hierarchy-depth+ :do
|
|
(loop :for wdth :to +hierarchy-width+ :do
|
|
(push `(simple-method-definition ,dpth ,wdth) forms)
|
|
#-(or poplog)
|
|
(push `(complex-method-definition ,dpth ,wdth) forms)))
|
|
(nreverse forms)))
|
|
|
|
(defun after-method-forms ()
|
|
(let (forms)
|
|
(loop :for depth :from 2 :to +hierarchy-depth+ :do
|
|
(loop :for width :to +hierarchy-width+ :do
|
|
(push `(after-method-definition ,depth ,width) forms)))
|
|
(nreverse forms)))
|
|
|
|
(defparameter *defclass-operator* nil)
|
|
|
|
(defun run-defclass ()
|
|
(setq *defclass-operator* (compile nil `(lambda () ,@(defclass-forms))))
|
|
(funcall *defclass-operator*))
|
|
|
|
(defun run-defclass-precompiled ()
|
|
(funcall *defclass-operator*))
|
|
|
|
(defparameter *defmethod-operator* nil)
|
|
|
|
(defun run-defmethod ()
|
|
(setq *defmethod-operator* (compile nil `(lambda () ,@(defmethod-forms))))
|
|
(funcall *defmethod-operator*))
|
|
|
|
(defun run-defmethod-precompiled ()
|
|
(funcall *defmethod-operator*))
|
|
|
|
(defun add-after-methods ()
|
|
(funcall (compile nil `(lambda () ,@(after-method-forms)))))
|
|
|
|
#+i-do-not-understand
|
|
(defun make-instances ()
|
|
(dotimes (i 5000)
|
|
(dotimes (w +hierarchy-width+)
|
|
(setf (aref *instances* w)
|
|
(make-instance (make-class-name +hierarchy-depth+ w)
|
|
(make-initarg-name +hierarchy-depth+ w) 42))
|
|
`(incf (slot-value (aref *instances* w) ',(make-attribute-name +hierarchy-depth+ w))))))
|
|
|
|
(defparameter *make-instances-operator* nil)
|
|
|
|
(defun make-instances ()
|
|
(setq *make-instances-operator*
|
|
(compile nil `(lambda ()
|
|
(dotimes (i 5000)
|
|
,@(let ((forms nil))
|
|
(dotimes (w +hierarchy-width+)
|
|
(push `(progn (setf (aref *instances* ,w)
|
|
(make-instance ',(make-class-name +hierarchy-depth+ w)
|
|
,(make-initarg-name +hierarchy-depth+ w) 42))
|
|
(incf (slot-value (aref *instances* ,w)
|
|
',(make-attribute-name +hierarchy-depth+ w))))
|
|
forms))
|
|
(reverse forms))))))
|
|
(funcall *make-instances-operator*))
|
|
|
|
(defun make-instances-precompiled ()
|
|
(funcall *make-instances-operator*))
|
|
|
|
;; the code in the function MAKE-INSTANCES is very difficult to
|
|
;; optimize, because the arguments to MAKE-INSTANCE are not constant.
|
|
;; This test attempts to simulate the common case where some of the
|
|
;; parameters to MAKE-INSTANCE are constants.
|
|
(defclass a-simple-base-class ()
|
|
((attribute-one :accessor attribute-one
|
|
:initarg :attribute-one
|
|
:type string)))
|
|
|
|
(defclass a-derived-class (a-simple-base-class)
|
|
((attribute-two :accessor attribute-two
|
|
:initform 42
|
|
:type integer)))
|
|
|
|
(defun make-instances/simple ()
|
|
(dotimes (i 5000)
|
|
(make-instance 'a-derived-class
|
|
:attribute-one "The first attribute"))
|
|
(dotimes (i 5000)
|
|
(make-instance 'a-derived-class
|
|
:attribute-one "The non-defaulting attribute")))
|
|
|
|
|
|
(defun methodcall/simple (num)
|
|
(dotimes (i 5000)
|
|
(simple-method (aref *instances* num) i)))
|
|
|
|
(defun methodcalls/simple ()
|
|
(dotimes (w +hierarchy-width+)
|
|
(methodcall/simple w)))
|
|
|
|
(defun methodcalls/simple+after ()
|
|
(add-after-methods)
|
|
(dotimes (w +hierarchy-width+)
|
|
(methodcall/simple w)))
|
|
|
|
#-(or poplog)
|
|
(defun methodcall/complex (num)
|
|
(dotimes (i 5000)
|
|
(complex-method (aref *instances* num) i)))
|
|
|
|
#-(or poplog)
|
|
(defun methodcalls/complex ()
|
|
(dotimes (w +hierarchy-width+)
|
|
(methodcall/complex w)))
|
|
|
|
|
|
|
|
;;; CLOS implementation of the Fibonnaci function, with EQL specialization
|
|
|
|
(defmethod eql-fib ((x (eql 0)))
|
|
1)
|
|
|
|
(defmethod eql-fib ((x (eql 1)))
|
|
1)
|
|
|
|
; a method for all other cases
|
|
(defmethod eql-fib (x)
|
|
(+ (eql-fib (- x 1))
|
|
(eql-fib (- x 2))))
|
|
|
|
|
|
;; EOF
|