new function cancel-finalization
[commonqt:commonqt.git] / call.lisp
1 ;;; -*- show-trailing-whitespace: t; indent-tabs-mode: nil -*-
2
3 ;;; Copyright (c) 2009 David Lichteblau. All rights reserved.
4
5 ;;; Redistribution and use in source and binary forms, with or without
6 ;;; modification, are permitted provided that the following conditions
7 ;;; are met:
8 ;;;
9 ;;;   * Redistributions of source code must retain the above copyright
10 ;;;     notice, this list of conditions and the following disclaimer.
11 ;;;
12 ;;;   * Redistributions in binary form must reproduce the above
13 ;;;     copyright notice, this list of conditions and the following
14 ;;;     disclaimer in the documentation and/or other materials
15 ;;;     provided with the distribution.
16 ;;;
17 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
18 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
19 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
20 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
21 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
22 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
23 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
24 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
25 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
26 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
27 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
28
29 (in-package :qt)
30 #+sbcl (declaim (optimize (debug 2)))
31 (named-readtables:in-readtable :qt)
32
33 (defun pointer->cached-object (ptr)
34   (gethash (cffi:pointer-address ptr) *cached-objects*))
35
36 (defun (setf pointer->cached-object) (newval ptr)
37   (setf (gethash (cffi:pointer-address ptr) *cached-objects*)
38         newval))
39
40 (defun %deletion-callback (obj)
41   (restart-case
42       (let ((object (pointer->cached-object obj)))
43         (when object
44           (note-deleted object)))
45     (abort ()
46       :report (lambda (stream) (write-string "Abort smoke callback" stream)))))
47
48 (defun %method-invocation-callback (smoke method-idx obj stack abstractp)
49   (declare (ignore abstractp))
50   (restart-case
51       (let* ((<module> (module-number smoke))
52              (object (pointer->cached-object obj))
53              (<method> (bash method-idx <module> +method+))
54              (fun (and object (find-method-override object <method>))))
55         (if fun
56             (let* ((args
57                     (loop for type in (list-qmethod-argument-types <method>)
58                        for i from 1
59                        for item = (cffi:mem-aref stack
60                                                  '|union StackItem|
61                                                  i)
62                        collect (unmarshal type item)))
63                    (result (override fun object <method> args))
64                    (rtype (qmethod-return-type <method>)))
65               (unless (qtype-void-p rtype)
66                 (marshal result rtype stack (lambda ())))
67               1)
68             0))
69     (abort ()
70       :report (lambda (stream) (write-string "Abort smoke callback" stream))
71       0)))
72
73 (defun %child-callback (added obj)
74   (restart-case
75       (let ((object (pointer->cached-object obj)))
76         (when object
77           (if (zerop added)
78               (note-child-removed object)
79               (note-child-added object))))
80     (abort ()
81       :report (lambda (stream) (write-string "Abort smoke callback" stream)))))
82
83 (defun map-qobject-children (fn x)
84   (let ((*ptr-callback*
85          (lambda (ptr)
86            (funcall fn (%qobject (find-qclass "QObject") ptr)))))
87     (sw_map_children (qobject-pointer x) (cffi:callback ptr-callback))))
88
89 (defun map-qobject-hierarchy (fn x)
90   (funcall fn x)
91   (map-qobject-children (lambda (y)
92                           (map-qobject-hierarchy fn y))
93                         x))
94
95 (defclass abstract-qobject ()
96   ((class :initarg :class
97           :accessor qobject-class)))
98
99 (defclass null-qobject (abstract-qobject)
100   ())
101
102 (defun null-qobject (class)
103   (make-instance 'null-qobject :class (find-qclass class)))
104
105 (defmethod qobject-pointer ((object null-qobject))
106   (cffi:null-pointer))
107
108 (defclass qobject (abstract-qobject)
109   ((pointer :initarg :pointer
110             :initform :unborn
111             :accessor qobject-pointer)
112    (deleted :initform nil
113             :accessor qobject-deleted)))
114
115 (defmethod print-object ((instance qobject) stream)
116   (print-unreadable-object (instance stream :type nil :identity nil)
117     (cond
118       ((not (slot-boundp instance 'class))
119        (format stream "uninitialized"))
120       ((cffi:pointerp (qobject-pointer instance))
121        (format stream "~A 0x~8,'0X"
122                (qclass-name (qobject-class instance))
123                (cffi:pointer-address (qobject-pointer instance))))
124       (t
125        (format stream "~A ~A"
126                (qclass-name (qobject-class instance))
127                (qobject-pointer instance))))))
128
129 (defmethod print-object ((instance null-qobject) stream)
130   (print-unreadable-object (instance stream :type nil :identity nil)
131     (format stream "~A NULL"
132             (qclass-name (qobject-class instance)))))
133
134 (defclass primitive ()
135   ((value :initarg :value :accessor primitive-value)))
136
137 (defmethod print-object ((instance primitive) stream)
138   (print-unreadable-object (instance stream :type t :identity nil)
139     (format stream "~A" (primitive-value instance))))
140
141 (defmacro defprimitive (name (superclass) type)
142   `(progn
143      (defclass ,name (,superclass) ())
144      (defun ,name (value)
145        (check-type value ,type)
146        (make-instance ',name :value value))))
147
148 (defclass $ (primitive) ())
149 (defclass ? (primitive) ())
150
151 (defprimitive int ($) (signed-byte 32))
152 (defprimitive uint ($) (unsigned-byte 32))
153 (defprimitive bool ($) (signed-byte 32))
154
155 (defprimitive char* ($) (satisfies cffi:pointerp))
156 (defprimitive char** (?) (satisfies cffi:pointerp))
157 (defprimitive qstring ($) string)
158 (defprimitive qstringlist (?) (satisfies cffi:pointerp))
159 (defprimitive int& ($) (satisfies cffi:pointerp))
160 (defprimitive void** (?) (satisfies cffi:pointerp))
161 (defprimitive bool* ($) (satisfies cffi:pointerp))
162 (defprimitive quintptr (?) (satisfies cffi:pointerp))
163
164 (defclass enum ($)
165   ((type-name :initarg :type-name
166               :accessor enum-type-name)))
167
168 (defun enum (value type-name)
169   (check-type value (signed-byte 32))
170   (make-instance 'enum :type-name type-name :value value))
171
172 (defmethod print-object ((instance primitive) stream)
173   (print-unreadable-object (instance stream :type t :identity nil)
174     (format stream "~A"
175             (primitive-value instance))))
176
177 (defmethod print-object ((instance enum) stream)
178   (print-unreadable-object (instance stream :type t :identity nil)
179     (format stream "~A ~A"
180             (enum-type-name instance)
181             (primitive-value instance))))
182
183 (defun enum= (a b)
184   (and (eq (enum-type-name a) (enum-type-name b))
185        (eql (primitive-value a) (primitive-value b))))
186
187 (defun qobject= (x y)
188   (cffi-sys:pointer-eq (qobject-pointer x) (qobject-pointer y)))
189
190 (defun %qobject (class ptr)
191   (or (pointer->cached-object ptr)
192       (if (cffi:null-pointer-p ptr)
193           (make-instance 'null-qobject :class class)
194           (make-instance 'qobject :class class :pointer ptr))))
195
196 (defgeneric argument-munged-char (object))
197
198 (defmethod argument-munged-char ((object t))
199   (error "don't know how to pass ~A to smoke functions" object))
200
201 (defmethod argument-munged-char ((object abstract-qobject)) #\#)
202 (defmethod argument-munged-char ((object $)) #\$)
203 (defmethod argument-munged-char ((object ?)) #\?)
204 (defmethod argument-munged-char ((object vector)) #\?)
205 (defmethod argument-munged-char ((object string)) #\$)
206 (defmethod argument-munged-char ((object integer)) #\$)
207 (defmethod argument-munged-char ((object real)) #\$)
208 (defmethod argument-munged-char ((object (eql t))) #\$)
209 (defmethod argument-munged-char ((object null)) #\$)
210 (defmethod argument-munged-char ((object qlist)) #\?)
211
212 (defmethod can-marshal-p ((kind t) (name t) (slot t) (arg t) (type t))
213   nil)
214
215 (defmacro defmarshal ((kind name slot)
216                       ((arg-var arg-type) type-var item-var &key test)
217                       &body body)
218   (let ((kind-var (gensym))
219         (name-var (gensym))
220         (slot-var (gensym))
221         (cont-var (gensym)))
222     `(progn
223        (defmethod can-marshal-p ((kind ,kind)
224                                  (name ,name)
225                                  (slot ,slot)
226                                  (arg ,arg-type)
227                                  (type t))
228          ,(if test
229               `(funcall ,test arg type)
230               t))
231        (defmethod marshal-using-type ((,KIND-VAR ,kind)
232                                       (,NAME-VAR ,name)
233                                       (,SLOT-VAR ,slot)
234                                       (,arg-var ,arg-type)
235                                       ,type-var
236                                       ,item-var
237                                       ,CONT-VAR)
238          ,@ (when test
239               `((unless (funcall ,test ,arg-var ,type-var)
240                   (error "argument ~A is not of the required type ~A"
241                          ,arg-var ,type-var))))
242          (macrolet ((marshal-next ()
243                       `(funcall ,',CONT-VAR)))
244            ,@body)))))
245
246 (defgeneric marshal-using-type (kind name slot arg type item cont))
247
248 (defgeneric find-applicable-method (object name args))
249
250 (defmethod find-applicable-method ((object abstract-qobject) method-name args)
251   (qclass-find-applicable-method (qobject-class object) method-name args))
252
253 (defmethod find-applicable-method ((class integer) method-name args)
254   (qclass-find-applicable-method class method-name args))
255
256 (defun type= (x y)
257   (and (eq (qtype-kind x) (qtype-kind y))
258        (eq (qtype-interned-name x) (qtype-interned-name y))
259        (eq (qtype-stack-item-slot x) (qtype-stack-item-slot y))))
260
261 (defun method-signature= (a b)
262   (let ((r (list-qmethod-argument-types a))
263         (s (list-qmethod-argument-types b)))
264     (and (eql (length r) (length s))
265          (every #'type= r s))))
266
267 (defun arguments-to-munged-name (name args)
268   (format nil "~A~{~C~}" name (mapcar #'argument-munged-char args)))
269
270 (defun qclass-find-applicable-method (class method-name args)
271   (let ((munged-name (arguments-to-munged-name method-name args)))
272     (labels ((recurse (c)
273                (append (list-methodmap-methods (find-methodmap c munged-name))
274                        (some #'recurse (list-qclass-superclasses c)))))
275       (let ((methods (remove-duplicates (recurse class)
276                                         :from-end t
277                                         :test #'method-signature=)))
278         (cond
279           ((null methods)
280            nil)
281           ((cdr methods)
282            (find-if (lambda (method)
283                       (method-applicable-p method args))
284                     methods))
285           (t
286            (car methods)))))))
287
288 (defun method-applicable-p (method args)
289   (every (lambda (type arg)
290            (can-marshal-p (qtype-kind type)
291                           (qtype-interned-name type)
292                           (qtype-stack-item-slot type)
293                           arg
294                           type))
295          (list-qmethod-argument-types method)
296          args))
297
298 (defun marshal (argument type stack-item cont)
299   (marshal-using-type (qtype-kind type)
300                       (qtype-interned-name type)
301                       (qtype-stack-item-slot type)
302                       argument
303                       type
304                       stack-item
305                       cont))
306
307 (defun qtypep (instance thing)
308   (let ((kind (nth-value 2 (unbash thing))))
309     (cond
310      ((eql kind +class+) (qsubclassp (qobject-class instance) thing))
311      ((eql kind +type+) (qtypep instance (qtype-class thing)))
312      (t (error "not a type or class: ~A" thing)))))
313
314 (defun qsubclassp (a b)
315   (or (eq a b)
316       (some (lambda (super) (qsubclassp super b))
317             (list-qclass-superclasses a))))
318
319 ;; for reference results, return new values as multiple return values
320 (defun splice-reference-result (result-list newval)
321   (destructuring-bind (primary-return-value &rest rest) result-list
322     (list* primary-return-value newval rest)))
323
324 (defun string-vector-to-char**! (ptr vector)
325   (loop
326      for i from 0
327      for elt across vector
328      do
329        (setf (cffi:mem-aref ptr :pointer i)
330              (cffi:foreign-string-alloc elt))))
331
332 (defun string-vector-to-char** (vector)
333   (let ((ptr (cffi:foreign-alloc :pointer :count (length vector))))
334     (string-vector-to-char**! ptr vector)
335     ptr))
336
337 (defun char**-to-string-vector! (vector ptr n freep)
338   (loop
339      for i from 0 below n
340      do
341        (setf (elt vector i)
342              (cffi:mem-aref ptr :string i))
343        (when freep
344          (cffi:foreign-free (cffi:mem-aref ptr :pointer i)))))
345
346 (defun char**-to-string-vector (ptr n freep)
347   (let ((vector (make-array n)))
348     (char**-to-string-vector! vector ptr n freep)
349     vector))
350
351 (defgeneric unmarshal-using-type (kind name item type stack))
352
353 (defun unmarshal (type stack-item)
354   (unmarshal-using-type (qtype-kind type)
355                         (qtype-interned-name type)
356                         (qtype-stack-item-slot type)
357                         type
358                         stack-item))
359
360 (defun call-with-marshalling (fun types args)
361   (cffi:with-foreign-object (stack '|union StackItem| (1+ (length args)))
362     (labels ((iterate (i rest-types rest-args)
363                (if rest-args
364                    (marshal (car rest-args)
365                             (car rest-types)
366                             (cffi:mem-aref stack '|union StackItem| i)
367                             (lambda ()
368                               (iterate (1+ i)
369                                        (cdr rest-types)
370                                        (cdr rest-args))))
371                    (funcall fun stack))))
372       (iterate 1 types args))))
373
374 (defmethod new ((qclass string) &rest args)
375   (apply #'new (find-qclass qclass) args))
376
377 (defun qpointer-target-already-deleted-p (qp)
378   (logbitp 0 (sw_qpointer_is_null qp)))
379
380 (defun null-qobject-p (object)
381   (typep object 'null-qobject))
382
383 (defun postmortem (ptr class description qobjectp dynamicp)
384   (declare (ignore ptr class))
385   (format t "Finalizer called for ~A (~{~A~^, ~}), possible memory leak.~%"
386           description
387           (append (when dynamicp '("Lisp"))
388                   (when qobjectp '("QObject"))))
389   (force-output)
390   #+(or)
391   (let* ((object (%qobject class ptr))
392          (parent (and qobjectp (#_parent object))))
393     (cond
394       ((or (not qobjectp)
395            (and parent (null-qobject-p parent)))
396        (format t "deleting ~A (~A)~%" object qobjectp)
397        (force-output)
398        (handler-case
399            (if qobjectp
400                (#_deleteLater object)
401                (call object (format nil "~~~A" (qclass-name class))))
402          (error (c)
403            (format t "Error in finalizer: ~A, for object: ~A~%"
404                    c description))))
405       (dynamicp
406        (warn "Bug in CommonQt?  previously dynamic object ~A still has parent ~A, but has been GCed"
407              object parent))
408       (t
409        (warn "Bug in CommonQt?  ~A still has parent ~A; not deleting"
410              object parent)))))
411
412 #+(or)
413 (defun run-pending ()
414   (setf *pending-finalizations*
415         (remove-if #'funcall *pending-finalizations*)))
416
417 (defun cache! (object)
418   (assert (null (pointer->cached-object (qobject-pointer object))))
419   (setf (pointer->cached-object (qobject-pointer object)) object)
420   (when (or (not (qtypep object (find-qclass "QObject")))
421             (typep (#_parent object) 'null-qobject))
422     (tg:finalize object
423                  (let* ((ptr (qobject-pointer object))
424                         (class (qobject-class object))
425                         (str (princ-to-string object))
426                         (qobjectp (qsubclassp class (find-qclass "QObject")))
427                         (dynamicp (typep object 'dynamic-object)))
428                    (lambda ()
429                      (postmortem ptr class str qobjectp dynamicp)))))
430   object)
431
432 (defmethod new ((class integer) &rest args)
433   (apply #'new
434          (make-instance 'qobject
435                         :class class
436                         :pointer :unborn)
437          args))
438
439 (defun %call-ctor (method stack binding)
440   (cffi:foreign-funcall-pointer
441    (qclass-trampoline-fun (qmethod-class method))
442    ()
443    :short (qmethod-arg-for-classfn method)
444    :pointer (cffi:null-pointer)
445    :pointer stack
446    :void)
447   (let ((new-object (cffi:foreign-slot-value stack '|union StackItem| 'ptr)))
448     (cffi:with-foreign-object (stack2 '|union StackItem| 2)
449       (setf (cffi:foreign-slot-value
450              (cffi:mem-aref stack2 '|union StackItem| 1)
451              '|union StackItem|
452              'ptr)
453             binding)
454       (cffi:foreign-funcall-pointer
455        (qclass-trampoline-fun (qmethod-class method))
456        ()
457        :short 0
458        :pointer new-object
459        :pointer stack2
460        :void))
461     new-object))
462
463 (defun binding-for-ctor (method instance)
464   (let* ((<module> (ldb-module (qmethod-class method)))
465          (data (data-ref <module>)))
466     (if (typep instance 'dynamic-object)
467         (data-fat data)
468         (data-thin data))))
469
470 (defmethod new ((instance qobject) &rest args)
471   (let* ((class (qobject-class instance))
472          (method (qclass-find-applicable-method class (qclass-name class) args)))
473     (unless method
474       (error "No applicable constructor ~A found for arguments ~A"
475              (qclass-name class) args))
476     (assert (eq class (qtype-class (qmethod-return-type method))))
477     (apply #'values
478            (call-with-marshalling
479             (lambda (stack)
480               (setf (qobject-pointer instance)
481                     (%call-ctor method
482                                 stack
483                                 (binding-for-ctor method instance)))
484               (cache! instance)
485               (list instance))
486             (list-qmethod-argument-types method)
487             args))))
488
489 (defun call (instance method &rest args)
490   (%call t instance method args))
491
492 (defun call-without-override (instance method &rest args)
493   (%call nil instance method args))
494
495 (defun %call (allow-override-p instance method args)
496   (typecase instance
497     (symbol
498      (setf instance (class-effective-class (find-class instance))))
499     (qt-class
500      (setf instance (class-effective-class instance)))
501     (string
502      (setf instance (find-qclass instance))))
503   (let ((name method)
504         (method (etypecase method
505                   (integer method)
506                   (string (find-applicable-method instance method args)))))
507     (unless method
508       (error "No applicable method ~A found on ~A with arguments ~A"
509              name instance args))
510     (when (typep instance 'integer)
511       (unless (qmethod-static-p method)
512         (error "not a static method"))
513       (setf instance (null-qobject instance)))
514     (let ((rtype (qmethod-return-type method)))
515       (apply #'values
516              (call-with-marshalling
517               (lambda (stack &aux fun)
518                 (cond
519                  ((and allow-override-p
520                        (setf fun
521                              (find-method-override instance method)))
522                   (multiple-value-list (override fun instance method args)))
523                  (t
524                   (cffi:foreign-funcall-pointer
525                    (qclass-trampoline-fun (qmethod-class method))
526                    ()
527                    :short (qmethod-arg-for-classfn method)
528                    :pointer (if (null-qobject-p instance)
529                                 (cffi:null-pointer)
530                                 (%cast instance (qmethod-class method)))
531                    :pointer stack
532                    :void)
533                   (list (and (not (qtype-void-p rtype))
534                              (unmarshal rtype stack))))))
535               (list-qmethod-argument-types method)
536               args)))))
537
538 (defun note-deleted (object)
539   (check-type object abstract-qobject)
540   (unless (qobject-deleted object)
541     (cancel-finalization object)
542     (remhash (cffi:pointer-address (qobject-pointer object)) *cached-objects*)
543     (setf (qobject-deleted object) t)))
544
545 (defun cancel-finalization (object)
546   (check-type object abstract-qobject)
547   (tg:cancel-finalization object))
548
549 (defun delete-object (object)
550   (cond
551     ((typep object 'null-qobject)
552      (error "cannot delete null object: ~A" object))
553     ((qobject-deleted object)
554      (warn "not deleting dead object: ~A" object))
555     (t
556      #+nil (sw_delete (qobject-pointer object))
557      (call object (format nil "~~~A" (qclass-name (qobject-class object))))
558      (note-deleted object))))
559
560 (defmacro with-object ((var &optional value) &body body)
561   (if value
562       `(call-with-object (lambda (,var) ,@body) ,value)
563       `(let ((,var nil))
564          (flet ((,var (x) (push x ,var) x))
565            (unwind-protect
566                 (progn ,@body)
567              (mapc #'maybe-delete-object ,var))))))
568
569 (defmacro with-objects ((&rest clauses) &body body)
570   (if clauses
571       `(with-object ,(car clauses) (with-objects ,(rest clauses) ,@body))
572       `(progn ,@body)))
573
574 (defun maybe-delete-object (object)
575   (unless (or (typep object 'null-qobject)
576               (qobject-deleted object))
577     (delete-object object)))
578
579 (defun call-with-object (fun object)
580   (check-type object abstract-qobject)
581   (unwind-protect
582        (funcall fun object)
583     (maybe-delete-object object)))
584
585 (defmethod note-child-added ((object qobject))
586   (setf (gethash object *keep-alive*) t))
587
588 (defmethod note-child-removed ((object qobject))
589   (remhash object *keep-alive*))
590
591 (defun map-cpl (fun class)
592   (labels ((recurse (c)
593              (funcall fun c)
594              (map-qclass-superclasses #'recurse c)))
595     (recurse class)))