repos
/
smoke
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
Cache overload resolution on sbcl
Annotate for file /src/sb-optimize.lisp
2009-07-08 tobias
1
(in-package :smoke)
14:56:52 '
2
'
3
(declaim (optimize (debug 3)))
'
4
'
5
(defmacro catch-try ((tag &optional catch-result) catch-form &body body)
'
6
"Catch TAG in the BODY forms. When TAG is throw CATCH-RESULT is bound
'
7
to the thrown values and result of CATCH-FORM is returned. Otherwise
'
8
the result of BODY is returned and CATCH-FORM is not evaluated."
'
9
(flet ((catch-block (tag return-block body)
'
10
`(catch ,tag
'
11
(return-from ,return-block
'
12
,@body))))
'
13
(let ((return-block (gensym)))
'
14
`(block ,return-block
'
15
,(if catch-result
'
16
`(let ((,catch-result ,(catch-block tag return-block body)))
'
17
,catch-form)
'
18
`(progn ,(catch-block tag return-block body)
'
19
,catch-form))))))
'
20
'
21
(defun type-specifier (lvar)
'
22
(let ((type (sb-kernel:type-specifier (sb-c::lvar-type lvar))))
'
23
(if (subtypep type 'smoke-standard-object)
'
24
(find-class type)
'
25
type)))
'
26
'
27
'
28
(defun give-up-transform (&rest args)
'
29
(apply #'sb-c::give-up-ir1-transform args))
'
30
'
31
(defmacro define-transform (name lambda-list &body body)
'
32
`(sb-c:deftransform ,name (,lambda-list)
'
33
,@body))
'
34
'
35
(defmacro define-known (name)
'
36
`(sb-c:defknown ,name * *))
'
37
'
38
(defun method-form (method)
'
39
`(make-smoke-method
'
40
:id ,(id method)
'
41
:smoke (eval ,(get-smoke-variable-for-pointer
'
42
(smoke method)))))
'
43
'
44
(defun sequence-form (sequence arguments)
'
45
(mapcar #'(lambda (sequence argument)
'
46
(if (symbolp sequence)
'
47
`(,sequence ,argument)
'
48
`(,(first sequence) ,argument ,@(rest sequence))))
'
49
sequence arguments))
'
50
'
51
'
52
(defmacro define-resolve-at-compile-time (gf-name)
'
53
`(eval-when (:compile-toplevel :load-toplevel :execute)
'
54
(define-known ,gf-name)
'
55
(sb-c:defoptimizer (,gf-name derive-type) ((object &rest args))
'
56
(catch-try ('unspecific-type) sb-c::*wild-type*
'
57
(let ((method (find-best-viable-function-using-types
'
58
,(name (fdefinition gf-name))
'
59
(mapcar #'type-specifier args) (type-specifier object))))
'
60
(if (and method (class-p (return-type method)))
'
61
(sb-kernel:single-value-specifier-type
'
62
(find-smoke-class (get-class (return-type method))))
'
63
sb-c::*wild-type*))))
'
64
(define-transform ,gf-name (object &rest args)
'
65
(when (null args)
'
66
(give-up-transform "No arguments."))
'
67
(catch-try ('unspecific-type reason)
'
68
(give-up-transform "Could not resolve overload at compile time: ~A" reason)
'
69
(multiple-value-bind (method sequence)
'
70
(find-best-viable-function-using-types
'
71
,(name (fdefinition gf-name))
'
72
(mapcar #'type-specifier args)
'
73
(type-specifier object))
'
74
(let ((argument-names (make-gensym-list (length args))))
'
75
(when (null method)
'
76
(give-up-transform "No applicable method."))
'
77
(if (static-p method)
'
78
`(s-call ,(method-form method)
'
79
(null-pointer)
'
80
(list ,@(sequence-form
'
81
sequence args)))
'
82
`(lambda (object ,@argument-names)
'
83
(s-call ,(method-form method)
2009-07-08 tobias
84
,(if (eql (type-specifier object)
20:41:19 '
85
(find-smoke-class (get-class method)))
'
86
`(pointer object)
'
87
`(cast object
'
88
(find-class (quote ,(class-name
'
89
(find-smoke-class
'
90
(get-class method)))))))
2009-07-08 tobias
91
(list ,@(sequence-form
14:56:52 '
92
sequence argument-names)))))))))))
2009-09-01 tobias
93
2010-02-20 tobias
94
;;; Cache overload resolution / method lookup
17:24:36 '
95
'
96
;;; FIXME the cached lookup should be faster
2009-09-01 tobias
97
;;;
2010-02-20 tobias
98
;;; cache return value conversion
17:24:36 '
99
;;;
'
100
;;; Using the gf symbol instead of the method name would be better,
'
101
;;; althoug we would have to invent one for constructors.
'
102
;;;
'
103
;;; Since the -using-types stuff was intended for for compile time
'
104
;;; expansion it is not that well suited for this. i.e. passing
'
105
;;; closures would be better than the actual syntax.
'
106
;;;
'
107
;;; For qt.tests the uncached calls make up 30 % of all calls.
'
108
;;; qt.examples:colliding-mice (run for ~1 min) gets 20 % uncached
'
109
;;; calls and qt.examples:class-browser get 10 %. (20 February 2010)
2009-09-01 tobias
110
2010-02-20 tobias
111
(sb-int:defun-cached (find-best-viable-function-using-layouts-cached
2009-09-01 tobias
112
:hash-function (lambda (name arguments
11:44:21 '
113
class const-p)
'
114
(declare (string name)
'
115
(list arguments)
2010-02-20 tobias
116
(sb-c::layout class)
2009-09-01 tobias
117
(boolean const-p))
11:44:21 '
118
(logand
'
119
(logxor
'
120
(sxhash name)
2010-02-20 tobias
121
(the fixnum
17:24:36 '
122
(reduce
'
123
#'logxor
'
124
(mapcar #'sb-c::layout-clos-hash
'
125
arguments)))
2009-09-01 tobias
126
(sxhash class)
11:44:21 '
127
(sxhash const-p))
'
128
#x1FF))
'
129
:hash-bits 9)
'
130
((name equal) (arguments equal) (class eq) (const-p eq))
'
131
(declare (optimize (speed 3))
'
132
(inline find-best-viable-function-using-types))
'
133
(multiple-value-bind (method conversion-sequence)
2010-02-20 tobias
134
(find-best-viable-function-using-types
17:24:36 '
135
name (mapcar #'sb-pcl::wrapper-class* arguments)
'
136
class const-p)
2009-09-01 tobias
137
(list method (mapcar #'(lambda (s)
11:44:21 '
138
(if (symbolp s)
'
139
(fdefinition s)
'
140
#'(lambda (x)
2010-02-20 tobias
141
(declare (optimize (speed 3)))
2009-09-01 tobias
142
(funcall (fdefinition (first s))
11:44:21 '
143
x
2010-02-20 tobias
144
(eval (second s))))))
2009-09-01 tobias
145
conversion-sequence))))
2010-02-20 tobias
146
2009-09-01 tobias
147
(declaim (inline find-best-viable-function-cached))
11:44:21 '
148
(defun find-best-viable-function-cached (name arguments class const-p)
'
149
(declare (optimize (speed 3)))
'
150
(catch 'unspecific-type
'
151
(return-from find-best-viable-function-cached
'
152
(values-list
2010-02-20 tobias
153
(find-best-viable-function-using-layouts-cached
2009-09-01 tobias
154
name
2010-02-20 tobias
155
(mapcar #'(lambda (o) (sb-c::layout-of o)) arguments)
2009-09-01 tobias
156
class
11:44:21 '
157
const-p))))
'
158
(find-best-viable-function name arguments class const-p))
'
159