repos
/
smoke
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
Speedup overload resolution and some other stuff for faster C++ method calling.
Annotate for file src/smoke.lisp
2010-01-10 tobias
1
;;; Copyright (C) 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
2009-04-14 tobias
2
;;;
14:23:24 '
3
;;; This program is free software: you can redistribute it and/or modify
'
4
;;; it under the terms of the GNU General Public License as published by
'
5
;;; the Free Software Foundation, either version 3 of the License, or
'
6
;;; (at your option) any later version.
'
7
;;;
'
8
;;; This program is distributed in the hope that it will be useful,
'
9
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
'
10
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
'
11
;;; GNU General Public License for more details.
'
12
;;;
'
13
;;; You should have received a copy of the GNU General Public License
'
14
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
'
15
;;;
'
16
;;; As a special exception, the copyright holders of this library give you
'
17
;;; permission to link this library with independent modules to produce an
'
18
;;; executable, regardless of the license terms of these independent
'
19
;;; modules, and to copy and distribute the resulting executable under
'
20
;;; terms of your choice, provided that you also meet, for each linked
'
21
;;; independent module, the terms and conditions of the license of that
'
22
;;; module. An independent module is a module which is not derived from or
'
23
;;; based on this library. If you modify this library, you may extend this
'
24
;;; exception to your version of the library, but you are not obligated to
'
25
;;; do so. If you do not wish to do so, delete this exception statement
'
26
;;; from your version.
2009-04-05 tobias
27
2009-04-14 tobias
28
(in-package #:smoke)
2009-04-05 tobias
29
2009-06-30 tobias
30
(declaim (inline call-s-method))
2009-06-22 tobias
31
(defun call-s-method (method object-pointer stack-pointer)
12:18:08 '
32
(foreign-funcall-pointer
2009-07-08 tobias
33
(foreign-slot-value (smoke-class-pointer (get-class method))
2009-08-02 tobias
34
'smoke-class
10:12:41 '
35
'class-function)
2009-06-22 tobias
36
()
12:18:08 '
37
smoke-index (foreign-slot-value (smoke-method-pointer method)
2009-08-02 tobias
38
'smoke-method
10:12:41 '
39
'method)
2009-06-22 tobias
40
:pointer object-pointer
12:18:08 '
41
smoke-stack stack-pointer
'
42
:void))
'
43
'
44
(defun s-call (method object-pointer &optional (args nil))
2009-04-05 tobias
45
(with-stack (stack args (arguments method) )
2009-07-08 tobias
46
(call-s-method method object-pointer (call-stack-pointer stack))
20:41:19 '
47
(type-to-lisp (call-stack-pointer stack) (return-type method))))
2009-04-05 tobias
48
2009-06-22 tobias
49
(defun pointer-call (method object-pointer &optional (args nil))
2009-04-05 tobias
50
(with-stack (stack args (arguments method) )
2009-07-08 tobias
51
(call-s-method method object-pointer (call-stack-pointer stack))
20:41:19 '
52
(foreign-slot-value (call-stack-pointer stack) 'smoke-stack-item 'class)))
2009-04-05 tobias
53
2009-08-02 tobias
54
2009-04-05 tobias
55
(defun smoke-call (class pointer method-name &optional (args nil))
2009-08-02 tobias
56
(s-call
10:12:41 '
57
(make-smoke-method-from-name class method-name)
'
58
pointer args))
2009-04-05 tobias
59
2010-01-17 tobias
60
(defun static-call (smoke class-name method-name &rest args)
2009-08-02 tobias
61
(s-call
10:12:41 '
62
(make-smoke-method-from-name (make-smoke-class smoke class-name)
'
63
method-name)
'
64
(null-pointer) args))
2010-01-17 tobias
65
2009-04-05 tobias
66
(defun enum-call (method)
15:36:29 '
67
"Return the enum value for METHOD."
'
68
;; FIXME:
'
69
;; we could use static call, but QGraphicsEllipseItem::Type has
'
70
;; wrongly QGraphicsGridLayout as return type. Smoke ignores case
2009-08-02 tobias
71
;; and confuses it with the member function type() ??
10:12:41 '
72
;; (27.2.09)
2009-04-05 tobias
73
;;
15:36:29 '
74
(assert (enum-p method))
'
75
(with-stack (stack nil nil)
2009-07-08 tobias
76
(call-s-method method (null-pointer) (call-stack-pointer stack))
20:41:19 '
77
(foreign-slot-value (call-stack-pointer stack) 'smoke-stack-item 'long)))
2009-04-05 tobias
78
15:36:29 '
79
(defun delete-pointer (pointer class)
'
80
"Destructs the object at POINTER of type CLASS.
2009-07-01 tobias
81
Calls the destructor and frees the memory."
2009-06-30 tobias
82
(declare (optimize (speed 3)))
2009-07-22 tobias
83
(let ((method-name (concatenate 'string "~" (name class))))
2009-08-02 tobias
84
(s-call
10:12:41 '
85
(make-smoke-method-from-name class method-name)
2009-07-22 tobias
86
pointer))
22:26:05 '
87
(setf pointer (null-pointer)))
2009-04-05 tobias
88
15:36:29 '
89
(defun delete-object (object)
2010-02-19 tobias
90
(let ((method-name (concatenate 'string "~" (name (class-of object)))))
21:22:50 '
91
(s-call
2009-08-02 tobias
92
(make-smoke-method-from-name (class-of object) method-name)
10:12:41 '
93
(pointer object)))
2009-04-05 tobias
94
(setf (slot-value object 'pointer) (null-pointer)))
15:36:29 '
95
2009-06-22 tobias
96
(defun set-binding (object)
12:18:08 '
97
"Sets the Smoke binding for OBJECT, that receives its callbacks."
'
98
(declare (optimize (speed 3)))
2010-02-18 tobias
99
(with-foreign-object (stack 'smoke-stack-item 2)
2009-08-02 tobias
100
(setf (foreign-slot-value (mem-aref stack
10:12:41 '
101
'smoke-stack-item
'
102
1)
'
103
'smoke-stack-item
'
104
'voidp)
2010-02-18 tobias
105
(smoke-module-binding (smoke (class-of object))))
19:57:00 '
106
(foreign-funcall-pointer
2009-07-08 tobias
107
(foreign-slot-value (smoke-class-pointer (class-of object))
2009-08-02 tobias
108
'smoke-class
10:12:41 '
109
'class-function)
2010-02-18 tobias
110
()
19:57:00 '
111
smoke-index 0 ;; set binding method index
2009-08-02 tobias
112
:pointer (pointer object) smoke-stack stack
2010-02-18 tobias
113
:void)))
2009-04-05 tobias
114
2009-06-22 tobias
115
(defun init (smoke module)
2009-04-05 tobias
116
"Returns the a new Smoke binding for the Smoke module SMOKE."
2010-01-10 tobias
117
(use-foreign-library libsmoke-c)
2009-08-02 tobias
118
(let* ((binding (smoke-init smoke
10:12:41 '
119
(callback destructed)
2010-02-18 tobias
120
(callback dispatch-method))))
2010-01-10 tobias
121
(setf (binding smoke) binding
08:49:36 '
122
(smoke-module-pointer module) smoke
2010-02-19 tobias
123
(smoke-module-binding module) binding)
21:10:24 '
124
(init-smoke-module module)
'
125
(setf (gethash (pointer-address smoke) *smoke-modules*) module)
'
126
module))
2009-04-05 tobias
127
2009-05-12 tobias
128
(let ((pointer-symbol-map (make-hash-table)))
13:54:46 '
129
(defun register-smoke-module-var (symbol)
'
130
"Registers SYMBOL of a variable containing a pointer to a Smoke module."
2009-08-02 tobias
131
(setf (gethash (pointer-address (smoke-module-pointer (eval symbol))) pointer-symbol-map)
2009-05-12 tobias
132
symbol))
13:54:46 '
133
(defun get-smoke-variable-for-pointer (pointer)
'
134
"Returns the SYMBOL of the variable whose value is POINTER."
'
135
(gethash (pointer-address pointer) pointer-symbol-map)))
'
136
2009-04-05 tobias
137
(defun call (object method-name &rest args)
2009-08-02 tobias
138
(smoke-call (class-of object)
10:12:41 '
139
(pointer object)
'
140
method-name
'
141
args))
2009-04-05 tobias
142
2009-04-12 tobias
143
(defmethod documentation ((class smoke-standard-class) (doc-type (eql 't)))
20:25:47 '
144
(declare (optimize (speed 3)))
2009-04-05 tobias
145
(format nil "~@[~A~%~]C++ name: ~A" (call-next-method) (name class)))
15:36:29 '
146
2009-07-22 tobias
147
;; No eql T since all-methods is to slow to be used in conjunction with
22:26:05 '
148
;; mb:document
'
149
(defmethod documentation ((gf smoke-gf) (doc-type (eql 'cxx-function)))
2009-04-12 tobias
150
(declare (optimize (speed 3)))
2009-04-05 tobias
151
(let ((methods (all-methods (name gf))))
15:36:29 '
152
(format nil "~@[~A~%~]~{~T~A~%~}"
'
153
(call-next-method)
'
154
(sort (mapcar #'method-declaration methods) #'string<=))))
'
155
'
156
(defun all-methods (name)
'
157
"Returns a list of all methods named NAME."
2010-01-10 tobias
158
;;FIXME speed this up, needed by (mb:document :smoke).
2009-07-22 tobias
159
(declare (string name)
22:26:05 '
160
(optimize (speed 3)))
2009-04-05 tobias
161
(let ((methods))
2009-06-22 tobias
162
(maphash
2009-07-22 tobias
163
#'(lambda (address value)
22:26:05 '
164
(declare (ignore value))
'
165
(let ((smoke (make-pointer address)))
'
166
(map-methods #'(lambda (method)
'
167
(when (and (string= name (name method))
'
168
(not (enum-p method)))
'
169
(push (make-instance 'smoke-method
'
170
:id (smoke-method-id method)
'
171
:smoke (smoke method))
'
172
methods)))
'
173
smoke)))
'
174
*smoke-id-class-map*)
'
175
methods))
2009-04-05 tobias
176
15:36:29 '
177
(defun fgrep-methods (smoke str)
'
178
(map-methods #'(lambda (method)
2009-06-22 tobias
179
(when (search str (name method))
12:18:08 '
180
(princ (method-declaration method))
'
181
(terpri)))
2009-04-05 tobias
182
smoke))
15:36:29 '
183
2009-06-11 tobias
184
(defmacro define-smoke-module (package library
14:35:40 '
185
(variable variable-name)
2009-05-14 tobias
186
(init-function function-name))
12:07:00 '
187
"Define a Smoke module."
2009-06-22 tobias
188
(let ((smoke-module (intern "*SMOKE-MODULE*")))
12:18:08 '
189
`(progn
2009-07-22 tobias
190
(eval-when (:compile-toplevel :load-toplevel :execute)
22:26:05 '
191
(define-foreign-library ,library
'
192
(:unix ,(format nil "~(~A~).so.2" library))
'
193
(t (:default ,(format nil "~(~A~)" library)))))
2009-07-02 tobias
194
(eval-startup (:compile-toplevel :execute)
2009-07-22 tobias
195
(load-foreign-library ',library))
2009-07-02 tobias
196
(eval-startup (:compile-toplevel :execute)
2009-07-22 tobias
197
; (eval-when (:compile-toplevel :load-toplevel :execute)
22:26:05 '
198
; (define-foreign-library ,library
'
199
; (:unix ,(format nil "~(~A~).so.2" library))
'
200
; (t (:default ,(format nil "~(~A~)" library))))
'
201
; (load-foreign-library ',library))
2009-08-02 tobias
202
(defcvar (,variable ,variable-name
10:12:41 '
203
:read-only t
'
204
:library ,library) :pointer)
2009-12-13 tobias
205
(defcfun (,init-function ,(format nil "_Z~A~Av"
10:17:08 '
206
(length function-name)
'
207
function-name)
'
208
:library ,library)
2009-06-30 tobias
209
:void))
2009-06-12 tobias
210
(eval-when (:compile-toplevel :load-toplevel :execute)
2009-06-22 tobias
211
(defparameter ,smoke-module (make-smoke-module)))
12:18:08 '
212
(eval-startup (:compile-toplevel :execute)
2009-06-30 tobias
213
(,init-function)
22:47:39 '
214
(init ,variable ,smoke-module)
'
215
(register-smoke-module-var ',smoke-module))
2009-06-22 tobias
216
(define-classes-and-gfs ,package ,smoke-module))))
2009-05-14 tobias
217
2009-08-02 tobias
218
2009-04-05 tobias
219
(defun fgrep-classes (smoke str)
15:36:29 '
220
(map-classes #'(lambda (class)
'
221
(when (search str (name class))
'
222
(format t "~A~%" (name class))))
'
223
smoke))
2009-05-28 tobias
224
(defmacro define-takes-ownership (method lambda-list object)
2009-06-08 tobias
225
"Declares METHOD transfers the ownership of OBJECT to the
09:20:54 '
226
first argument of LAMBDA-LIST."
2009-05-31 tobias
227
`(defmethod ,method :before ,lambda-list
2009-06-30 tobias
228
(declare (ignorable ,@(loop for arg in (rest lambda-list) collect
22:47:39 '
229
(if (consp arg)
'
230
(first arg)
'
231
arg))))
2009-06-08 tobias
232
(transfer-ownership-to ,object ,(if (consp (first lambda-list))
09:20:54 '
233
(first (first lambda-list))
'
234
(first lambda-list)))))
2009-05-28 tobias
235