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/objects/stack.lisp
2009-04-05 tobias
1
(in-package #:smoke)
15:36:29 '
2
2009-07-08 tobias
3
(declaim (inline %make-call-stack))
20:41:19 '
4
(defstruct (call-stack (:constructor %make-call-stack))
'
5
(pointer (null-pointer) :type foreign-pointer)
'
6
(top (null-pointer) :type foreign-pointer))
2009-04-05 tobias
7
2009-05-27 tobias
8
(defgeneric size (object))
2009-04-05 tobias
9
(defmethod size ((stack call-stack))
15:36:29 '
10
"Returns the size (number of arguments) of STACK."
2009-07-22 tobias
11
(/
2009-07-08 tobias
12
(- (pointer-address (call-stack-top stack))
20:41:19 '
13
(pointer-address (call-stack-pointer stack)))
2009-07-22 tobias
14
(foreign-type-size 'smoke-stack-item)))
2009-04-05 tobias
15
15:36:29 '
16
(defun make-call-stack (smoke-stack)
2009-07-08 tobias
17
(declare (type foreign-pointer smoke-stack)
20:41:19 '
18
(optimize (speed 3)))
'
19
(%make-call-stack
'
20
:pointer smoke-stack
'
21
:top (inc-pointer smoke-stack
'
22
#.(foreign-type-size 'smoke-stack-item))))
2009-04-05 tobias
23
15:36:29 '
24
(defun push-stack (stack value type)
2009-07-08 tobias
25
(setf (foreign-slot-value (call-stack-top stack)
2009-08-02 tobias
26
'smoke-stack-item type) value)
2009-07-08 tobias
27
(incf-pointer (call-stack-top stack) #.(foreign-type-size 'smoke-stack-item)))
2009-06-22 tobias
28
12:18:08 '
29
(define-compiler-macro push-stack (&whole form stack value type)
'
30
(if (constantp type)
'
31
`(progn
2009-07-08 tobias
32
(setf (foreign-slot-value (call-stack-top ,stack)
2009-08-02 tobias
33
'smoke-stack-item ,type) ,value)
2009-07-08 tobias
34
(incf-pointer (call-stack-top ,stack)
20:41:19 '
35
,(foreign-type-size 'smoke-stack-item)))
2009-06-22 tobias
36
form))
2009-08-27 tobias
37
2009-06-12 tobias
38
12:21:44 '
39
(defclass smoke-standard-object ()
'
40
((pointer :reader pointer
2009-07-08 tobias
41
:type foreign-pointer
2009-06-12 tobias
42
:initarg :pointer
12:21:44 '
43
:documentation "Pointer to the C++ object.")
2009-06-30 tobias
44
#+clisp (finalizer :type list :initform (list nil))
2009-06-12 tobias
45
;; We can not have a global table of objects owned by C++,
2009-07-01 tobias
46
;; since then they would be always reachable from Lisp and thus
2009-06-12 tobias
47
;; cycles would never be garbage collected.
12:21:44 '
48
(owned-objects :accessor owned-objects
'
49
:initform nil
'
50
:type list
2009-07-01 tobias
51
:documentation "Objects owned by the C++ instance."))
2009-06-12 tobias
52
(:documentation "The standard superclass for Smoke classes."))
2009-04-05 tobias
53
2009-05-26 tobias
54
(defun push-smoke-stack (stack value type-id)
2009-06-22 tobias
55
(declare (type (smoke-index 0) type-id)
12:18:08 '
56
(type call-stack stack)
'
57
(optimize (speed 3)))
2009-04-05 tobias
58
(ecase type-id
15:36:29 '
59
(0 (push-stack stack value 'voidp))
'
60
(1 (push-stack stack value 'bool))
2009-04-12 tobias
61
(2 (push-stack stack (char-code value) 'char))
2009-04-05 tobias
62
(3 (push-stack stack value 'uchar))
15:36:29 '
63
(4 (push-stack stack value 'short))
'
64
(5 (push-stack stack value 'ushort))
'
65
(6 (push-stack stack value 'int))
'
66
(7 (push-stack stack value 'uint))
'
67
(8 (push-stack stack value 'long))
'
68
(9 (push-stack stack value 'ulong))
'
69
(10 (push-stack stack value 'float))
'
70
(11 (push-stack stack value 'double))
'
71
(12 (push-stack stack (value value) 'enum-value))
2009-05-26 tobias
72
(13 (if (typep value 'smoke-standard-object)
09:54:47 '
73
;; FIXME call pointer in overload resolution
'
74
(push-stack stack (pointer value) 'class)
'
75
(push-stack stack value 'class)))))
2009-04-05 tobias
76
15:36:29 '
77
(defun set-smoke-stack (stack args arguments)
'
78
"Pushes the arguments ARGS onto the Smoke stack STACK."
'
79
(when (null args)
'
80
(assert (null arguments)
'
81
()
'
82
"To few arguments supplied. Missing: ~A" arguments))
'
83
(unless (null args)
'
84
(assert (not (null arguments))
'
85
()
2009-07-01 tobias
86
"To many arguments supplied (Arguments ~A)." args)
2009-05-26 tobias
87
(if (typep (first arguments) 'smoke-type)
09:54:47 '
88
(push-smoke-stack stack (first args) (type-id (first arguments)))
'
89
(push-stack stack (first args) 'class)) ;; Used for :qt lisp-object
'
90
(set-smoke-stack stack (rest args) (rest arguments))))
2009-04-05 tobias
91
15:36:29 '
92
(defmacro with-stack ((stack args types) &body body)
'
93
(let ((smoke-stack (gensym "STACK")))
'
94
`(with-foreign-object (,smoke-stack 'smoke-stack-item (1+ (length ,args)))
'
95
(let ((,stack (make-call-stack ,smoke-stack)))
'
96
(set-smoke-stack ,stack ,args
'
97
,types)
2009-05-26 tobias
98
,@body))))
2009-04-05 tobias
99
15:36:29 '
100
(defun enum-to-lisp (stack-item type)
'
101
"Returns the Lisp representation for STACK-ITEM of the basic C type TYPE."
2009-06-22 tobias
102
(declare (optimize (speed 3)))
2009-04-05 tobias
103
(ecase (type-id type)
2009-08-02 tobias
104
(0 (let ((cffi-type (get-type (name type))))
10:12:41 '
105
(if (null cffi-type)
'
106
(progn
'
107
;; FIXME warn but not on void**
'
108
;;(warn "Unknown translation from ~A to lisp." (name type))
'
109
(foreign-slot-value stack-item 'smoke-stack-item 'voidp))
'
110
(let* ((pointer (foreign-slot-value stack-item
'
111
'smoke-stack-item
'
112
'voidp))
'
113
(value (convert-from-foreign pointer cffi-type)))
'
114
(when (stack-p type)
'
115
;; FIXME free-translated-object is not intended for this;
'
116
;; param is NIL for now.
'
117
(cffi:free-translated-object pointer cffi-type nil))
'
118
value
'
119
))))
2009-04-05 tobias
120
(1 (foreign-slot-value stack-item 'smoke-stack-item 'bool))
15:36:29 '
121
(2 (code-char (foreign-slot-value stack-item 'smoke-stack-item 'char)))
'
122
(3 (code-char (foreign-slot-value stack-item 'smoke-stack-item 'uchar)))
'
123
(4 (code-char (foreign-slot-value stack-item 'smoke-stack-item 'short)))
'
124
(5 (code-char (foreign-slot-value stack-item 'smoke-stack-item 'ushort)))
'
125
(6 (foreign-slot-value stack-item 'smoke-stack-item 'int))
'
126
(7 (foreign-slot-value stack-item 'smoke-stack-item 'uint))
'
127
(8 (foreign-slot-value stack-item 'smoke-stack-item 'long))
'
128
(9 (foreign-slot-value stack-item 'smoke-stack-item 'ulong))
'
129
(10 (foreign-slot-value stack-item 'smoke-stack-item 'float))
'
130
(11 (foreign-slot-value stack-item 'smoke-stack-item 'double))
'
131
(12 (make-instance 'enum
2009-08-02 tobias
132
:value (foreign-slot-value stack-item 'smoke-stack-item 'enum-value)
2009-04-05 tobias
133
:type type))))
15:36:29 '
134
'
135
(defgeneric instance-to-lisp (pointer class type)
2009-06-22 tobias
136
(declare (optimize (speed 3)))
2009-07-01 tobias
137
(:documentation "Returns a CLOS instance for POINTER."))
2009-04-05 tobias
138
15:36:29 '
139
(defun object-to-lisp (object type)
2009-06-22 tobias
140
(declare (optimize (speed 3)))
2009-08-02 tobias
141
(if (class-p type)
10:12:41 '
142
(let ((class (get-class type)))
'
143
(if (has-pointer-p object)
2009-04-05 tobias
144
(get-object object)
2009-08-02 tobias
145
(instance-to-lisp object (find-smoke-class class) type)))
10:12:41 '
146
nil))
2009-04-05 tobias
147
15:36:29 '
148
'
149
'
150
(defun class-to-lisp (stack-item type)
'
151
"Returns the Lisp representation for STACK-ITEM of type C++ class."
2009-08-02 tobias
152
(object-to-lisp (foreign-slot-value stack-item
10:12:41 '
153
'smoke-stack-item
2009-06-22 tobias
154
'class)
12:18:08 '
155
type))
2009-04-05 tobias
156
15:36:29 '
157
(defun type-to-lisp (stack-item type)
'
158
"Returns the Lisp representation of STACK-ITEM"
2009-06-22 tobias
159
(declare (optimize (speed 3)))
2009-04-05 tobias
160
(cond
2009-08-02 tobias
161
((void-p type)
10:12:41 '
162
(values))
'
163
((class-p type)
'
164
(class-to-lisp stack-item type))
'
165
(t
'
166
(enum-to-lisp stack-item type))))