Initial commit

1 files changed, 176 insertions, 0 deletions

diff --git a/src/device.lisp b/src/device.lisp
new file mode 100644
index 0000000..830ee82
--- /dev/null
+++ b/src/device.lisp
@@ -0,0 +1,176 @@
+(in-package #:ocl)
+
+(defun get-device-ids (platform device-type)
+  (let (num-devices)
+    (cffi:with-foreign-object (c-num-devices 'cl-uint)
+      (check-error (%get-device-ids platform device-type 0 (cffi:null-pointer) c-num-devices))
+      (setf num-devices (cffi:mem-ref c-num-devices 'cl-uint)))
+    (cffi:with-foreign-object (c-devices 'cl-device-id num-devices)
+      (check-error (%get-device-ids platform device-type num-devices c-devices (cffi:null-pointer)))
+      (loop :for i :below num-devices
+            :collect (cffi:mem-aref c-devices 'cl-device-id i)))))
+
+(defparameter +device-info-type-alist+
+  '((:device-type                                    . cl-device-type)
+    (:device-vendor-id                               . cl-uint)
+    (:device-max-compute-units                       . cl-uint)
+    (:device-max-work-item-dimensions                . cl-uint)
+    (:device-max-work-group-size                     . :size)
+    (:device-max-work-item-sizes                     . (:pointer :size))
+    (:device-preferred-vector-width-char             . cl-uint)
+    (:device-preferred-vector-width-short            . cl-uint)
+    (:device-preferred-vector-width-int              . cl-uint)
+    (:device-preferred-vector-width-long             . cl-uint)
+    (:device-preferred-vector-width-float            . cl-uint)
+    (:device-preferred-vector-width-double           . cl-uint)
+    (:device-max-clock-frequency                     . cl-uint)
+    (:device-address-bits                            . cl-uint)
+    (:device-max-read-image-args                     . cl-uint)
+    (:device-max-write-image-args                    . cl-uint)
+    (:device-max-mem-alloc-size                      . cl-ulong)
+    (:device-image2d-max-width                       . :size)
+    (:device-image2d-max-height                      . :size)
+    (:device-image3d-max-width                       . :size)
+    (:device-image3d-max-height                      . :size)
+    (:device-image3d-max-depth                       . :size)
+    (:device-image-support                           . cl-bool)
+    (:device-max-parameter-size                      . :size)
+    (:device-max-samplers                            . cl-uint)
+    (:device-mem-base-addr-align                     . cl-uint)
+    (:device-min-data-type-align-size                . cl-uint)
+    (:device-single-fp-config                        . cl-device-fp-config)
+    (:device-global-mem-cache-type                   . cl-device-mem-cache-type)
+    (:device-global-mem-cacheline-size               . cl-uint)
+    (:device-global-mem-cache-size                   . cl-ulong)
+    (:device-global-mem-size                         . cl-ulong)
+    (:device-max-constant-buffer-size                . cl-ulong)
+    (:device-max-constant-args                       . cl-uint)
+    (:device-local-mem-type                          . cl-device-local-mem-type)
+    (:device-local-mem-size                          . cl-ulong)
+    (:device-error-correction-support                . cl-bool)
+    (:device-profiling-timer-resolution              . :size)
+    (:device-endian-little                           . cl-bool)
+    (:device-available                               . cl-bool)
+    (:device-compiler-available                      . cl-bool)
+    (:device-execution-capabilities                  . cl-device-exec-capabilities)
+    (:device-queue-properties                        . cl-command-queue-properties)
+    (:device-queue-on-host-properties                . cl-command-queue-properties)
+    (:device-name                                    . :string)
+    (:device-vendor                                  . :string)
+    (:driver-version                                 . :string)
+    (:device-profile                                 . :string)
+    (:device-version                                 . :string)
+    (:device-extensions                              . :string)
+    (:device-platform                                . cl-platform-id)
+    (:device-double-fp-config                        . cl-device-fp-config)
+    (:device-preferred-vector-width-half             . cl-uint)
+    (:device-host-unified-memory                     . cl-bool)
+    (:device-native-vector-width-char                . cl-uint)
+    (:device-native-vector-width-short               . cl-uint)
+    (:device-native-vector-width-int                 . cl-uint)
+    (:device-native-vector-width-long                . cl-uint)
+    (:device-native-vector-width-float               . cl-uint)
+    (:device-native-vector-width-double              . cl-uint)
+    (:device-native-vector-width-half                . cl-uint)
+    (:device-opencl-c-version                        . :string)
+    (:device-linker-available                        . cl-bool)
+    (:device-built-in-kernels                        . :string)
+    (:device-image-max-buffer-size                   . :size)
+    (:device-image-max-array-size                    . :size)
+    (:device-parent-device                           . cl-device-id)
+    (:device-partition-max-sub-devices               . cl-uint)
+    (:device-partition-properties                    . (:pointer cl-device-partition-property))
+    (:device-partition-affinity-domain               . cl-device-affinity-domain)
+    (:device-partition-type                          . (:pointer cl-device-partition-property))
+    (:device-reference-count                         . cl-uint)
+    (:device-preferred-interop-user-sync             . cl-bool)
+    (:device-printf-buffer-size                      . :size)
+    (:device-image-pitch-alignment                   . cl-uint)
+    (:device-image-base-address-alignment            . cl-uint)
+    (:device-max-read-write-image-args               . cl-uint)
+    (:device-max-global-variable-size                . :size)
+    (:device-queue-on-device-properties              . cl-command-queue-properties)
+    (:device-queue-on-device-preferred-size          . cl-uint)
+    (:device-queue-on-device-max-size                . cl-uint)
+    (:device-max-on-device-queues                    . cl-uint)
+    (:device-max-on-device-events                    . cl-uint)
+    (:device-svm-capabilities                        . cl-device-svm-capabilities)
+    (:device-global-variable-preferred-total-size    . :size)
+    (:device-max-pipe-args                           . cl-uint)
+    (:device-pipe-max-active-reservations            . cl-uint)
+    (:device-pipe-max-packet-size                    . cl-uint)
+    (:device-preferred-platform-atomic-alignment     . cl-uint)
+    (:device-preferred-global-atomic-alignment       . cl-uint)
+    (:device-preferred-local-atomic-alignment        . cl-uint)
+    (:device-il-version                              . :string)
+    (:device-max-num-sub-groups                      . cl-uint)
+    (:device-sub-group-independent-forward-progress  . cl-bool)
+    (:device-numeric-version                         . cl-version)
+    (:device-extensions-with-version                 . (:pointer cl-name-version))
+    (:device-ils-with-version                        . (:pointer cl-name-version))
+    (:device-built-in-kernels-with-version           . (:pointer cl-name-version))
+    (:device-atomic-memory-capabilities              . cl-device-atomic-capabilities)
+    (:device-atomic-fence-capabilities               . cl-device-atomic-capabilities)
+    (:device-non-uniform-work-group-support          . cl-bool)
+    (:device-opencl-c-all-versions                   . (:pointer cl-name-version))
+    (:device-preferred-work-group-size-multiple      . :size)
+    (:device-work-group-collective-functions-support . cl-bool)
+    (:device-generic-address-space-support           . cl-bool)
+    (:device-opencl-c-features                       . (:pointer cl-name-version))
+    (:device-device-enqueue-capabilities             . cl-device-device-enqueue-capabilities)
+    (:device-pipe-support                            . cl-bool)
+    (:device-latest-conformance-version-passed       . :string)))
+
+(wrap-get-info-function get-device-info %get-device-info +device-info-type-alist+)
+
+;; (defun get-device-info (device param-name)
+;;   (let ((type (assoc-value +device-info-type-alist+ param-name))
+;;         (return-size nil)
+;;         (error-code nil)
+;;         (return-value nil))
+;;     (cffi:with-foreign-object (c-return-size :size)
+;;       (setf error-code (%get-device-info device param-name 0 (cffi:null-pointer) c-return-size))
+;;       (unless (eq error-code :success)
+;;         (error 'opencl-error :code 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 (%get-device-info device 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 (%get-device-info device param-name return-size c-string (cffi:null-pointer))))))
+;;           (t
+;;            (cffi:with-foreign-object (c-value type)
+;;              (setf error-code (%get-device-info device param-name (cffi:foreign-type-size type)
+;;                                                 c-value (cffi:null-pointer)))
+;;              (setf return-value (cffi:mem-ref c-value type)))))
+;;     (unless (eq error-code :success)
+;;       (error 'opencl-error :code error-code))
+;;     return-value))
+
+;; (defun create-sub-devices (in-device properties)
+;;   (check-error (%create-sub-devices in-device )))
+
+(defun retain-device (device)
+  (check-error (%retain-device device)))
+
+(defun release-device (device)
+  (check-error (%release-device device)))
+
+(defun set-default-device-command-queue (context device command-queue)
+  (check-error (%set-default-device-command-queue context device command-queue)))
+
+(defun get-device-and-host-timer (device)
+  (cffi:with-foreign-objects ((device-timestamp 'cl-ulong)
+                              (host-timestamp 'cl-ulong))
+    (check-error (%get-device-and-host-timer device device-timestamp host-timestamp))
+    (values (cffi:mem-ref device-timestamp 'cl-ulong)
+            (cffi:mem-ref host-timestamp 'cl-ulong))))
+
+(defun get-host-timer (device)
+  (cffi:with-foreign-object (host-timestamp 'cl-ulong)
+    (check-error (%get-host-timer device host-timestamp))
+    (cffi:mem-ref host-timestamp 'cl-ulong)))