From 6fe823a614279cceb2d48507bd8e93b0efd87f94 Mon Sep 17 00:00:00 2001
From: Thomas Albers <thomas@thomaslabs.org>
Date: Sat, 4 Mar 2023 22:47:28 +0100
Subject: Initial commit

---
 src/opencl.lisp | 109 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 109 insertions(+)
 create mode 100644 src/opencl.lisp

(limited to 'src/opencl.lisp')

diff --git a/src/opencl.lisp b/src/opencl.lisp
new file mode 100644
index 0000000..ca95928
--- /dev/null
+++ b/src/opencl.lisp
@@ -0,0 +1,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))))))
-- 
cgit v1.2.3