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/memory.lisp | 89 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 89 insertions(+)
 create mode 100644 src/memory.lisp

(limited to 'src/memory.lisp')

diff --git a/src/memory.lisp b/src/memory.lisp
new file mode 100644
index 0000000..f6ab419
--- /dev/null
+++ b/src/memory.lisp
@@ -0,0 +1,89 @@
+(in-package #:ocl)
+
+(defun create-buffer (context flags size &optional (host-ptr (cffi:null-pointer)))
+  (check-error-arg (%create-buffer context flags size host-ptr)))
+
+;; TODO: Support multi-dimensional arrays? row-major?
+(defun create-buffer-from-array (context flags array)
+  (let* ((length (length array))
+         (c-type (array-foreign-type array))
+         (size (* length (cffi:foreign-type-size c-type))))
+    (cffi:with-foreign-array (c-array array (list :array c-type length))
+      (check-error-arg (%create-buffer context flags size c-array)))))
+
+(defun create-pipe (context flags packet-size max-packets &key properties)
+  (declare (ignorable properties))
+  (check-error-arg
+   (%create-pipe context flags packet-size max-packets (cffi:null-pointer))))
+
+(defun retain-mem-object (memobj)
+  (check-error (%retain-mem-object memobj)))
+
+(defun release-mem-object (memobj)
+  (check-error (%release-mem-object memobj)))
+
+(get-cl-objects get-supported-image-formats (context flags image-type)
+                %get-supported-image-formats 'cl-image-format)
+
+(defparameter +mem-object-info-type-alist+
+  '((:mem-type                 . cl-mem-object-type)
+    (:mem-flags                . cl-mem-flags)
+    (:mem-size                 . :size)
+    (:mem-host-ptr             . (:pointer :void))
+    (:mem-map-count            . cl-uint)
+    (:mem-reference-count      . cl-uint)
+    (:mem-context              . cl-context)
+    (:mem-associated-memobject . cl-mem)
+    (:mem-offset               . :size)
+    (:mem-uses-svm-pointer     . cl-bool)
+    (:mem-properties           . (:pointer cl-mem-properties))))
+
+(wrap-get-info-function get-mem-object-info %get-mem-object-info
+                        +mem-object-info-type-alist+)
+
+(defparameter +image-info-type-alist+
+  '((:image-format         . cl-image-format)
+    (:image-element-size   . :size)
+    (:image-row-pitch      . :size)
+    (:image-slice-pitch    . :size)
+    (:image-width          . :size)
+    (:image-height         . :size)
+    (:image-depth          . :size)
+    (:image-array-size     . :size)
+    (:image-buffer         . cl-mem)
+    (:image-num-mip-levels . cl-uint)
+    (:image-num-samples    . cl-uint)))
+
+(wrap-get-info-function get-image-info %get-image-info +image-info-type-alist+)
+
+(defparameter +pipe-info-type-alist+
+  '((:pipe-packet-size . cl-uint)
+    (:pipe-max-packets . cl-uint)
+    (:pipe-properties  . (:pointer cl-pipe-properties))))
+
+(wrap-get-info-function get-pipe-info %get-pipe-info +pipe-info-type-alist+)
+
+(defmacro with-mem-object ())
+
+(defmacro with-buffer ((buffer context flags size &optional host-ptr) &body body)
+  `(let ((,buffer (create-buffer ,context ,flags ,size ,(if host-ptr host-ptr '(cffi:null-pointer)))))
+     (unwind-protect
+          (progn ,@body)
+       (release-mem-object ,buffer))))
+
+(defmacro with-buffer-from-array ((buffer context flags array) &body body)
+  `(let ((,buffer (create-buffer-from-array ,context ,flags ,array)))
+     (unwind-protect
+          (progn ,@body)
+       (release-mem-object ,buffer))))
+
+(defmacro with-buffers-from-arrays ())
+
+(defun copy-buffer-to-array (queue buffer array)
+  (let* ((length (length array))
+         (c-type (array-foreign-type array))
+         (size (* length (cffi:foreign-type-size c-type))))
+    (cffi:with-foreign-object (c-array c-type length)
+      (enqueue-read-buffer queue buffer t 0 size c-array)
+      (dotimes (i length)
+        (setf (aref array i) (cffi:mem-aref c-array c-type i))))))
-- 
cgit v1.2.3