path: root/chickadee/graphics/gpu.scm

;;; Chickadee Game Toolkit
;;; Copyright © 2023 David Thompson <dthompson2@worcester.edu>
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;    http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

;;; Commentary:
;;
;; WebGPU-like abstract GPU interface.
;;
;;; Code:

(define-module (chickadee graphics gpu)
  #:use-module (chickadee graphics color)
  #:use-module (ice-9 match)
  #:use-module (ice-9 threads)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:export (make-gpu
            gpu-tick
            gpu-swap
            gpu-gc
            gpu-submit
            current-gpu
            define-gpu-backend

            make-buffer
            buffer?
            buffer-available?
            buffer-destroyed?
            buffer-mapped?
            buffer-destroy!
            buffer-map!
            buffer-unmap!
            bytevector->buffer

            make-texture
            texture-destroy!
            texture?
            texture-gpu
            texture-handle
            texture-destroyed?
            texture-width
            texture-height
            texture-layers
            texture-mip-level-count
            texture-sample-count
            texture-dimension
            texture-format
            texture-usage
            texture-view-formats

            make-texture-view
            texture-view-destroy!
            texture-view?
            texture-view-gpu
            texture-view-handle
            texture-view-destroyed?
            texture-view-texture
            texture-view-format
            texture-view-dimension
            texture-view-aspect
            texture-view-base-mip-level
            texture-view-mip-level-count
            texture-view-base-layer
            texture-view-layer-count

            make-sampler
            sampler-destroy!
            sampler?
            sampler-gpu
            sampler-handle
            sampler-destroyed?
            sampler-address-mode-u
            sampler-address-mode-v
            sampler-address-mode-w
            sampler-mag-filter
            sampler-min-filter
            sampler-mipmap-filter

            make-shader-module
            shader-module?
            shader-module-vertex
            shader-module-fragment

            make-vertex-attribute
            vertex-attribute?
            vertex-attribute-location
            vertex-attribute-format
            vertex-attribute-offset

            make-vertex-buffer-layout
            vertex-buffer-layout?
            vertex-buffer-layout-stride
            vertex-buffer-layout-step-mode
            vertex-buffer-layout-attributes

            make-vertex-state
            vertex-state?
            vertex-state-module
            vertex-state-buffers

            make-blend-component
            blend-component?
            blend-component-operation
            blend-component-src-factor
            blend-component-dst-factor

            make-blend-state
            blend-state?
            blend-state-color
            blend-state-alpha

            make-color-target-state
            color-target-state?
            color-target-state-format
            color-target-state-blend
            color-target-state-write-mask

            make-fragment-state
            fragment-state?
            fragment-state-module
            fragment-state-targets

            make-primitive-state
            primitive-state?
            primitive-state-topology
            primitive-state-front-face
            primitive-state-cull-mode
            primitive-state-unclipped-depth?

            make-stencil-face-state
            stencil-face-state?
            stencil-face-state-compare
            stencil-face-state-fail-op
            stencil-face-state-depth-fail-op
            stencil-face-state-pass-op

            make-depth-stencil-format
            depth-stencil-format?
            depth-stencil-state-format
            depth-stencil-state-depth-write-enabled?
            depth-stencil-state-compare-function
            depth-stencil-state-stencil-front
            depth-stencil-state-stencil-back
            depth-stencil-state-stencil-read-mask
            depth-stencil-state-stencil-write-mask

            make-multisample-state
            multisample-state?
            multisample-state-count
            multisample-state-mask
            multisample-state-alpha-to-coverage?

            make-render-pipeline
            render-pipeline?
            render-pipeline-vertex
            render-pipeline-fragment
            render-pipeline-primitive
            render-pipeline-depth-stencil
            render-pipeline-multisample

            make-color-attachment
            color-attachment?
            color-attachment-view
            color-attachment-resolve-target
            color-attachment-clear-color
            color-attachment-load-op
            color-attachment-store-op

            make-depth-stencil-attachment
            depth-stencil-attachment?
            depth-stencil-attachment-view
            depth-stencil-attachment-depth-clear-value
            depth-stencil-attachment-depth-load-op
            depth-stencil-attachment-depth-store-op
            depth-stencil-attachment-depth-read-only?
            depth-stencil-attachment-stencil-clear-value
            depth-stencil-attachment-stencil-load-op
            depth-stencil-attachment-stencil-store-op
            depth-stencil-attachment-stencil-read-only?

            make-render-pass-descriptor
            render-pass-descriptor?
            render-pass-descriptor?-color-attachments
            render-pass-descriptor?-depth-stencil-attachment
            render-pass-descriptor?-max-draw-count

            render-state?
            render-state-pipeline
            render-state-vertex-buffers

            command-buffer?
            command-buffer-commands

            make-command-encoder
            command-encoder?
            command-encoder-finish
            begin-render-pass

            render-pass-encoder?
            render-pass-encoder-pipeline
            render-pass-encoder-vertex-buffers
            set-render-pass-encoder-pipeline!
            set-render-pass-encoder-vertex-buffer!
            render-pass-draw
            end-render-pass))

