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