src/pcl/time.lisp

   1 ;;;; FIXME: This should probably move to some separate tests or benchmarks
   2 ;;;; directory.
   3
   4 (in-package "SB-PCL")
   5
   6 (sb-int:file-comment
   7   "$Header$")
   8
   9 (declaim (optimize (speed 3) (safety 0) (compilation-speed 0)))
  10
  11 (defvar *tests*)
  12 (setq *tests* nil)
  13
  14 (defvar m (car (generic-function-methods #'shared-initialize)))
  15 (defvar gf #'shared-initialize)
  16 (defvar c (find-class 'standard-class))
  17
  18 (defclass str ()
  19   ((slot :initform nil :reader str-slot))
  20   (:metaclass structure-class))
  21
  22 (defvar str (make-instance 'str))
  23
  24 (push (cons "Time unoptimized slot-value. This is case (1) from notes.text. (standard)"
  25             '(time-slot-value m 'plist 10000))
  26       *tests*)
  27 (push (cons "Time unoptimized slot-value. This is case (1) from notes.text. (standard)"
  28             '(time-slot-value m 'generic-function 10000))
  29       *tests*)
  30 (push (cons "Time unoptimized slot-value. This is case (1) from notes.text. (structure)"
  31             '(time-slot-value str 'slot 10000))
  32       *tests*)
  33 (defun time-slot-value (object slot-name n)
  34   (time (dotimes-fixnum (i n) (slot-value object slot-name))))
  35
  36 (push (cons "Time optimized slot-value outside of a defmethod. Case (2). (standard)"
  37             '(time-slot-value-function m 10000))
  38       *tests*)
  39 (defun time-slot-value-function (object n)
  40   (time (dotimes-fixnum (i n) (slot-value object 'function))))
  41
  42 (push (cons "Time optimized slot-value outside of a defmethod. Case (2). (structure)"
  43             '(time-slot-value-slot str 10000))
  44       *tests*)
  45 (defun time-slot-value-slot (object n)
  46   (time (dotimes-fixnum (i n) (slot-value object 'slot))))
  47
  48 (push (cons "Time one-class dfun."
  49             '(time-generic-function-methods gf 10000))
  50       *tests*)
  51 (defun time-generic-function-methods (object n)
  52   (time (dotimes-fixnum (i n) (generic-function-methods object))))
  53
  54 (push (cons "Time one-index dfun."
  55             '(time-class-precedence-list c 10000))
  56       *tests*)
  57 (defun time-class-precedence-list (object n)
  58   (time (dotimes-fixnum (i n) (class-precedence-list object))))
  59
  60 (push (cons "Time n-n dfun."
  61             '(time-method-function m 10000))
  62       *tests*)
  63 (defun time-method-function (object n)
  64   (time (dotimes-fixnum (i n) (method-function object))))
  65
  66 (push (cons "Time caching dfun."
  67             '(time-class-slots c 10000))
  68       *tests*)
  69 (defun time-class-slots (object n)
  70   (time (dotimes-fixnum (i n) (class-slots object))))
  71
  72 (push (cons "Time typep for classes."
  73             '(time-typep-standard-object m 10000))
  74       *tests*)
  75 (defun time-typep-standard-object (object n)
  76   (time (dotimes-fixnum (i n) (typep object 'standard-object))))
  77
  78 (push (cons "Time default-initargs."
  79             '(time-default-initargs (find-class 'plist-mixin) 1000))
  80       *tests*)
  81 (defun time-default-initargs (class n)
  82   (time (dotimes-fixnum (i n) (default-initargs class nil))))
  83
  84 (push (cons "Time make-instance."
  85             '(time-make-instance (find-class 'plist-mixin) 1000))
  86       *tests*)
  87 (defun time-make-instance (class n)
  88   (time (dotimes-fixnum (i n) (make-instance class))))
  89
  90 (push (cons "Time constant-keys make-instance."
  91             '(time-constant-keys-make-instance 1000))
  92       *tests*)
  93
  94 (expanding-make-instance-top-level
  95 (defun constant-keys-make-instance (n)
  96   (dotimes-fixnum (i n) (make-instance 'plist-mixin))))
  97
  98 (precompile-random-code-segments)
  99
 100 (defun time-constant-keys-make-instance (n)
 101   (time (constant-keys-make-instance n)))
 102
 103 (defun expand-all-macros (form)
 104   (walk-form form nil #'(lambda (form context env)
 105                           (if (and (eq context :eval)
 106                                    (consp form)
 107                                    (symbolp (car form))
 108                                    (not (special-form-p (car form)))
 109                                    (macro-function (car form)))
 110                               (values (macroexpand form env))
 111                               form))))
 112
 113 (push (cons "Macroexpand meth-structure-slot-value"
 114             '(pprint (multiple-value-bind (pgf pm)
 115                          (prototypes-for-make-method-lambda
 116                           'meth-structure-slot-value)
 117                        (expand-defmethod
 118                         'meth-structure-slot-value pgf pm
 119                         nil '((object str))
 120                         '(#'(lambda () (slot-value object 'slot)))
 121                         nil))))
 122       *tests*)
 123
 124 (push (cons "Show code for slot-value inside a defmethod for a structure-class. Case (3)."
 125             '(disassemble (meth-structure-slot-value str)))
 126       *tests*)
 127 (defmethod meth-structure-slot-value ((object str))
 128   #'(lambda () (slot-value object 'slot)))
 129
 130 #|| ; interesting, but long. (produces 100 lines of output)
 131 (push (cons "Macroexpand meth-standard-slot-value"
 132             '(pprint (expand-all-macros
 133                      (expand-defmethod-internal 'meth-standard-slot-value
 134                       nil '((object standard-method))
 135                       '(#'(lambda () (slot-value object 'function)))
 136                       nil))))
 137       *tests*)
 138 (push (cons "Show code for slot-value inside a defmethod for a standard-class. Case (4)."
 139             '(disassemble (meth-standard-slot-value m)))
 140       *tests*)
 141 (defmethod meth-standard-slot-value ((object standard-method))
 142   #'(lambda () (slot-value object 'function)))
 143 ||#
 144
 145 (defun do-tests ()
 146   (dolist (doc+form (reverse *tests*))
 147     (format t "~&~%~A~%" (car doc+form))
 148     (pprint (cdr doc+form))
 149     (eval (cdr doc+form))))