repos
/
smoke
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
Fix overload resolution using types and test caching the overload resolution.
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
11:44:21 '
94
;;; cache ==================================================================
'
95
;;;
'
96
;;; we could replace the call to #'find-best-viable-function in
'
97
;;; #'call-using-args with a call to
'
98
;;; #'find-best-viable-function-cached, but it is only doubles speed.
'
99
'
100
(sb-int:defun-cached (find-best-viable-function-using-types-cached
'
101
:hash-function (lambda (name arguments
'
102
class const-p)
'
103
(declare (string name)
'
104
(list arguments)
'
105
(class class)
'
106
(boolean const-p))
'
107
(logand
'
108
(logxor
'
109
(sxhash name)
'
110
(sxhash arguments)
'
111
(sxhash class)
'
112
(sxhash const-p))
'
113
#x1FF))
'
114
:hash-bits 9)
'
115
((name equal) (arguments equal) (class eq) (const-p eq))
'
116
(declare (optimize (speed 3))
'
117
(inline find-best-viable-function-using-types))
'
118
(multiple-value-bind (method conversion-sequence)
'
119
(find-best-viable-function-using-types name arguments class const-p)
'
120
(list method (mapcar #'(lambda (s)
'
121
(if (symbolp s)
'
122
(fdefinition s)
'
123
#'(lambda (x)
'
124
(funcall (fdefinition (first s))
'
125
x
'
126
(second s)))))
'
127
conversion-sequence))))
'
128
'
129
(declaim (inline find-best-viable-function-cached))
'
130
(defun find-best-viable-function-cached (name arguments class const-p)
'
131
(declare (optimize (speed 3)))
'
132
(catch 'unspecific-type
'
133
(return-from find-best-viable-function-cached
'
134
(values-list
'
135
(find-best-viable-function-using-types-cached
'
136
name
'
137
(mapcar #'(lambda (o) (class-of o)) arguments)
'
138
class
'
139
const-p))))
'
140
(find-best-viable-function name arguments class const-p))
'
141