1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
|
(in-package #:ocl)
(defmacro define-get-info ())
(define-condition opencl-error ()
((code :initarg :code
:reader opencl-error-code))
(:report (lambda (condition stream)
(format stream "OPENCL-ERROR: ~A~%" (opencl-error-code condition)))))
(defmacro check-error (error-code)
(alexandria:once-only (error-code)
`(unless (eq ,error-code :success)
(error 'opencl-error :code ,error-code))))
;; TODO: Finish me
(defun array-foreign-type (array)
"Returns the most appropiate foreign type to store ARRAY"
(case (array-element-type array)
(single-float :float)
(double-float :double)
(t nil)))
(defun array-foreign-size (array)
"Returns the size in bytes required to store a foreign version of ARRAY"
(reduce #'* (array-dimensions array)
:initial-value (cffi:foreign-type-size (array-foreign-type array))))
(defmacro check-error-arg (form)
(let ((value (gensym "VALUE"))
(error-code (gensym "ERROR-CODE"))
(c-error-code (gensym "C-ERROR-CODE")))
`(cffi:with-foreign-object (,c-error-code 'cl-error-code)
(let* ((,value (,@form ,c-error-code))
(,error-code (cffi:mem-ref ,c-error-code 'cl-error-code)))
(if (eq ,error-code :success)
,value
(error 'opencl-error :code ,error-code))))))
(defmacro with-foreign-arrays (bindings &body body)
(if (null bindings)
`(progn ,@body)
`(cffi:with-foreign-array ,(first bindings)
(with-foreign-arrays ,(rest bindings)
,@body))))
(defmacro with-foreign-sequence ((var lisp-sequence type &optional length) &body body)
"Like CFFI:WITH-FOREIGN-ARRAY but works also for lists"
(unless length (setf length (gensym "LENGTH")))
(alexandria:once-only (lisp-sequence type)
`(let ((,length (length ,lisp-sequence)))
(cffi:with-foreign-object (,var ,type ,length)
(dotimes (i ,length)
(setf (cffi:mem-aref ,var ,type i) (elt ,lisp-sequence i)))
,@body))))
(defmacro with-foreign-sequences (bindings &body body)
(if bindings
`(with-foreign-sequence ,(first bindings)
(with-foreign-sequences ,(rest bindings)
,@body))
`(progn ,@body)))
(defun vector-type-p (type)
(and (consp type) (eq (car type) :pointer)))
(defun string-type-p (type)
(eq type :string))
(defmacro wrap-get-info-function (name low-level-name type-alist)
""
;; FIXME? This is a top level form, no call to GENSYM is needed, right?
`(defun ,name (object param-name)
(let ((type (assoc-value ,type-alist param-name))
(return-size nil)
(error-code nil)
(return-value nil))
(cffi:with-foreign-object (c-return-size :size)
(setf error-code (,low-level-name object param-name 0 (cffi:null-pointer) c-return-size))
(check-error error-code)
(setf return-size (cffi:mem-ref c-return-size :size)))
(cond ((vector-type-p type)
(let ((count (/ return-size (cffi:foreign-type-size (second type)))))
(cffi:with-foreign-object (c-value type count)
(setf error-code (,low-level-name object param-name return-size c-value (cffi:null-pointer)))
(setf return-value (loop :for i :below count :collect (cffi:mem-aref c-value type i))))))
((string-type-p type)
(setf return-value
(cffi:with-foreign-pointer-as-string (c-string return-size)
(setf error-code (,low-level-name object param-name return-size c-string (cffi:null-pointer))))))
(t
(cffi:with-foreign-object (c-value type)
(setf error-code (,low-level-name object param-name (cffi:foreign-type-size type)
c-value (cffi:null-pointer)))
(setf return-value (cffi:mem-ref c-value type)))))
(check-error error-code)
return-value)))
(defmacro get-cl-objects (name (&rest args) low-level-name type)
(assert (every #'symbolp args) nil "ARGS must be a list of only symbols")
`(defun ,name (,@args)
(let (n)
(cffi:with-foreign-object (cn 'cl-uint)
(check-error (,low-level-name ,@args 0 (cffi:null-pointer) cn))
(setf n (cffi:mem-ref cn 'cl-uint)))
(cffi:with-foreign-object (c-objects ,type n)
(check-error (,low-level-name ,@args n c-objects (cffi:null-pointer)))
(loop :for i :below n
:collect (cffi:mem-aref c-objects ,type i))))))
|