(define-syntax-rule (define-record-type* name
                      make pred
                      (field accessor default) ...)
  (begin
    (define-record-type name
      (%make field ...)
      pred
      (field accessor) ...)
    (define* (make #:key (field default) ...)
      (%make field ...))))


;;;
;;; Generic GPU
;;;

(define-syntax-rule (define-gpu-type name make pred
                      (mutex mutex-accessor)
                      (guardian guardian-accessor)
                      (internal internal-accessor)
                      (vfield vfield-accessor
                              (vfield-dispatch vfield-dispatch-args ...))
                      ...)
  (begin
    (define-record-type name
      (%make mutex guardian internal vfield ...)
      pred
      (mutex mutex-accessor)
      (guardian guardian-accessor)
      (internal internal-accessor)
      (vfield vfield-accessor) ...)
    (define* (make internal #:key vfield ...)
      (%make (make-recursive-mutex) (make-guardian) internal vfield ...))
    (define (vfield-dispatch gpu vfield-dispatch-args ...)
      (with-mutex (mutex-accessor gpu)
        ((vfield-accessor gpu)
         (internal-accessor gpu)
         vfield-dispatch-args ...)))
    ...))

(define-gpu-type <gpu>
  %make-gpu
  gpu?
  (mutex gpu-mutex)
  (guardian gpu-guardian)
  (internal gpu-internal)
  (tick %gpu-tick (gpu-tick))
  (swap %gpu-swap (gpu-swap))
  (enqueue %gpu-enqueue (backend:enqueue command-buffer))
  (make-buffer %gpu-make-buffer
               (backend:make-buffer length usage))
  (buffer-destroy %gpu-buffer-destroy
                  (backend:buffer-destroy buffer))
  (buffer-map %gpu-buffer-map
              (backend:buffer-map buffer mode offset sizes))
  (buffer-unmap %gpu-buffer-unmap
                (backend:buffer-unmap buffer))
  (buffer-write %gpu-buffer-write
                (backend:buffer-write buffer buffer-offset data data-offset
                                      length))
  (make-texture %gpu-make-texture
                (backend:make-texture width height depth mip-level-count
                                      sample-count dimension format usage
                                      view-formats))
  (texture-destroy %gpu-texture-destroy (backend:texture-destroy texture))
  (make-texture-view %gpu-make-texture-view
                     (backend:make-texture-view texture format dimension aspect
                                                base-mip-level mip-level-count
                                                base-depth depth))
  (texture-view-destroy %gpu-texture-view-destroy
                        (backend:texture-view-destroy view))
  (make-sampler %gpu-make-sampler
                (backend:make-sampler address-mode-u address-mode-v
                                      address-mode-w mag-filter min-filter
                                      mipmap-filter))
  (sampler-destroy %gpu-sampler-destroy (backend:sampler-destroy module))
  (make-shader-module %gpu-make-shader-module
                      (backend:make-shader-module vertex-source fragment-source))
  (shader-module-destroy %gpu-shader-module-destroy
                         (backend:shader-module-destroy module))
  (make-render-pipeline %gpu-make-render-pipeline
                        (backend:make-render-pipeline vertex fragment
                                                      primitive depth-stencil
                                                      multisample))
  (render-pipeline-destroy %gpu-render-pipeline-destroy
                           (backend:render-pipeline-destroy pipeline)))

(define (gpu-guard! gpu obj)
  ((gpu-guardian gpu) obj))

(define *gpu-backends* (make-hash-table))

(define (gpu-backend-ref name)
  (hashq-ref *gpu-backends* name))

(define (gpu-backend-set! name proc)
  (hashq-set! *gpu-backends* name proc))

(define-syntax-rule (define-gpu-backend name
                      internal-constructor
                      args ...)
  (gpu-backend-set! 'name
                    (lambda (window context)
                      (%make-gpu (internal-constructor window context)
                                 args ...))))

(define current-gpu (make-parameter #f))

;; TODO: Respect the args according to WebGPU spec.
;;
;; TODO: Platform detection + open SDL window with proper GL, Vulkan,
;; or Metal flag.  Forcing OpenGL for now.
(define* (make-gpu window context #:key
                   power-preference
                   (required-features '())
                   (required-limits '()))
  ;; Include module at runtime to avoid circular reference.
  ;;
  ;; TODO: Programatically discover backend modules, load them, and
  ;; pick the "best" one.
  (module-use! (current-module)
               (resolve-interface
                '(chickadee graphics backend opengl)))
  ((gpu-backend-ref 'opengl) window context))


;;;
;;; Buffers
;;;

(define-record-type <buffer>
  (%make-buffer gpu handle length usage state map-state)
  buffer?
  (gpu buffer-gpu)
  (handle buffer-handle)
  (length buffer-length)
  (usage buffer-usage)
  (state buffer-state set-buffer-state!)
  (map-state buffer-map-state set-buffer-map-state!)
  (mapping buffer-mapping set-buffer-mapping!))

(define (print-buffer buffer port)
  (match buffer
    (($ <buffer> _ handle length usage)
     (format #t "#<buffer handle: ~a length: ~a usage ~a>"
             handle length usage))))

(set-record-type-printer! <buffer> print-buffer)

(define (buffer-available? buffer)
  (eq? (buffer-state buffer) 'available))

(define (buffer-destroyed? buffer)
  (eq? (buffer-state buffer) 'destroyed))

(define (buffer-mapped? buffer)
  (eq? (buffer-map-state buffer) 'mapped))

;; TODO: Validate length is > 0 and < max length.
;; TODO: Validate usage flags.
(define* (make-buffer gpu length #:optional (usage '(vertex)))
  (let ((handle (backend:make-buffer gpu length usage)))
    (%make-buffer gpu handle length usage 'available 'unmapped)))

;; TODO: Ensure buffer is unmapped first.
(define (buffer-destroy! buffer)
  (unless (buffer-destroyed? buffer)
    (backend:buffer-destroy (buffer-gpu buffer) (buffer-handle buffer))
    (set-buffer-state! buffer 'destroyed)))

(define (buffer-map! buffer mode offset size)
  (backend:buffer-map (buffer-gpu buffer) (buffer-handle buffer)
                      mode offset size))

(define (buffer-unmap! buffer)
  (when (buffer-mapped? buffer)
    (backend:buffer-unmap (buffer-gpu buffer) (buffer-handle buffer))
    (set-buffer-mapping! buffer #f)))

(define* (bytevector->buffer gpu bv #:optional (usage '(vertex)))
  (let* ((length (bytevector-length bv))
         (buffer (make-buffer gpu length usage)))
    (backend:buffer-write gpu (buffer-handle buffer) 0 bv 0 (bytevector-length bv))
    buffer))


;;;
;;; Textures
;;;

(define-record-type <texture>
  (%make-texture gpu handle destroyed? width height layers mip-level-count
                 sample-count dimension format usage view-formats)
  texture?
  (gpu texture-gpu)
  (handle texture-handle)
  (destroyed? texture-destroyed? set-texture-destroyed!)
  (width texture-width)
  (height texture-height)
  (layers texture-layers)
  (mip-level-count texture-mip-level-count)
  (sample-count texture-sample-count)
  (dimension texture-dimension)
  (format texture-format)
  (usage texture-usage)
  (view-formats texture-view-formats))

(define (print-texture texture port)
  (match texture
    (($ <texture> _ handle _ width height layers _ _ dimension format* usage)
     (format #t "#<texture handle: ~a width: ~a height: ~a layers: ~a dimension: ~a format: ~a usage: ~a>"
             handle width height layers dimension format* usage))))

(set-record-type-printer! <texture> print-texture)

(define* (make-texture gpu #:key
                       (width 1)
                       (height 1)
                       (layers 0)
                       (mip-level-count 1)
                       (sample-count 1)
                       (dimension '2d)
                       format usage
                       (view-formats '()))
  (let ((handle (backend:make-texture gpu width height layers mip-level-count
                                      sample-count dimension format usage
                                      view-formats)))
    (%make-texture gpu handle #f width height layers mip-level-count
                   sample-count dimension format usage view-formats)))

(define (texture-destroy! texture)
  (unless (texture-destroyed? texture)
    (backend:texture-destroy (texture-gpu texture) (texture-handle texture))
    (set-texture-destroyed! texture #t)))

(define-record-type <texture-view>
  (%make-texture-view gpu handle destroyed? texture format dimension aspect
                      base-mip-level mip-level-count base-layer layer-count)
  texture-view?
  (gpu texture-view-gpu)
  (handle texture-view-handle)
  (destroyed? texture-view-destroyed? set-texture-view-destroyed!)
  (texture texture-view-texture)
  (format texture-view-format)
  (dimension texture-view-dimension) ; 2d or 3d
  (aspect texture-view-aspect) ; all, stencil-only, depth-only
  (base-mip-level texture-view-base-mip-level)
  (mip-level-count texture-view-mip-level-count)
  (base-layer texture-view-base-layer)
  (layer-count texture-view-layer-count))

(define (print-texture-view view port)
  (match view
    (($ <texture-view> _ handle _ texture format* dimension)
     (format #t "#<texture-view handle: ~a texture: ~a format: ~a dimension: ~a>"
             handle texture format* dimension))))

(set-record-type-printer! <texture-view> print-texture-view)

(define* (make-texture-view gpu texture #:key
                            format
                            (dimension '2d)
                            (aspect 'all)
                            (base-mip-level 0)
                            (mip-level-count 0)
                            (base-layer 0)
                            (layer-count 0))
  (let ((handle (backend:make-texture-view gpu texture format dimension aspect
                                           base-mip-level mip-level-count
                                           base-layer layer-count)))
    (%make-texture-view gpu handle #f texture format dimension aspect
                        base-mip-level mip-level-count base-layer layer-count)))

(define (texture-view-destroy! view)
  (unless (texture-view-destroyed? view)
    (backend:texture-view-destroy (texture-view-gpu view)
                                  (texture-view-handle view))
    (set-texture-view-destroyed! view #t)))

;; TODO: lod, compare, anisotropy.
(define-record-type <sampler>
  (%make-sampler gpu handle destroyed?
                 address-mode-u address-mode-v address-mode-w
                 mag-filter min-filter mipmap-filter)
  sampler?
  (gpu sampler-gpu)
  (handle sampler-handle)
  (destroyed? sampler-destroyed? set-sampler-destroyed!)
  ;; clamp-to-edge, repeat, or mirror-repeat
  (address-mode-u sampler-address-mode-u)
  (address-mode-v sampler-address-mode-v)
  (address-mode-w sampler-address-mode-w)
  ;; nearest or linear
  (mag-filter sampler-mag-filter)
  (min-filter sampler-min-filter)
  (mipmap-filter sampler-mipmap-filter))

(define (print-sampler view port)
  (match view
    (($ <sampler> _ handle _ u v w mag min mip)
     (format #t "#<sampler handle: ~a address-mode-u: ~a address-mode-v: ~a address-mode-w: ~a mag-filter: ~a min-filter: ~a mipmap-filter: ~a>"
             handle u v w mag min mip))))

(set-record-type-printer! <sampler> print-sampler)

(define* (make-sampler gpu #:key
                       (address-mode-u 'clamp-to-edge)
                       (address-mode-v 'clamp-to-edge)
                       (address-mode-w 'clamp-to-edge)
                       (mag-filter 'nearest)
                       (min-filter 'nearest)
                       (mipmap-filter 'nearest))
  (let ((handle (backend:make-sampler gpu address-mode-u address-mode-v
                                      address-mode-w mag-filter min-filter
                                      mipmap-filter)))
    (%make-sampler gpu handle #f address-mode-u address-mode-v
                   address-mode-w mag-filter min-filter
                   mipmap-filter)))

(define (sampler-destroy! sampler)
  (unless (sampler-destroyed? sampler)
    (backend:sampler-destroy (sampler-gpu sampler) (sampler-handle sampler))
    (set-sampler-destroyed! sampler #t)))


;;;
;;; Shader modules
;;;

(define-record-type <shader-module>
  (%make-shader-module gpu handle state)
  shader-module?
  (gpu shader-module-gpu)
  (handle shader-module-handle)
  (state shader-module-state set-shader-module-state!))

(define (print-shader-module shader port)
  (match shader
    (($ <shader-module> _ handle)
     (format #t "#<shader-module handle: ~a>" handle))))

(set-record-type-printer! <shader-module> print-shader-module)

(define (shader-module-available? shader-module)
  (eq? (shader-module-state shader-module) 'available))

(define (shader-module-destroyed? shader-module)
  (eq? (shader-module-state shader-module) 'destroyed))

(define* (make-shader-module gpu #:key vertex-source fragment-source)
  (let ((handle (backend:make-shader-module gpu vertex-source fragment-source)))
    (%make-shader-module gpu handle 'available)))

(define (shader-module-destroy! module)
  (unless (shader-module-destroyed? module)
    (backend:shader-module-destroy (shader-module-gpu module)
                                   (shader-module-handle module))
    (set-shader-module-state! module 'destroyed)))


;;;
;;; Render pipelines
;;;

(define-record-type* <vertex-attribute>
  make-vertex-attribute
  attribute?
  (location vertex-attribute-location #f)
  (format vertex-attribute-format #f)
  (offset vertex-attribute-offset 0))

(define-record-type* <vertex-buffer-layout>
  make-vertex-buffer-layout
  vertex-buffer-layout?
  (stride vertex-buffer-layout-stride 0)
  (step-mode vertex-buffer-layout-step-mode 'vertex)
  (attributes vertex-buffer-layout-attributes '()))

(define-record-type* <vertex-state>
  make-vertex-state
  vertex-state?
  (module vertex-state-module #f)
  (buffers vertex-state-buffers '()))

(define-record-type* <blend-component>
  make-blend-component
  blend-component?
  (operation blend-component-operation 'add)
  (src-factor blend-component-src-factor 'one)
  (dst-factor blend-component-dst-factor 'zero))

(define-record-type* <blend-state>
  make-blend-state
  blend-state?
  (color blend-state-color (make-blend-component))
  (alpha blend-state-alpha (make-blend-component)))

(define-record-type* <color-target-state>
  make-color-target-state
  color-target-state?
  (format color-target-state-format #f)
  (blend color-target-state-blend #f)
  (write-mask color-target-state-write-mask #xf))

(define-record-type* <fragment-state>
  make-fragment-state
  fragment-state?
  (module fragment-state-module #f)
  (targets fragment-state-targets '()))

(define-record-type* <primitive-state>
  make-primitive-state
  primitive-state
  (topology primitive-state-topology 'triangle-list)
  (front-face primitive-state-front-face 'ccw)
  (cull-mode primitive-state-cull-mode 'none)
  (unclipped-depth? primitive-state-unclipped-depth? #f))

(define-record-type* <stencil-face-state>
  make-stencil-face-state
  stencil-face-state?
  (compare stencil-face-state-compare 'always)
  (fail-op stencil-face-state-fail-op 'keep)
  (depth-fail-op stencil-face-state-depth-fail-op 'keep)
  (pass-op stencil-face-state-pass-op 'keep))

;; TODO: depth bias fields.
(define-record-type* <depth-stencil-state>
  make-depth-stencil-state
  depth-stencil-state?
  (format depth-stencil-state-format #f)
  (depth-write-enabled? depth-stencil-state-depth-write-enabled? #f)
  (compare-function depth-stencil-state-compare-function #f)
  (stencil-front depth-stencil-state-stencil-front (make-stencil-face-state))
  (stencil-back depth-stencil-state-stencil-back (make-stencil-face-state))
  (stencil-read-mask depth-stencil-state-stencil-read-mask #xffffffff)
  (stencil-write-mask depth-stencil-state-stencil-write-mask #xffffffff))

(define-record-type* <multisample-state>
  make-multisample-state
  multisample-state?
  (count multisample-state-count 1)
  (mask multisample-state-mask #xffffffff)
  (alpha-to-coverage? multisample-state-alpha-to-coverage? #f))

(define-record-type <render-pipeline>
  (%make-render-pipeline handle vertex fragment primitive depth-stencil multisample)
  render-pipeline?
  (handle render-pipeline-handle)
  (vertex render-pipeline-vertex)
  (fragment render-pipeline-fragment)
  (primitive render-pipeline-primitive)
  (depth-stencil render-pipeline-depth-stencil)
  (multisample render-pipeline-multisample))

(define* (make-render-pipeline gpu #:key vertex fragment
                               (primitive (make-primitive-state))
                               depth-stencil
                               (multisample (make-multisample-state)))
  (unless (vertex-state? vertex)
    (error "vertex state is required"))
  (let ((handle (backend:make-render-pipeline gpu vertex fragment primitive
                                              depth-stencil multisample)))
    (%make-render-pipeline handle vertex fragment primitive depth-stencil
                           multisample)))

(define default-clear-color (make-color 0.0 0.0 0.0 0.0))

(define-record-type* <color-attachment>
  make-color-attachment
  color-attachment?
  (view color-attachment-view #f)
  (resolve-target color-attachment-resolve-target #f)
  (clear-color color-attachment-clear-color default-clear-color)
  (load-op color-attachment-load-op 'clear)
  (store-op color-attachment-store-op 'store))

(define-record-type* <depth-stencil-attachment>
  make-depth-stencil-attachment
  depth-stencil-attachment?
  (view depth-stencil-attachment-view #f)
  (depth-clear-value depth-stencil-attachment-depth-clear-value 0.0)
  (depth-load-op depth-stencil-attachment-depth-load-op 'clear)
  (depth-store-op depth-stencil-attachment-depth-store-op 'store)
  (depth-read-only? depth-stencil-attachment-depth-read-only? #f)
  (stencil-clear-value depth-stencil-attachment-stencil-clear-value 0)
  (stencil-load-op depth-stencil-attachment-stencil-load-op 'clear)
  (stencil-store-op depth-stencil-attachment-stencil-store-op 'store)
  (stencil-read-only? depth-stencil-attachment-stencil-read-only? #f))

(define-record-type* <render-pass-descriptor>
  make-render-pass-descriptor
  render-pass-descriptor?
  (color-attachments render-pass--descriptorcolor-attachments '())
  (depth-stencil-attachment render-pass-descriptor-depth-stencil-attachment #f)
  (max-draw-count render-pass-descriptor-max-draw-count 50000000))

;; (define-record-type <buffer-binding-layout>
;;   (make-buffer-binding-layout type)
;;   buffer-binding-layout?
;;   ;; uniform, storage, or read-only-storage
;;   (type buffer-binding-layout-type))

;; (define-record-type <sampler-binding-layout>
;;   (make-sampler-binding-layout type)
;;   ;; filtering or non-filtering
;;   (type sampler-binding-layout-type))

;; (define-record-type <texture-binding-layout>
;;   (make-texture-binding-layout type dimension multisample?)
;;   texture-binding-layout?
;;   ;; float, unfilterable-float, depth, sint, uint
;;   (type texture-binding-layout-type)
;;   (dimension texture-binding-layout-dimension) ; 2d or 3d
;;   (multisample? texture-binding-layout-multisample?))

;; (define-record-type <binding-layout>
;;   (make-binding-layout index stages kind)
;;   binding-layout?
;;   (index binding-layout-index) ; integer
;;   (stages binding-layout-stages) ; vertex, fragment, or compute
;;   (kind binding-layout-kind))

;; (define-record-type <bind-group-entry>
;;   (make-bind-group-entry index resource)
;;   bind-group-entry?
;;   (index bind-group-entry-index)
;;   (resource bind-group-entry-resource))

;; (define-record-type <bind-group>
;;   (make-bind-group layout bindings)
;;   bind-group?
;;   (layout bind-group-layout)
;;   (bindings bind-group-bindings))

;; ;; A single GPU command. These objects are re-used over and over to
;; ;; reduce allocation during rendering.  Not directly exposed to users.
;; (define-record-type <command>
;;   (make-render-command op arg1 arg2 arg3 arg4 arg5)
;;   render-command?
;;   (op render-command-op)
;;   (arg1 render-command-arg1)
;;   (arg2 render-command-arg2)
;;   (arg3 render-command-arg3)
;;   (arg4 render-command-arg4)
;;   (arg5 render-command-arg5))


;;;
;;; Commands
;;;

(define-record-type <command-buffer>
  (make-command-buffer commands)
  command-buffer?
  (commands command-buffer-commands))

;; A public wrapper around a command buffer.  The command encoder asks
;; the GPU for a command buffer (so that the GPU can reuse command
;; buffers repeatedly to reduce allocation), fills it up with
;; commands, and then submits the buffer back to the GPU for
;; execution.
(define-record-type <command-encoder>
  (%make-command-encoder state commands)
  command-encoder?
  (state command-encoder-state set-command-encoder-state!)
  (commands command-encoder-commands set-command-encoder-commands!))

;; TODO: Don't hardcode this limit and move the limit into the GPU
;; object.
(define max-vertex-buffers 8)

(define-record-type <render-pass-encoder>
  (make-render-pass-encoder state command-encoder descriptor pipeline
                            vertex-buffers)
  render-pass-encoder?
  (state render-pass-encoder-state set-render-pass-encoder-state!)
  (command-encoder render-pass-encoder-command-encoder)
  (descriptor render-pass-encoder-descriptor)
  (pipeline render-pass-encoder-pipeline set-render-pass-encoder-pipeline!)
  (vertex-buffers render-pass-encoder-vertex-buffers
                  set-render-pass-encoder-vertex-buffers!))

(define-record-type <render-state>
  (%make-render-state pipeline vertex-buffers)
  render-state?
  (pipeline render-state-pipeline)
  (vertex-buffers render-state-vertex-buffers))

(define-record-type <draw-command>
  (make-draw-command render-state vertex-count instance-count
                     first-vertex first-instance)
  draw-command?
  (render-state draw-command-render-state)
  (vertex-count draw-command-vertex-count)
  (instance-count draw-command-instance-count)
  (first-vertex draw-command-first-vertex)
  (first-instance draw-command-first-instance))

(define (make-render-state pipeline vertex-buffers)
  (%make-render-state pipeline (vector-copy vertex-buffers)))

(define (make-command-encoder)
  (%make-command-encoder 'open '()))

(define (command-encoder-add! encoder command)
  (set-command-encoder-commands! encoder
                                 (cons command
                                       (command-encoder-commands encoder))))

(define (command-encoder-finish encoder)
  (make-command-buffer (reverse (command-encoder-commands encoder))))

(define (begin-render-pass command-encoder pass-descriptor)
  (make-render-pass-encoder 'open command-encoder pass-descriptor
                            #f (make-vector max-vertex-buffers #f)))

(define (end-render-pass pass)
  (set-render-pass-encoder-state! pass 'closed))

(define (render-pass-encoder->render-state pass)
  (match pass
    (($ <render-pass-encoder> _ _ _ pipeline vertex-buffers)
     (make-render-state pipeline vertex-buffers))))

(define (set-render-pass-encoder-vertex-buffer! pass index buffer)
  (vector-set! (render-pass-encoder-vertex-buffers pass) index buffer))

(define* (render-pass-draw pass vertex-count #:key
                           (instance-count 1)
                           (first-vertex 0)
                           (first-instance 0))
  (let ((cmd (make-draw-command (render-pass-encoder->render-state pass)
                                vertex-count instance-count
                                first-vertex first-instance)))
    (command-encoder-add! (render-pass-encoder-command-encoder pass) cmd)))

(define (gpu-submit gpu command-buffer)
  (with-mutex (gpu-mutex gpu)
    (backend:enqueue gpu command-buffer)))


;;;
;;; Garbage collection
;;;

(define (gpu-gc gpu)
  (with-mutex (gpu-mutex gpu)
    (let ((guardian (gpu-guardian gpu)))
      (let loop ()
        (let ((obj (guardian)))
          (when obj
            (match obj
              ((? buffer? buffer) (buffer-destroy! buffer))
              ((? texture? texture) (texture-destroy! texture))
              ((? shader-module? module) (shader-module-destroy! module)))
            (loop)))))))