path: root/chickadee/graphics/backend/opengl.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:
;;
;; OpenGL graphics backend.
;;
;;; Code:

(define-module (chickadee graphics backend opengl)
  #:use-module (chickadee graphics backend)
  #:use-module (chickadee graphics color)
  #:use-module (chickadee graphics depth-stencil)
  #:use-module (chickadee graphics layout)
  #:use-module (chickadee graphics primitive)
  #:use-module (chickadee graphics viewport)
  #:use-module (gl)
  #:use-module ((gl low-level) #:renamer (symbol-prefix-proc '%))
  #:use-module (gl runtime)
  #:use-module (gl types)
  #:use-module (ice-9 match)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:use-module ((system foreign) #:select (%null-pointer
                                           bytevector->pointer
                                           make-pointer
                                           pointer->string
                                           pointer->bytevector
                                           pointer-address))
  #:export (make-opengl-gpu))


;;;
;;; Additional OpenGL wrappers
;;;

;; TODO: Upstream these to guile-opengl

(define gl-clear-color %glClearColor)
(define gl-clear-depth %glClearDepth)
(define gl-clear-stencil %glClearStencil)
(define gl-scissor %glScissor)
(define gl-blend-func-separate %glBlendFuncSeparate)
(define gl-blend-equation-separate %glBlendEquationSeparate)
(define gl-blend-color %glBlendColor)
(define gl-active-texture %glActiveTexture)
(define gl-tex-image-3d %glTexImage3D)
(define gl-tex-image-2d %glTexImage2D)
(define gl-tex-image-1d %glTexImage1D)
(define gl-copy-tex-image-2d %glCopyTexImage2D)
(define gl-copy-tex-image-1d %glCopyTexImage1D)
(define gl-copy-tex-sub-image-3d %glCopyTexSubImage3D)
(define gl-copy-tex-sub-image-2d %glCopyTexSubImage2D)
(define gl-copy-tex-sub-image-1d %glCopyTexSubImage1D)
(define gl-tex-sub-image-3d %glTexSubImage3D)
(define gl-tex-sub-image-2d %glTexSubImage2D)
(define gl-tex-sub-image-1d %glTexSubImage1D)
(define gl-compressed-tex-image-1d %glCompressedTexImage1D)
(define gl-compressed-tex-image-2d %glCompressedTexImage2D)
(define gl-compressed-tex-image-3d %glCompressedTexImage3D)
(define gl-compressed-tex-sub-image-1d %glCompressedTexSubImage1D)
(define gl-compressed-tex-sub-image-2d %glCompressedTexSubImage2D)
(define gl-compressed-tex-sub-image-3d %glCompressedTexSubImage3D)
(define gl-tex-parameter %glTexParameteri)
(define gl-get-tex-parameter %glGetTexParameteriv)
(define gl-bind-texture %glBindTexture)
(define gl-get-tex-image %glGetTexImage)
(define gl-buffer-data %glBufferData)
(define gl-buffer-sub-data %glBufferSubData)
(define gl-map-buffer %glMapBuffer)
(define gl-unmap-buffer %glUnmapBuffer)
(define gl-draw-buffers %glDrawBuffers)
(define gl-draw-buffer %glDrawBuffer)
(define gl-use-program %glUseProgram)
(define gl-link-program  %glLinkProgram)
(define gl-bind-attrib-location  %glBindAttribLocation)
(define gl-attach-shader  %glAttachShader)
(define gl-detach-shader  %glDetachShader)
(define gl-get-attrib-location  %glGetAttribLocation)
(define gl-get-uniform-location  %glGetUniformLocation)
(define gl-create-program  %glCreateProgram)
(define gl-get-program-info-log  %glGetProgramInfoLog)
(define gl-get-programiv  %glGetProgramiv)
(define gl-delete-program  %glDeleteProgram)
(define gl-delete-shader  %glDeleteShader)
(define gl-get-shaderiv  %glGetShaderiv)
(define gl-get-shader-info-log  %glGetShaderInfoLog)
(define gl-compile-shader  %glCompileShader)
(define gl-shader-source  %glShaderSource)
(define gl-create-shader  %glCreateShader)
(define gl-get-active-uniform %glGetActiveUniform)
(define gl-get-active-attrib %glGetActiveAttrib)
(define gl-uniform1i  %glUniform1i)
(define gl-uniform1iv %glUniform1iv)
(define gl-uniform2i  %glUniform2i)
(define gl-uniform3i  %glUniform3i)
(define gl-uniform4i  %glUniform4i)
(define gl-uniform1f %glUniform1f)
(define gl-uniform1fv  %glUniform1fv)
(define gl-uniform2f  %glUniform2f)
(define gl-uniform2fv  %glUniform2fv)
(define gl-uniform3f %glUniform3f)
(define gl-uniform3fv %glUniform3fv)
(define gl-uniform4f  %glUniform4f)
(define gl-uniform4fv %glUniform4fv)
(define gl-uniform-matrix3fv %glUniformMatrix3fv)
(define gl-uniform-matrix4fv %glUniformMatrix4fv)
(define gl-point-size %glPointSize)
(define %gl-get-string %glGetString)
(define gl-get-integerv %glGetIntegerv)
(define gl-depth-func %glDepthFunc)
(define gl-depth-mask %glDepthMask)
(define gl-depth-range %glDepthRange)
(define gl-stencil-mask %glStencilMask)
(define gl-stencil-mask-separate %glStencilMaskSeparate)
(define gl-stencil-func %glStencilFunc)
(define gl-stencil-func-separate %glStencilFuncSeparate)
(define gl-stencil-op %glStencilOp)
(define gl-stencil-op-separate %glStencilOpSeparate)
(define gl-polygon-mode %glPolygonMode)
(define gl-cull-face %glCullFace)
(define gl-front-face %glFrontFace)
(define gl-color-mask %glColorMask)
(define gl-get-error %glGetError)

(define-gl-procedure (glTexStorage1D (target GLenum)
                                     (levels GLsizei)
                                     (internalformat GLenum)
                                     (width GLsizei)
                                     -> void)
  "Simultaneously specify storage for all levels of a one-dimensional texture.")

(define-gl-procedure (glTexStorage2D (target GLenum)
                                     (levels GLsizei)
                                     (internalformat GLenum)
                                     (width GLsizei)
                                     (height GLsizei)
                                     -> void)
  "Simultaneously specify storage for all levels of a two-dimensional or
one-dimensional array texture.")

(define-gl-procedure (glTexStorage3D (target GLenum)
                                     (levels GLsizei)
                                     (internalformat GLenum)
                                     (width GLsizei)
                                     (height GLsizei)
                                     (depth GLsizei)
                                     -> void)
  "Simultaneously specify storage for all levels of a three-dimensional,
two-dimensional array or cube-map array texture.")

(define-gl-procedure (glGenerateMipmap (target GLenum) -> void)
  "Generate mipmaps for the texture attached to target of the active
texture unit.")

(define-gl-procedure (glTextureView (texture GLuint)
                                    (target GLenum)
                                    (origtexture GLuint)
                                    (internalformat GLenum)
                                    (minlevel GLuint)
                                    (numlevels GLuint)
                                    (minlayer GLuint)
                                    (numlayers GLuint)
                                    -> void)
  "Initialize a texture as a data alias of another texture's data
store.")

(define-gl-procedure (glGenSamplers (n GLsizei)
                                    (ids GLuint-*)
                                    -> void)
  "Generate sampler object names.")

(define-gl-procedure (glDeleteSamplers (n GLsizei)
                                       (ids GLuint-*)
                                       -> void)
  "Delete named sampler objects.")

(define-gl-procedure (glSamplerParameteri (sampler GLuint)
                                          (pname GLenum)
                                          (param GLint)
                                          -> void)
  "Set sampler parameters.")

(define-gl-procedure (glBindSampler (unit GLuint)
                                    (sampler GLuint)
                                    -> void)
  "Bind sampler.")

(define-gl-procedure (glDrawArraysInstanced (mode GLenum)
                                            (first GLint)
                                            (count GLsizei)
                                            (primcount GLsizei)
                                            -> void)
  "Draw multiple instances of a set of arrays.")

(define-gl-procedure (glDrawElementsInstanced (mode GLenum)
                                              (count GLsizei)
                                              (type GLenum)
                                              (indices void-*)
                                              (primcount GLsizei)
                                              -> void)
  "Draw multiple instances of a set of elements.")

(define-gl-procedure (glVertexAttribDivisor (index GLuint)
                                            (divisor GLuint)
                                            -> void)
  "Modify the rate at which generic vertex attributes advance during
instanced rendering.")

(define-gl-procedure (glBindBufferBase (target GLenum)
                                       (index GLuint)
                                       (buffer GLuint)
                                       -> void)
  "Bind a buffer object to an indexed buffer target.")

(define-gl-procedure (glBindBufferRange (target GLenum)
                                        (index GLuint)
                                        (buffer GLuint)
                                        (offset GLint-*)
                                        (size GLsizei-*)
                                        -> void)
  "Bind a buffer object to an indexed buffer target.")

(define-gl-procedure (glGenVertexArrays (n GLsizei)
                                        (arrays GLuint-*)
                                        -> void)
  "Generate N vertex arrays.")

(define-gl-procedure (glDeleteVertexArrays (n GLsizei)
                                           (arrays GLuint-*)
                                           -> void)
  "Delete vertex array objects.")

(define-gl-procedure (glBindVertexArray (array GLuint)
                                        -> void)
  "Bind vertex array object ARRAY.")

(define-gl-procedure (glEnableVertexAttribArray (index GLuint)
                                                -> void)
  "Enable or disable a generic vertex attribute array.")

(define-gl-procedure (glVertexAttribPointer (index GLuint)
                                            (size GLint)
                                            (type GLenum)
                                            (normalized GLboolean)
                                            (stride GLsizei)
                                            (pointer GLvoid-*)
                                            -> void)
  "Define an array of generic vertex attribute data.")

(define-gl-procedure (glDrawElements (mode GLenum)
                                     (count GLsizei)
                                     (type GLenum)
                                     (indices GLvoid-*)
                                     -> void)
  "Render primitives from array data.")

(define-gl-procedure (glGenFramebuffers (n GLsizei)
                                        (ids GLuint-*)
                                        -> void)
  "Generate framebuffer object names.")

(define-gl-procedure (glDeleteFramebuffers (n GLsizei)
                                           (framebuffers GLuint-*)
                                           -> void)
  "Delete framebuffer objects.")

(define-gl-procedure (glBindFramebuffer (target GLenum)
                                        (framebuffer GLuint)
                                        -> void)
  "Bind a framebuffer to a framebuffer target.")

(define-gl-procedure (glGetFramebufferAttachmentParameteriv (target GLenum)
                                                            (attachment GLenum)
                                                            (pname GLenum)
                                                            (params GLint-*)
                                                            -> void)
  "Return attachment parameters of a framebuffer object.")

(define-gl-procedure (glFramebufferTexture2D (target GLenum)
                                             (attachment GLenum)
                                             (textarget GLenum)
                                             (texture GLuint)
                                             (level GLint)
                                             -> void)
  "Attach a level of a texture object as a logical buffer to the
currently bound framebuffer object.")

(define-gl-procedure (glCheckFramebufferStatus (target GLenum)
                                               -> GLenum)
  "Return the framebuffer completeness status of a framebuffer
object.")

(define-gl-procedure (glGenRenderbuffers (n GLsizei)
                                         (ids GLuint-*)
                                         -> void)
  "Generate renderbuffer object names.")

(define-gl-procedure (glDeleteRenderbuffers (n GLsizei)
                                            (renderbuffers GLuint-*)
                                            -> void)
  "Delete renderbuffer objects.")

(define-gl-procedure (glBindRenderbuffer (target GLenum)
                                         (renderbuffer GLuint)
                                         -> void)
  "Bind a named renderbuffer object.")

(define-gl-procedure (glRenderbufferStorage (target GLenum)
                                            (internalformat GLenum)
                                            (width GLsizei)
                                            (height GLsizei)
                                            -> void)
  "Create and initialize a renderbuffer object's data store.")

(define-gl-procedure (glFramebufferRenderbuffer (target GLenum)
                                                (attachment GLenum)
                                                (renderbuffertarget GLenum)
                                                (renderbuffer GLuint)
                                                -> void)
  "Attach a renderbuffer object to a framebuffer object.")

(define-gl-procedure (glUniform1ui (location GLint)
                                   (v0 GLuint)
                                   -> void)
  "Specify the value of a uniform variable for the current program object")

(define-gl-procedure (glUniform1uiv (location GLint)
                                    (count GLint)
                                    (ptr GLvoid-*)
                                    -> void)
  "Specify the value of a uniform variable for the current program object")

(define gl-tex-storage-1d glTexStorage1D)
(define gl-tex-storage-2d glTexStorage2D)
(define gl-tex-storage-3d glTexStorage3D)
(define gl-generate-mipmap glGenerateMipmap)
(define gl-texture-view glTextureView)
(define gl-gen-samplers glGenSamplers)
(define gl-sampler-parameter glSamplerParameteri)
(define gl-bind-sampler glBindSampler)
(define gl-draw-arrays-instanced glDrawArraysInstanced)
(define gl-draw-elements-instanced glDrawElementsInstanced)
(define gl-vertex-attrib-divisor glVertexAttribDivisor)
(define gl-bind-buffer-base glBindBufferBase)
(define gl-bind-buffer-range glBindBufferRange)
(define gl-gen-vertex-arrays glGenVertexArrays)
(define gl-delete-vertex-arrays glDeleteVertexArrays)
(define gl-bind-vertex-array glBindVertexArray)
(define gl-enable-vertex-attrib-array glEnableVertexAttribArray)
(define gl-vertex-attrib-pointer glVertexAttribPointer)
(define gl-draw-elements glDrawElements)
(define gl-gen-framebuffers glGenFramebuffers)
(define gl-bind-framebuffer glBindFramebuffer)
(define gl-get-framebuffer-attachment-parameteriv
  glGetFramebufferAttachmentParameteriv)
(define gl-framebuffer-texture-2d glFramebufferTexture2D)
(define gl-check-framebuffer-status glCheckFramebufferStatus)
(define gl-gen-renderbuffers glGenRenderbuffers)
(define gl-delete-renderbuffers glDeleteRenderbuffers)
(define gl-bind-renderbuffer glBindRenderbuffer)
(define gl-renderbuffer-storage glRenderbufferStorage)
(define gl-framebuffer-renderbuffer glFramebufferRenderbuffer)
(define gl-uniform1ui glUniform1ui)
(define gl-uniform1uiv glUniform1uiv)

(define (gl-generate-sampler)
  (let ((bv (u32vector 0)))
    (glGenSamplers 1 bv)
    (u32vector-ref bv 0)))

(define (gl-delete-sampler n)
  (let ((bv (u32vector n)))
    (glDeleteSamplers 1 bv)))

(define (gl-generate-vertex-array)
  (let ((bv (u32vector 0)))
    (glGenVertexArrays 1 bv)
    (u32vector-ref bv 0)))

(define (gl-delete-vertex-array n)
  (let ((bv (u32vector n)))
    (glDeleteVertexArrays 1 bv)))

(define (gl-generate-framebuffer)
  (let ((bv (u32vector 0)))
    (glGenFramebuffers 1 bv)
    (u32vector-ref bv 0)))

(define (gl-delete-framebuffer n)
  (let ((bv (u32vector n)))
    (glDeleteFramebuffers 1 bv)))

(define (gl-generate-renderbuffer)
  (let ((bv (u32vector 0)))
    (glGenRenderbuffers 1 bv)
    (u32vector-ref bv 0)))

(define (gl-delete-renderbuffer n)
  (let ((bv (u32vector n)))
    (glDeleteRenderbuffers 1 bv)))

(define (gl-get-integer id)
  (let ((bv (s32vector 0)))
    (gl-get-integerv id (bytevector->pointer bv))
    (s32vector-ref bv 0)))

(define (gl-get-string id)
  (pointer->string (%gl-get-string id)))


;;;
;;; Types
;;;

(define-record-type <gl-buffer>
  (%make-gl-buffer id map-cache)
  gl-buffer?
  (id gl-buffer-id)
  (map-cache gl-buffer-map-cache)
  (destroyed? gl-buffer-destroyed? set-gl-buffer-destroyed!))

(define-record-type <gl-texture>
  (%make-gl-texture id target width height depth mip-levels samples format)
  gl-texture?
  (id gl-texture-id)
  (target gl-texture-target)
  (width gl-texture-width)
  (height gl-texture-height)
  (depth gl-texture-depth)
  (mip-levels gl-texture-mip-levels)
  (samples gl-texture-samples)
  (format gl-texture-format)
  (destroyed? gl-texture-destroyed? set-gl-texture-destroyed!))

(define-record-type <gl-texture-view>
  (%make-gl-texture-view id target parent)
  gl-texture-view?
  (id gl-texture-view-id)
  (target gl-texture-view-target)
  (parent gl-texture-view-parent)
  (destroyed? gl-texture-view-destroyed? set-gl-texture-view-destroyed!))

(define-record-type <gl-sampler>
  (%make-gl-sampler id)
  gl-sampler?
  (id gl-sampler-id)
  (destroyed? gl-sampler-destroyed? set-gl-sampler-destroyed!))

;; When sampler objects are not available.
(define-record-type <gl-sampler-fallback>
  (make-gl-sampler-fallback wrap-s wrap-t wrap-r mag-filter min-filter)
  gl-sampler-fallback?
  (wrap-s gl-sampler-fallback-wrap-s)
  (wrap-t gl-sampler-fallback-wrap-t)
  (wrap-r gl-sampler-fallback-wrap-r)
  (mag-filter gl-sampler-fallback-mag-filter)
  (min-filter gl-sampler-fallback-min-filter))

(define-record-type <gl-shader>
  (%make-gl-shader id)
  gl-shader?
  (id gl-shader-id)
  (destroyed? gl-shader-destroyed? set-gl-shader-destroyed!))

(define-record-type <gl-framebuffer>
  (%make-gl-framebuffer id color-views depth+stencil-view destroyed?)
  gl-framebuffer?
  (id gl-framebuffer-id)
  (color-views gl-framebuffer-color-views)
  (depth+stencil-view gl-framebuffer-depth+stencil-view)
  (destroyed? gl-framebuffer-destroyed? set-gl-framebuffer-destroyed!))

(define-record-type <gl-vertex-attribute>
  (make-gl-vertex-attribute index size type normalized? stride pointer divisor)
  gl-vertex-attribute?
  (index gl-vertex-attribute-index)
  (size gl-vertex-attribute-size)
  (type gl-vertex-attribute-type)
  (normalized? gl-vertex-attribute-normalized?)
  (stride gl-vertex-attribute-stride)
  (pointer gl-vertex-attribute-pointer)
  (divisor gl-vertex-attribute-divisor))

(define-record-type <gl-blend-op>
  (make-gl-blend-op rgb alpha)
  gl-blend-op?
  (rgb gl-blend-op-rgb)
  (alpha gl-blend-op-alpha))

(define-record-type <gl-blend-func>
  (make-gl-blend-func src-rgb src-alpha dst-rgb dst-alpha)
  gl-blend-func?
  (src-rgb gl-blend-func-src-rgb)
  (src-alpha gl-blend-func-src-alpha)
  (dst-rgb gl-blend-func-dst-rgb)
  (dst-alpha gl-blend-func-dst-alpha))

(define-record-type <gl-blend-mode>
  (make-gl-blend-mode op func)
  gl-blend-mode?
  (op gl-blend-mode-op)
  (func gl-blend-mode-func))

(define-record-type <gl-depth-test>
  (make-gl-depth-test func mask)
  gl-depth-test?
  (func gl-depth-test-func)
  (mask gl-depth-test-mask))

(define-record-type <gl-stencil-op>
  (make-gl-stencil-op on-fail on-depth-fail on-pass)
  gl-stencil-op?
  (on-fail gl-stencil-op-on-fail)
  (on-depth-fail gl-stencil-op-on-depth-fail)
  (on-pass gl-stencil-op-on-pass))

(define-record-type <gl-stencil-test>
  (make-gl-stencil-test read-mask write-mask func-front func-back op-front op-back)
  gl-stencil-test?
  (read-mask gl-stencil-test-read-mask)
  (write-mask gl-stencil-test-write-mask)
  (func-front gl-stencil-test-func-front)
  (func-back gl-stencil-test-func-back)
  (op-front gl-stencil-test-op-front)
  (op-back gl-stencil-test-op-back))

(define-record-type <gl-render-pipeline>
  (%make-gl-render-pipeline shader begin-mode polygon-mode cull-face-mode
                            front-face color-format blend-mode color-mask
                            depth-test stencil-test vertex-attributes
                            binding-layout)
  gl-render-pipeline?
  (shader gl-render-pipeline-shader)
  (begin-mode gl-render-pipeline-begin-mode)
  (polygon-mode gl-render-pipeline-polygon-mode)
  (cull-face-mode gl-render-pipeline-cull-face-mode)
  (front-face gl-render-pipeline-front-face)
  (color-format gl-render-pipeline-color-format)
  (blend-mode gl-render-pipeline-blend-mode)
  (color-mask gl-render-pipeline-color-mask)
  (depth-test gl-render-pipeline-depth-test)
  (stencil-test gl-render-pipeline-stencil-test)
  (vertex-attributes gl-render-pipeline-vertex-attributes)
  (binding-layout gl-render-pipeline-binding-layout))

;; Cache driver state locally so we only talk to the GPU when
;; necessary.  This allows us to efficiently implement "stateless"
;; draw calls on top of the stateful GL context without a ton of round
;; trips to the driver/GPU to set redundant state.
(define-record-type <gl-state>
  (%make-gl-state gl-context
                  swap
                  guardian
                  gl-version
                  glsl-version
                  vendor
                  renderer
                  limits
                  texture-views-supported?
                  samplers-supported?
                  uniform-buffers-supported?
                  blending?
                  face-culling?
                  depth-test?
                  stencil-test?
                  scissor-test?
                  viewport
                  scissor-rect
                  polygon-mode
                  cull-face
                  front-face
                  blend-op
                  blend-func
                  color-mask
                  depth-func
                  depth-write?
                  depth-range
                  stencil-write-mask
                  stencil-func-front
                  stencil-func-back
                  stencil-op-front
                  stencil-op-back
                  clear-color
                  clear-depth
                  clear-stencil
                  buffer-index
                  buffer-vertex
                  buffer-copy-read
                  buffer-copy-write
                  buffer-uniforms
                  textures
                  samplers
                  shader
                  framebuffer
                  mode
                  framebuffer-cache)
  gl-state?
  (gl-context gl-state-gl-context)
  (swap gl-state-swap)
  ;; GC guardian for finalizing GPU objects.
  (guardian gl-state-guardian)
  ;; Metadata
  (gl-version gl-state-gl-version)
  (glsl-version gl-state-glsl-version)
  (vendor gl-state-vendor)
  (renderer gl-state-renderer)
  (limits gl-state-limits)
  ;; Feature flags
  (texture-views-supported? gl-state-texture-views-supported?)
  (samplers-supported? gl-state-samplers-supported?)
  (uniform-buffers-supported? gl-state-uniform-buffers-supported?)
  ;; Capability flags
  (blending? gl-state-blending? %set-gl-state-blending!)
  (face-culling? gl-state-face-culling? %set-gl-state-face-culling!)
  (depth-test? gl-state-depth-test? %set-gl-state-depth-test!)
  (stencil-test? gl-state-stencil-test? %set-gl-state-stencil-test!)
  (scissor-test? gl-state-scissor-test? %set-gl-state-scissor-test!)
  ;; Driver state
  (viewport gl-state-viewport %set-gl-state-viewport!)
  (scissor-rect gl-state-scissor-rect %set-gl-state-scissor-rect!)
  (polygon-mode gl-state-polygon-mode %set-gl-state-polygon-mode!)
  (cull-face gl-state-cull-face %set-gl-state-cull-face!)
  (front-face gl-state-front-face %set-gl-state-front-face!)
  (blend-op gl-state-blend-op %set-gl-state-blend-op!)
  (blend-func gl-state-blend-func %set-gl-state-blend-func!)
  (blend-constant gl-state-blend-constant %set-gl-state-blend-constant!)
  (color-mask gl-state-color-mask %set-gl-state-color-mask!)
  (depth-func gl-state-depth-func %set-gl-state-depth-func!)
  (depth-write? gl-state-depth-write? %set-gl-state-depth-write!)
  (depth-range gl-state-depth-range)
  (stencil-write-mask gl-state-stencil-write-mask %set-gl-state-stencil-write-mask!)
  (stencil-func-front gl-state-stencil-func-front)
  (stencil-func-back gl-state-stencil-func-back)
  (stencil-op-front gl-state-stencil-op-front %set-gl-state-stencil-op-front!)
  (stencil-op-back gl-state-stencil-op-back %set-gl-state-stencil-op-back!)
  (clear-color gl-state-clear-color %set-gl-state-clear-color!)
  (clear-depth gl-state-clear-depth %set-gl-state-clear-depth!)
  (clear-stencil gl-state-clear-stencil %set-gl-state-clear-stencil!)
  (buffer-index gl-state-buffer-index %set-gl-state-buffer-index!)
  (buffer-vertex gl-state-buffer-vertex %set-gl-state-buffer-vertex!)
  (buffer-copy-read gl-state-buffer-copy-read %set-gl-state-buffer-copy-read!)
  (buffer-copy-write gl-state-buffer-copy-write %set-gl-state-buffer-copy-write!)
  (buffer-uniforms gl-state-buffer-uniforms) ; vector
  (textures gl-state-textures)               ; vector
  (samplers gl-state-samplers)               ; vector
  (shader gl-state-shader %set-gl-state-shader!)
  (framebuffer gl-state-framebuffer %set-gl-state-framebuffer!)
  ;; Command state
  (mode gl-state-mode set-gl-state-mode!) ; default, render-pass, etc.
  ;; Render pass state
  (framebuffer-cache gl-state-framebuffer-cache)
  ;; State for drawing to default framebuffer
  (screen-indices gl-state-screen-indices set-gl-state-screen-indices!)
  (screen-vertices gl-state-screen-vertices set-gl-state-screen-vertices!)
  (screen-shader gl-state-screen-shader set-gl-state-screen-shader!))

(define (print-gl-state state port)
  (match state
    (($ <gl-state> context _ _ gl-version glsl-version vendor renderer)
     (format port "#<gl-state context: ~a gl-version: ~a glsl-version: ~a vendor: ~a renderer: ~a>"
             context gl-version glsl-version vendor renderer))))

(set-record-type-printer! <gl-state> print-gl-state)


;;;
;;; Screen state
;;;

(define (set-gl-state-viewport! state viewport)
  (match viewport
    (($ <viewport> new-x new-y new-width new-height)
     (match (gl-state-viewport state)
       (($ <viewport> old-x old-y old-width old-height)
        (unless (and (= old-x new-x)
                     (= old-y new-y)
                     (= old-width new-width)
                     (= old-height new-height))
          (gl-viewport new-x new-y new-width new-height)
          (%set-gl-state-viewport! state viewport)))))))

(define (set-gl-state-scissor-test! state scissor-test?)
  (unless (eq? (gl-state-scissor-test? state) scissor-test?)
    (if scissor-test?
        (gl-enable (enable-cap scissor-test))
        (gl-disable (enable-cap scissor-test)))
    (%set-gl-state-scissor-test! state scissor-test?)))

(define (set-gl-state-scissor-rect! state rect)
  (unless (equal? (gl-state-scissor-rect state) rect)
    (match rect
      (($ <scissor-rect> x y w h)
       (gl-scissor x y w h)))
    (%set-gl-state-scissor-rect! state rect)))


;;;
;;; Primitive state
;;;

(define (set-gl-state-face-culling! state cull?)
  (unless (eq? (gl-state-face-culling? state) cull?)
    (if cull?
        (gl-enable (enable-cap cull-face))
        (gl-disable (enable-cap cull-face)))
    (%set-gl-state-face-culling! state cull?)))

(define (set-gl-state-polygon-mode! state mode)
  (unless (eqv? (gl-state-polygon-mode state) mode)
    (gl-polygon-mode (cull-face-mode front-and-back) mode)
    (%set-gl-state-polygon-mode! state mode)))

(define (set-gl-state-cull-face! state face)
  (unless (eqv? (gl-state-cull-face state) face)
    (gl-cull-face face)
    (%set-gl-state-cull-face! state face)))

(define (set-gl-state-front-face! state face)
  (unless (eq? (gl-state-front-face state) face)
    (gl-front-face face)
    (%set-gl-state-front-face! state face)))


;;;
;;; Color/blend state
;;;

(define (set-gl-state-blending! state blend?)
  (unless (eq? (gl-state-blending? state) blend?)
    (if blend?
        (gl-enable (enable-cap blend))
        (gl-disable (enable-cap blend)))
    (%set-gl-state-blending! state blend?)))

(define %default-color-mask (make-color-mask #t #t #t #t))

(define (set-gl-state-color-mask! state color-mask)
  (unless (equal? (gl-state-color-mask state) color-mask)
    (match color-mask
      (($ <color-mask> red? green? blue? alpha?)
       (gl-color-mask red? green? blue? alpha?)
       (%set-gl-state-color-mask! state color-mask)))))

(define (set-gl-state-blend-op! state op)
  (unless (equal? (gl-state-blend-op state) op)
    (match op
      (($ <gl-blend-op> rgb alpha)
       (gl-blend-equation-separate rgb alpha)
       (%set-gl-state-blend-op! state op)))))

(define (set-gl-state-blend-func! state func)
  (unless (equal? (gl-state-blend-func state) func)
    (match func
      (($ <gl-blend-func> src-rgb src-alpha dst-rgb dst-alpha)
       (gl-blend-func-separate src-rgb dst-rgb src-alpha dst-alpha)
       (%set-gl-state-blend-func! state func)))))

(define (set-gl-state-blend-constant! state color)
  (unless (equal? (gl-state-blend-constant state) color)
    (gl-blend-color (color-r color) (color-g color) (color-b color) (color-a color))
    (%set-gl-state-blend-constant! state color)))

(define (set-gl-state-clear-color! state color)
  (unless (equal? (gl-state-clear-color state) color)
    (gl-clear-color (color-r color) (color-g color) (color-b color) (color-a color))
    (%set-gl-state-clear-color! state color)))


;;;
;;; Depth test
;;;

(define (set-gl-state-depth-test! state depth-test?)
  (unless (eq? (gl-state-depth-test? state) depth-test?)
    (if depth-test?
        (gl-enable (enable-cap depth-test))
        (gl-disable (enable-cap depth-test)))
    (%set-gl-state-depth-test! state depth-test?)))

(define (set-gl-state-depth-func! state func)
  (unless (equal? (gl-state-depth-func state) func)
    (gl-depth-func func)
    (%set-gl-state-depth-func! state func)))

(define (set-gl-state-depth-write! state write?)
  (unless (eq? (gl-state-depth-write? state) write?)
    (gl-depth-mask write?)
    (%set-gl-state-depth-write! state write?)))

(define (set-gl-state-depth-range! state near far)
  (let ((range (gl-state-depth-range state)))
    (unless (and (= (f64vector-ref range 0) near)
                 (= (f64vector-ref range 1) far))
      (gl-depth-range near far)
      (f64vector-set! range 0 near)
      (f64vector-set! range 1 far))))

(define (set-gl-state-clear-depth! state depth)
  (unless (eqv? (gl-state-clear-depth state) depth)
    (gl-clear-depth depth)
    (%set-gl-state-clear-depth! state depth)))


;;;
;;; Stencil test
;;;

(define (set-gl-state-stencil-test! state stencil-test?)
  (unless (eq? (gl-state-stencil-test? state) stencil-test?)
    (if stencil-test?
        (gl-enable (enable-cap stencil-test))
        (gl-disable (enable-cap stencil-test)))
    (%set-gl-state-stencil-test! state stencil-test?)))

(define (set-gl-state-stencil-write-mask! state mask)
  (unless (eqv? (gl-state-stencil-write-mask state) mask)
    (gl-stencil-mask mask)
    (%set-gl-state-stencil-write-mask! state mask)))

(define (set-gl-state-stencil-func-front! state func ref mask)
  (match (gl-state-stencil-func-front state)
    ((and v #(old-func old-ref old-mask))
     (unless (and (eqv? func old-func)
                  (eqv? ref old-ref)
                  (eqv? mask old-mask))
       (gl-stencil-func func ref mask)
       (vector-set! v 0 func)
       (vector-set! v 1 ref)
       (vector-set! v 2 mask)))))

(define (set-gl-state-stencil-func-back! state func ref mask)
  (match (gl-state-stencil-func-back state)
    ((and v #(old-func old-ref old-mask))
     (unless (and (eqv? func old-func)
                  (eqv? ref old-ref)
                  (eqv? mask old-mask))
       (gl-stencil-func func ref mask)
       (vector-set! v 0 func)
       (vector-set! v 1 ref)
       (vector-set! v 2 mask)))))

(define (set-gl-state-stencil-op-front! state op)
  (unless (equal? (gl-state-stencil-op-front state) op)
    (match op
      (($ <gl-stencil-op> on-fail on-depth-fail on-pass)
       (gl-stencil-op-separate (cull-face-mode front) on-fail on-depth-fail on-pass)))
    (%set-gl-state-stencil-op-front! state op)))

(define (set-gl-state-stencil-op-back! state op)
  (unless (equal? (gl-state-stencil-op-back state) op)
    (match op
      (($ <gl-stencil-op> on-fail on-depth-fail on-pass)
       (gl-stencil-op-separate (cull-face-mode back) on-fail on-depth-fail on-pass)))
    (%set-gl-state-stencil-op-back! state op)))

(define (set-gl-state-clear-stencil! state s)
  (unless (eqv? (gl-state-clear-stencil state) s)
    (gl-clear-stencil s)
    (%set-gl-state-clear-stencil! state s)))


;;;
;;; Multisampling
;;;

;; TODO


;;;
;;; Buffers
;;;

;; TODO: Think about compatibility issues.
;;
;; The copy-src and uniform usages are available only if the GL
;; version is 3.1 or greater.  The indirect and storage usages targets
;; are available only if the GL version is 4.3 or greater.  The
;; query-resolve target is available only if the GL version is 4.4 or
;; greater.
;;
;; Some of these things just can't be emulated on GL 2 or 3, but we
;; need a solution for uniforms on GL 2 because the frontend
;; rightfully requires the use of uniform buffers.  A possible
;; solution is to keep a CPU-side buffer and when the buffer is bound
;; in a draw call, make the appropriate glUniform calls instead.  It's
;; slow, but that's what you've gotta deal with on old GL.  This
;; requires introspecting the shader to get uniform locations.

(define (set-gl-state-buffer-vertex! state buffer)
  (unless (eq? (gl-state-buffer-vertex state) buffer)
    (gl-bind-buffer (version-1-5 array-buffer) (gl-buffer-id buffer))
    (%set-gl-state-buffer-vertex! state buffer)))

(define (set-gl-state-buffer-index! state buffer)
  (unless (eq? (gl-state-buffer-index state) buffer)
    (gl-bind-buffer (version-1-5 element-array-buffer) (gl-buffer-id buffer))
    (%set-gl-state-buffer-index! state buffer)))

(define (set-gl-state-buffer-copy-read! state buffer)
  (unless (eq? (gl-state-buffer-copy-read state) buffer)
    (gl-bind-buffer (version-3-1 copy-read-buffer) (gl-buffer-id buffer))
    (%set-gl-state-buffer-copy-read! state buffer)))

(define (set-gl-state-buffer-copy-write! state buffer)
  (unless (eq? (gl-state-buffer-copy-write state) buffer)
    (gl-bind-buffer (version-3-1 copy-write-buffer) (gl-buffer-id buffer))
    (%set-gl-state-buffer-copy-write! state buffer)))

(define (set-gl-state-buffer-uniform! state i buffer)
  (let ((ubos (gl-state-buffer-uniforms state)))
    (unless (eq? (vector-ref ubos i) buffer)
      (gl-bind-buffer-base (version-3-1 uniform-buffer) i (gl-buffer-id buffer))
      (vector-set! ubos i buffer))))

(define null-gl-buffer (%make-gl-buffer 0 #f))

;; TODO: Respect usage flags.
(define (make-gl-buffer state length usage)
  (let ((buffer (%make-gl-buffer (gl-generate-buffer) (make-hash-table))))
    (gl-state-guard state buffer)
    ;; Allocate buffer memory.
    (set-gl-state-buffer-vertex! state buffer)
    (gl-buffer-data (version-1-5 array-buffer)
                    length %null-pointer
                    ;; TODO: Set hints based on usage flags.
                    (version-1-5 static-draw))
    buffer))

(define (destroy-gl-buffer state buffer)
  (unless (gl-buffer-destroyed? buffer)
    (gl-delete-buffer (gl-buffer-id buffer))
    (set-gl-buffer-destroyed! buffer #t)))

(define (map-gl-buffer state buffer mode offset length)
  ;; Mapping a buffer repeatedly tends to return the same pointers over
  ;; and over, even when the buffer re-specification trick is used.  By
  ;; caching bytevectors for those memory regions we avoid bytevector
  ;; allocation after some frames of warmup, reducing GC pressure.
  (define (pointer->bytevector* pointer length offset)
    (let ((cache (gl-buffer-map-cache buffer))
          (address (pointer-address pointer)))
      (or (let ((cached (hashv-ref cache address)))
            (and cached
                 (= length (bytevector-length cached))
                 cached))
          (let ((bv (pointer->bytevector pointer length)))
            (hashv-set! cache address bv)
            bv))))
  (let ((target (version-1-5 array-buffer))
        (access (match mode
                  ('read (version-1-5 read-only))
                  ('write (version-1-5 write-only)))))
    (set-gl-state-buffer-vertex! state buffer)
    ;; For write-only buffers, we abandon the original buffer storage
    ;; to avoid the performance hit of implicit synchronization.
    ;;
    ;; This is not the right thing to do generally but it's what *I*
    ;; want to happen when I am filling sprite batches so...
    ;;
    ;; See:
    ;; https://www.opengl.org/wiki/Buffer_Object_Streaming#Buffer_re-specification
    (when (eq? mode 'write)
      ;; Assuming for now that mapping for write means streaming.
      (gl-buffer-data target length %null-pointer (version-1-5 stream-draw)))
    ;; HACK: flush error since I'm not checking for errors everywhere.
    (gl-get-error)
    (let ((ptr (gl-map-buffer target access)))
      (unless (eq? (gl-get-error) 0)
        (error "failed to map buffer" buffer))
      (pointer->bytevector* ptr length offset))))

(define (unmap-gl-buffer state buffer)
  (set-gl-state-buffer-vertex! state buffer)
  ;; HACK: flush error since I'm not checking for errors everywhere.
  (gl-get-error)
  (gl-unmap-buffer (version-1-5 array-buffer))
  (unless (eq? (gl-get-error) 0)
    (error "failed to unmap buffer" buffer)))

(define (write-gl-buffer state buffer buffer-offset data data-offset length)
  (set-gl-state-buffer-vertex! state buffer)
  (gl-buffer-sub-data (version-1-5 array-buffer)
                      buffer-offset length
                      (bytevector->pointer data data-offset)))


;;;
;;; Textures and views
;;;

(define (gl-state-texture-ref state i)
  (vector-ref (gl-state-textures state) i))

(define (set-gl-state-texture! state i texture)
  (gl-active-texture (+ (version-1-3 texture0) i))
  (let ((textures (gl-state-textures state)))
    (unless (eq? (vector-ref textures i) texture)
      (match texture
        (($ <gl-texture> id target)
         (gl-bind-texture target id))
        (($ <gl-texture-view> id target)
         (gl-bind-texture target id)
         ;; If we're using fallback samplers, we need to modify the
         ;; texture parameters of the newly bound texture.
         (unless (gl-state-samplers-supported? state)
           (match (gl-state-sampler-ref state i)
             ((? gl-sampler-fallback? sampler)
              (apply-sampler-fallback i sampler texture))
             (_ #t)))))
      (vector-set! textures i texture))))

(define null-gl-texture (%make-gl-texture 0 #f 0 0 0 0 0 #f))

;; TODO: multisampling
;; TODO: layers for 2D textures (should use 3d storage)
(define (make-gl-texture state width height depth mip-levels samples
                         dimension format)
  (let* ((id (gl-generate-texture))
         (target (match dimension
                   ('1d (texture-target texture-1d))
                   ('2d (texture-target texture-2d))
                   ('3d (texture-target texture-3d-ext))))
         (format (match format
                   ('rgba8 (pixel-internal-format rgba8))))
         (texture (%make-gl-texture id target width height depth mip-levels
                                    samples format)))
    (gl-state-guard state texture)
    (set-gl-state-texture! state 0 texture)
    (gl-tex-parameter target (version-1-2 texture-max-level) mip-levels)
    (let ((levels (+ mip-levels 1)))
      (if (gl-state-texture-views-supported? state)
          ;; Setup immutable storage parameters.
          (match dimension
            ('1d (gl-tex-storage-1d target levels format width))
            ('2d (gl-tex-storage-2d target levels format width height))
            ('3d (gl-tex-storage-3d target levels format width height depth)))
          ;; Manually setup all layers and mip levels.
          ;;
          ;; Dummy format/type.  Doesn't matter because we aren't
          ;; sending over any pixel data.
          (let ((fmt (pixel-format rgba))
                (type (color-pointer-type unsigned-byte)))
            (match dimension
              ('1d
               (let loop ((i 0) (width width))
                 (when (< i levels)
                   (gl-tex-image-1d target i format width 0 fmt type
                                    %null-pointer)
                   (loop (+ i 1) (quotient width 2)))))
              ('2d
               (let loop ((i 0) (width width) (height height))
                 (when (< i levels)
                   (gl-tex-image-2d target i format width height 0 fmt type
                                    %null-pointer)
                   (loop (+ i 1) (quotient width 2) (quotient height 2)))))
              ('3d
               (let loop ((i 0) (width width) (height height) (depth depth))
                 (when (< i levels)
                   (gl-tex-image-3d target i format width height depth 0 fmt
                                    type %null-pointer)
                   (loop (+ i 1) (quotient width 2) (quotient height 2)
                         (quotient depth 3)))))))))
    texture))

(define (destroy-gl-texture state texture)
  (unless (gl-texture-destroyed? texture)
    (gl-delete-texture (gl-texture-id texture))
    (set-gl-texture-destroyed! texture #t)))

;; TODO: When texture views aren't supported, update all emulated
;; (copied) faux view textures after write completes.
(define (write-gl-texture state texture x y z width height depth mip-level
                          format data offset)
  (let ((ptr (bytevector->pointer data offset)))
    ;; TODO: Support additional formats.
    (let ((format (match format
                    ('rgba8 (pixel-format rgba))))
          (type (match format
                  ('rgba8 (color-pointer-type unsigned-byte)))))
      (match texture
        (($ <gl-texture> id target)
         (set-gl-state-texture! state 0 texture)
         (cond
          ((eqv? target (texture-target texture-1d))
           (gl-tex-sub-image-1d target mip-level x width format type ptr))
          ((eqv? target (texture-target texture-2d))
           (gl-tex-sub-image-2d target mip-level x y width height format
                                type ptr))
          ((eqv? target (texture-target texture-3d-ext))
           (gl-tex-sub-image-3d target mip-level x y z width height depth
                                format type ptr))))))))

(define null-gl-texture-view
  (%make-gl-texture-view 0 (texture-target texture-1d) 0))

;; Texture views are only supported in OpenGL >= 4.3 so older versions
;; have to fall back to copying data into a new texture.
(define (make-gl-texture-view state texture format dimension aspect base-mip-level
                              mip-levels base-layer layers)
  (let ((target (match dimension
                  ('1d (texture-target texture-1d))
                  ('2d (texture-target texture-2d))
                  ('2d-array (version-3-0 texture-2d-array))
                  ('cube (version-1-3 texture-cube-map))
                  ('cube-array (arb-texture-cube-map-array texture-cube-map-array))
                  ('3d (texture-target texture-3d-ext))))
        (format (match format
                  ('rgba8 (pixel-internal-format rgba8)))))
    (match texture
      (($ <gl-texture> pid ptarget pwidth pheight pdepth pmip-levels psamples pformat)
       ;; Is the view using the same settings as the parent texture?
       ;; If so, there's no need to make an alias.
       (if (and (= target ptarget)
                (= format pformat)
                (= base-mip-level 0)
                (= mip-levels pmip-levels)
                (= base-layer 0)
                (= layers pdepth)
                (eq? aspect 'all))
           ;; Re-use the parent texture id.  No need to guard it from
           ;; GC since no new texture was allocated.
           (%make-gl-texture-view pid target texture)
           ;; Create a new texture view.
           (let* ((levels (+ mip-levels 1))
                  (id (gl-generate-texture))
                  (view (%make-gl-texture-view id target texture)))
             (gl-state-guard state view)
             (if (gl-state-texture-views-supported? state)
                 ;; Ah, so simple.
                 (gl-texture-view id target pid format base-mip-level
                                  levels base-layer layers)
                 ;; Emulate texture view with a slow copy.  Gross.
                 (let* ((copy-format (pixel-format rgba))
                        (copy-type (color-pointer-type unsigned-byte))
                        (bv (make-bytevector (* pwidth pheight pdepth 4)))
                        (ptr (bytevector->pointer bv)))
                   (set-gl-state-texture! state 1 view)
                   (gl-tex-parameter target (version-1-2 texture-max-level)
                                     mip-levels)
                   ;; For each mip level, copy the pixels from the
                   ;; parent texture to the CPU then back over into
                   ;; the view texture.
                   (match dimension
                     ('1d
                      (let loop ((i 0) (w pwidth))
                        (when (< i levels)
                          (set-gl-state-texture! state 0 texture)
                          (gl-get-tex-image ptarget i copy-format copy-type ptr)
                          (set-gl-state-texture! state 0 view)
                          (gl-tex-image-1d target i format w 0
                                           copy-format copy-type ptr)
                          (loop (+ i 1) (quotient w 2)))))
                     ('2d
                      (let loop ((i 0) (w pwidth) (h pheight))
                        (when (< i levels)
                          (set-gl-state-texture! state 0 texture)
                          (gl-get-tex-image ptarget i copy-format copy-type ptr)
                          (set-gl-state-texture! state 0 view)
                          (gl-tex-image-2d target i format w h 0
                                           copy-format copy-type ptr)
                          (loop (+ i 1) (quotient w 2) (quotient h 2)))))
                     ((or '2d-array '3d)
                      (let loop ((i 0) (w pwidth) (h pheight) (d pdepth))
                        (when (< i levels)
                          (set-gl-state-texture! state 0 texture)
                          (gl-get-tex-image ptarget i copy-format copy-type ptr)
                          (set-gl-state-texture! state 0 view)
                          (gl-tex-image-3d target i format w h d 0
                                           copy-format copy-type ptr)
                          (loop (+ i 1) (quotient w 2) (quotient h 2)
                                (quotient d 2)))))
                     ('cube
                      (let loop ((i 0) (w pwidth) (h pheight))
                        (when (< i levels)
                          (set-gl-state-texture! state 0 texture)
                          (gl-get-tex-image ptarget i copy-format copy-type ptr)
                          (set-gl-state-texture! state 0 view)
                          ;; Annoyingly, we have to do a separate upload
                          ;; for each cube map face
                          (gl-tex-image-2d (version-1-3 texture-cube-map-positive-x)
                                           i format w h 0 copy-format copy-type ptr)
                          (gl-tex-image-2d (version-1-3 texture-cube-map-negative-x)
                                           i format w h 0 copy-format copy-type
                                           (bytevector->pointer bv (* w h)))
                          (gl-tex-image-2d (version-1-3 texture-cube-map-positive-y)
                                           i format w h 0 copy-format copy-type
                                           (bytevector->pointer bv (* w h 2)))
                          (gl-tex-image-2d (version-1-3 texture-cube-map-negative-y)
                                           i format w h 0 copy-format copy-type
                                           (bytevector->pointer bv (* w h 3)))
                          (gl-tex-image-2d (version-1-3 texture-cube-map-positive-z)
                                           i format w h 0 copy-format copy-type
                                           (bytevector->pointer bv (* w h 4)))
                          (gl-tex-image-2d (version-1-3 texture-cube-map-negative-z)
                                           i format w h 0 copy-format copy-type
                                           (bytevector->pointer bv (* w h 5)))
                          (loop (+ i 1) (quotient w 2) (quotient h 2)))))
                     ('cube-array (error "cube map array unsupported")))))
             view))))))

(define (destroy-gl-texture-view state view)
  (unless (gl-texture-view-destroyed? view)
    (gl-delete-texture (gl-texture-view-id view))
    (set-gl-texture-view-destroyed! view #t)))


;;;
;;; Samplers
;;;

;; Samplers are supported in OpenGL >= 3.3 so older versions have to
;; fall back to manipulating the texture parameters each time the
;; sampler is bound.  This simple approach has the limitation that
;; it's not possible to sample the same texture in two different ways
;; in the same shader.  I don't currently do this anywhere, so it's a
;; limitation I can live with right now.

(define (gl-state-sampler-ref state i)
  (vector-ref (gl-state-samplers state) i))

(define (apply-sampler-fallback i sampler texture)
  (match sampler
    (($ <gl-sampler-fallback> wrap-s wrap-t wrap-r mag-filter min-filter)
     (match texture
       (($ <gl-texture-view> id target)
        (gl-active-texture i)
        (gl-tex-parameter target
                          (texture-parameter-name texture-wrap-s)
                          wrap-s)
        (gl-tex-parameter target
                          (texture-parameter-name texture-wrap-t)
                          wrap-t)
        (gl-tex-parameter target
                          (texture-parameter-name texture-wrap-t)
                          wrap-t)
        (gl-tex-parameter target
                          (texture-parameter-name texture-mag-filter)
                          mag-filter)
        (gl-tex-parameter target
                          (texture-parameter-name texture-min-filter)
                          min-filter))
       ;; Do nothing if a view isn't bound.
       (_ #f)))))

(define (set-gl-state-sampler! state i sampler)
  (let ((samplers (gl-state-samplers state)))
    (unless (eq? (vector-ref samplers i) sampler)
      (match sampler
        (($ <gl-sampler> id)
         (gl-bind-sampler i id))
        ((? gl-sampler-fallback?)
         (apply-sampler-fallback i sampler (gl-state-texture-ref state i))))
      (vector-set! samplers i sampler))))

(define null-gl-sampler (%make-gl-sampler 0))

(define (make-gl-sampler state address-mode-u address-mode-v address-mode-w
                         mag-filter min-filter mipmap-filter)
  (define (gl-wrap-mode mode)
    (match mode
      ('clamp-to-edge (texture-wrap-mode clamp-to-edge-sgis))
      ('repeat (texture-wrap-mode repeat))
      ('mirror-repeat (version-1-4 mirrored-repeat))))
  (let ((wrap-s (gl-wrap-mode address-mode-u))
        (wrap-t (gl-wrap-mode address-mode-v))
        (wrap-r (gl-wrap-mode address-mode-w))
        (mag-filter (match mag-filter
                      ('nearest (texture-min-filter nearest))
                      ('linear (texture-min-filter linear))))
        (min-filter (match min-filter
                      ('nearest
                       (match mipmap-filter
                         ('nearest (texture-min-filter nearest-mipmap-nearest))
                         ('linear (texture-min-filter nearest-mipmap-linear))))
                      ('linear
                       (match mipmap-filter
                         ('nearest (texture-min-filter linear-mipmap-nearest))
                         ('linear (texture-min-filter linear-mipmap-linear)))))))
    (if (gl-state-samplers-supported? state)
        (let* ((id (gl-generate-sampler))
               (sampler (gl-state-guard state (%make-gl-sampler id))))
          (gl-sampler-parameter id (texture-parameter-name texture-wrap-s) wrap-s)
          (gl-sampler-parameter id (texture-parameter-name texture-wrap-t) wrap-t)
          (gl-sampler-parameter id (texture-parameter-name texture-wrap-r-ext) wrap-r)
          (gl-sampler-parameter id (texture-parameter-name texture-min-filter)
                                min-filter)
          (gl-sampler-parameter id (texture-parameter-name texture-mag-filter)
                                mag-filter)
          sampler)
        (make-gl-sampler-fallback wrap-s wrap-t wrap-r mag-filter min-filter))))

(define (destroy-gl-sampler state sampler)
  (unless (gl-sampler-destroyed? sampler)
    (gl-delete-sampler (gl-sampler-id sampler))
    (set-gl-sampler-destroyed! sampler #t)))


;;;
;;; Shaders
;;;

(define (set-gl-state-shader! state shader)
  (unless (eq? (gl-state-shader state) shader)
    (gl-use-program (gl-shader-id shader))
    (%set-gl-state-shader! state shader)))

(define null-gl-shader (%make-gl-shader 0))

(define (make-gl-shader state source)
  (define-values (vertex-source fragment-source) (source 'glsl))
  (define header
    ;; Set up preprocessor directives dynamically based on the current
    ;; OpenGL context's GLSL version so that we can write shaders that
    ;; are compatible with as many systems as possible.
    (let ((version (gl-state-glsl-version state)))
      (cond
       ((string>= version "3.3")
        "#version 330
#define GLSL330
")
       ((string>= version "1.3")
        "#version 130
#define GLSL130
")
       ((string>= version "1.2")
        "#version 120
#define GLSL120
")
       (else
        (error "incompatible GLSL version" version)))))
  (define (info-log shader)
    (let ((log-length-bv (make-u32vector 1 0)))
      (gl-get-shaderiv shader (version-2-0 info-log-length)
                       (bytevector->pointer log-length-bv))
      ;; Add one byte to account for the null string terminator.
      (let* ((log-length (u32vector-ref log-length-bv 0))
             (log (make-u8vector (1+ log-length) 0)))
        (gl-get-shader-info-log shader log-length %null-pointer
                                (bytevector->pointer log))
        (utf8->string log))))
  (define (compiled? id)
    (let ((status (make-u32vector 1)))
      (gl-get-shaderiv id
                       (version-2-0 compile-status)
                       (bytevector->pointer status))
      (= (u32vector-ref status 0) 1)))
  (define (linked? id)
    (let ((status (make-u32vector 1 0)))
      (gl-get-programiv id (version-2-0 link-status)
                        (bytevector->pointer status))
      (= (u32vector-ref status 0) 1)))
  (define (compile-stage source type)
    (let ((id (gl-create-shader type))
          (bv (string->utf8 (string-append header source))))
      (gl-shader-source id 1
                        (bytevector->pointer
                         (u64vector
                          (pointer-address (bytevector->pointer bv))))
                        (bytevector->pointer
                         (u32vector (bytevector-length bv))))
      (gl-compile-shader id)
      (if (compiled? id)
          id
          (let ((msg (info-log id)))
            (gl-delete-shader id)
            (error (format #f "failed to compile shader: ~a" msg))))))
  (let ((vert (compile-stage vertex-source (version-2-0 vertex-shader)))
        (frag (compile-stage fragment-source (version-2-0 fragment-shader)))
        (id (gl-create-program)))
    (gl-attach-shader id vert)
    (gl-attach-shader id frag)
    (gl-link-program id)
    (gl-detach-shader id vert)
    (gl-detach-shader id frag)
    (gl-delete-shader vert)
    (gl-delete-shader frag)
    (unless (linked? id)
      (let ((msg (info-log id)))
        (gl-delete-program id)
        (error (format #f "failed to link shader: ~a" msg))))
    (gl-state-guard state (%make-gl-shader id))))

(define (destroy-gl-shader state shader)
  (unless (gl-shader-destroyed? shader)
    (gl-delete-program (gl-shader-id shader))
    (set-gl-shader-destroyed! shader #t)))


;;;
;;; Framebuffers
;;;

(define (set-gl-state-framebuffer! state fbo)
  (unless (eq? (gl-state-framebuffer state) fbo)
    (gl-bind-framebuffer (version-3-0 framebuffer)
                         (gl-framebuffer-id fbo))
    (%set-gl-state-framebuffer! state fbo)))

(define null-gl-framebuffer (%make-gl-framebuffer 0 #() #f #f))

(define (make-gl-framebuffer state)
  (let ((id (gl-generate-framebuffer))
        (colors (make-vector (gpu-limits-max-color-attachments
                              (gl-state-limits state))
                             #f)))
    (gl-state-guard state (%make-gl-framebuffer id colors #f #f))))

(define (destroy-gl-framebuffer fbo)
  (unless (gl-framebuffer-destroyed? fbo)
    (gl-delete-framebuffer (gl-framebuffer-id fbo))
    (set-gl-framebuffer-destroyed! fbo #t)))

(define (gl-state-framebuffer-ref state key)
  (hashq-ref (gl-state-framebuffer-cache state) key))

;; Find or create framebuffer and update attachments.
(define (gl-state-framebuffer-build state key colors depth+stencil)
  (let* ((fbo-cache (gl-state-framebuffer-cache state))
         (fbo (or (hashq-ref fbo-cache key)
                  (let ((new (make-gl-framebuffer state)))
                    (hashq-set! fbo-cache key new)
                    new))))
    (set-gl-state-framebuffer! state fbo)
    (do ((i 0 (+ i 1)))
        ((= i (vector-length colors)))
      (match (vector-ref colors i)
        (#(#f _ _)
         (gl-framebuffer-texture-2d (version-3-0 framebuffer)
                                    (+ (version-3-0 color-attachment0) i)
                                    (texture-target texture-2d) 0 0))
        (#(view resolve _)
         (gl-framebuffer-texture-2d (version-3-0 framebuffer)
                                    (+ (version-3-0 color-attachment0) i)
                                    (gl-texture-view-target view)
                                    (gl-texture-view-id view)
                                    0))))
    (match depth+stencil
      (#(#f _ _)
       (gl-framebuffer-texture-2d (version-3-0 framebuffer)
                                  (arb-framebuffer-object depth-stencil-attachment)
                                  (texture-target texture-2d) 0 0))
      (#(view _ _)
       (gl-framebuffer-texture-2d (version-3-0 framebuffer)
                                  (arb-framebuffer-object depth-stencil-attachment)
                                  (gl-texture-view-target depth+stencil)
                                  (gl-texture-view-id depth+stencil)
                                  0)))
    fbo))


;;;
;;; Render pipelines
;;;

(define (make-gl-render-pipeline state shader primitive color-target
                                 depth+stencil vertex-layout binding-layout)
  (define (format-component-count format)
    (match format
      ((or 'uint32 'float32) 1)
      ((or 'uint8x2 'sint8x2 'unorm8x2 'snorm8x2 'uint16x2 'sint16x2
           'unorm16x2 'snorm16x2 'float16x2 'float32x2 'uint32x2 'sint32
           'sint32x2)
       2)
      ((or 'float32x3 'uint32x3 'sint32x3) 3)
      ((or 'uint8x4 'sint8x4 'unorm8x4 'snorm8x4 'uint16x4 'sint16x4
           'unorm16x4 'snorm16x4 'float16x4 'float32x4 'uint32x4 'sint32x4)
       4)))
  (define (format-type format)
    (match format
      ((or 'uint8x2 'uint8x4)
       (data-type unsigned-byte))
      ((or 'uint16x2 'uint16x4)
       (data-type unsigned-short))
      ((or 'uint32 'uint32x2 'uint32x3 'uint32x4)
       (data-type unsigned-int))
      ((or 'sint8x2 'sint8x4)
       (data-type byte))
      ((or 'sint16x2 'sint16x4)
       (data-type short))
      ((or 'sint32 'sint32x2 'sint32x3 'sint32x4)
       (data-type int))
      ((or 'float16x2 'float16x4)
       (oes-vertex-half-float half-float-oes))
      ((or 'float32 'float32x2 'float32x3 'float32x4 'unorm8x2 'unorm8x4
           'snorm8x2 'snorm8x4 'unorm16x2 'unorm16x4 'snorm16x2 'snorm16x4)
       (data-type float))))
  (define (format-normalized? format)
    (match format
      ((or 'uint8x2 'uint8x4 'sint8x2 'sint8x4 'uint16x2 'uint16x4 'sint16x2
           'sint16x4 'float16x2 'float16x4 'float32 'float32x2 'float32x3
           'float32x4 'uint32 'uint32x2 'uint32x3 'uint32x4 'sint32 'sint32x2
           'sint32x3 'sint32x4)
       #f)
      ((or 'unorm8x2 'unorm8x4 'snorm8x2 'snorm8x4 'unorm16x2 'unorm16x4
           'snorm16x2 'snorm16x4)
       #t)))
  (define vertex-attributes
    (let* ((k (vector-length vertex-layout))
           (layout (make-vector k)))
      (let loop ((i 0) (attr-count 0))
        (when (< i k)
          (match (vector-ref vertex-layout i)
            (($ <vertex-buffer-layout> stride step-mode attributes)
             (let* ((k (vector-length attributes))
                    (attrs (make-vector k)))
               (do ((j 0 (+ j 1)))
                   ((= j k))
                 (match (vector-ref attributes j)
                   (($ <vertex-attribute> format offset)
                    (vector-set! attrs j
                                 (make-gl-vertex-attribute (+ attr-count j)
                                                           (format-component-count format)
                                                           (format-type format)
                                                           (format-normalized? format)
                                                           stride
                                                           (offset->pointer offset)
                                                           (and (eq? step-mode 'instance) 1))))))
               (vector-set! layout i attrs)
               (loop (+ i 1) (+ attr-count k)))))))
      layout))
  (define (blend-equation op)
    (match op
      ('add (blend-equation-mode-ext func-add-ext))
      ('subtract (blend-equation-mode-ext func-subtract-ext))
      ('reverse-subtract (blend-equation-mode-ext func-reverse-subtract-ext))
      ('min (blend-equation-mode-ext min-ext))
      ('max (blend-equation-mode-ext max-ext))))
  (define (blend-src-func func)
    (match func
      ('zero (blending-factor-src zero))
      ('one (blending-factor-src one))
      ('src-alpha (blending-factor-src src-alpha))
      ('one-minus-src-alpha (blending-factor-src one-minus-src-alpha))
      ('dst (blending-factor-src dst-color))
      ('one-minus-dst (blending-factor-src one-minus-dst-color))
      ('dst-alpha (blending-factor-src dst-alpha))
      ('one-minus-dst-alpha (blending-factor-src one-minus-dst-alpha))
      ('src-alpha-saturated (blending-factor-src src-alpha-saturate))
      ('constant (blending-factor-src constant-color-ext))
      ('one-minus-constant (blending-factor-src one-minus-constant-color-ext))))
  (define (blend-dst-func func)
    (match func
      ('zero (blending-factor-dest zero))
      ('one (blending-factor-dest one))
      ('src (blending-factor-dest src-alpha))
      ('one-minus-src (blending-factor-dest one-minus-src-color))
      ('src-alpha (blending-factor-dest src-alpha))
      ('one-minus-src-alpha (blending-factor-dest one-minus-src-alpha))
      ('dst-alpha (blending-factor-dest dst-alpha))
      ('one-minus-dst-alpha (blending-factor-dest one-minus-dst-alpha))
      ('constant (blending-factor-dest constant-color-ext))
      ('one-minus-constant (blending-factor-src one-minus-constant-color-ext))))
  (define (depth-func func)
    (match func
      ('never (depth-function never))
      ('less (depth-function less))
      ('equal (depth-function equal))
      ('less-equal (depth-function lequal))
      ('greater (depth-function greater))
      ('not-equal (depth-function notequal))
      ('greater-equal (depth-function gequal))
      ('always (depth-function always))))
  (define (stencil-op* op)
    (match op
      ('keep (stencil-op keep))
      ('zero (stencil-op zero))
      ('replace (stencil-op replace))
      ('invert (stencil-op invert))
      ('increment-clamp (stencil-op incr))
      ('decrement-clamp (stencil-op decr))
      ('increment-wrap (version-1-4 incr-wrap))
      ('decrement-wrap (version-1-4 decr-wrap))))
  (define (stencil-func func)
    (match func
      ('always (stencil-function always))
      ('never (stencil-function never))
      ('less-than (stencil-function less))
      ('equal (stencil-function equal))
      ('less-than-or-equal (stencil-function lequal))
      ('greater-than (stencil-function greater))
      ('greater-than-or-equal (stencil-function gequal))
      ('not-equal (stencil-function notequal))))
  (%make-gl-render-pipeline
   shader
   (match (primitive-mode-topology primitive)
     ('point-list (begin-mode points))
     ('line-list (begin-mode lines))
     ('line-strip (begin-mode line-strip))
     ('triangle-list (begin-mode triangles))
     ('triangle-strip (begin-mode triangle-strip)))
   (match (primitive-mode-topology primitive)
     ('point-list (polygon-mode point))
     ((or 'line-list 'line-strip) (polygon-mode line))
     ((or 'triangle-list 'triangle-strip) (polygon-mode fill)))
   (match (primitive-mode-front-face primitive)
     ('ccw (front-face-direction ccw))
     ('cw (front-face-direction cw)))
   (match (primitive-mode-cull-face primitive)
     (#f #f)
     ('front (cull-face-mode front))
     ('back (cull-face-mode back)))
   (color-target-format color-target)
   (match (color-target-blend-mode color-target)
     (#f #f)
     (($ <blend-mode>
         ($ <blend-component> op-rgb src-rgb dst-rgb)
         ($ <blend-component> op-alpha src-alpha dst-alpha))
      (make-gl-blend-mode (make-gl-blend-op (blend-equation op-rgb)
                                            (blend-equation op-alpha))
                          (make-gl-blend-func (blend-src-func src-rgb)
                                              (blend-src-func src-alpha)
                                              (blend-dst-func dst-rgb)
                                              (blend-dst-func dst-alpha)))))
   (color-target-mask color-target)
   (match depth+stencil
     (#f #f)
     (($ <depth+stencil> _ write? func)
      (make-gl-depth-test (depth-func func) write?)))
   (match depth+stencil
     (#f #f)
     (($ <depth+stencil> _ _ _
         ($ <stencil-face> compare-front fail-front depth-fail-front pass-front)
         ($ <stencil-face> compare-back fail-back depth-fail-back pass-back)
         read-mask write-mask)
      (make-gl-stencil-test read-mask write-mask
                            (stencil-func compare-front)
                            (stencil-func compare-back)
                            (make-gl-stencil-op (stencil-op* fail-front)
                                                (stencil-op* depth-fail-front)
                                                (stencil-op* pass-front))
                            (make-gl-stencil-op (stencil-op* fail-back)
                                                (stencil-op* depth-fail-back)
                                                (stencil-op* pass-back)))))
   vertex-attributes
   binding-layout))

(define (destroy-gl-render-pipeline state pipeline)
  ;; No GPU resources allocated, so nothing to do.
  (values))


;;;
;;; General GL state stuff
;;;

(define (gl-state-init! state)
  (let* ((verts (f32vector -1.0 -1.0   0.0 0.0
                           +1.0 -1.0   1.0 0.0
                           +1.0 +1.0   1.0 1.0
                           -1.0 +1.0   0.0 1.0))
         (is (u32vector 0 2 3 0 1 2))
         (vlength (bytevector-length verts))
         (ilength (bytevector-length is))
         (vertices (make-gl-buffer state vlength '(vertex)))
         (indices (make-gl-buffer state ilength '(index)))
         (shader (make-gl-shader state
                                 (lambda (lang)
                                   (values "
#ifdef GLSL330
layout (location = 0) in vec2 position;
layout (location = 1) in vec2 tex;
#elif defined(GLSL130)
in vec2 position;
in vec2 tex;
#elif defined(GLSL120)
attribute vec2 position;
attribute vec2 tex;
#endif
#ifdef GLSL120
varying vec2 fragTex;
#else
out vec2 fragTex;
#endif

void main(void) {
    fragTex = tex;
    gl_Position = vec4(position, 0.0, 1.0);
}
" "
#ifdef GLSL120
varying vec2 fragTex;
#else
in vec2 fragTex;
#endif
#ifdef GLSL330
out vec4 outFragColor;
#else
#define outFragColor gl_FragColor
#define texture texture2D
#endif

uniform sampler2D sampler;

void main (void) {
    outFragColor = texture(sampler, fragTex);
}
")))))
    (write-gl-buffer state vertices 0 verts 0 vlength)
    (write-gl-buffer state indices 0 is 0 ilength)
    (set-gl-state-screen-vertices! state vertices)
    (set-gl-state-screen-indices! state indices)
    (set-gl-state-screen-shader! state shader)))

(define (gl-state-guard state obj)
  ((gl-state-guardian state) obj)
  obj)

(define (gl-state-gc state)
  (let ((guardian (gl-state-guardian state)))
    (let loop ((obj (guardian)))
      (when obj
        (match obj
          ((? gl-buffer?) (destroy-gl-buffer state obj))
          ((? gl-texture?) (destroy-gl-texture state obj))
          ((? gl-texture-view?) (destroy-gl-texture-view state obj))
          ((? gl-sampler?) (destroy-gl-sampler state obj))
          ((? gl-shader?) (destroy-gl-shader state obj)))
        (loop (guardian))))))

(define (swap-gl-state state view)
  (set-gl-state-framebuffer! state null-gl-framebuffer)
  (set-gl-state-buffer-index! state (gl-state-screen-indices state))
  (set-gl-state-buffer-vertex! state (gl-state-screen-vertices state))
  (set-gl-state-shader! state (gl-state-screen-shader state))
  (set-gl-state-texture! state 0 view)
  (set-gl-state-sampler! state 0 null-gl-sampler)
  (set-gl-state-blending! state #f)
  (set-gl-state-scissor-test! state #f)
  (set-gl-state-depth-test! state #f)
  (set-gl-state-stencil-test! state #f)
  (set-gl-state-face-culling! state #t)
  (set-gl-state-cull-face! state (cull-face-mode back))
  (set-gl-state-front-face! state (front-face-direction ccw))
  (set-gl-state-color-mask! state %default-color-mask)
  (gl-enable-vertex-attrib-array 0)
  (gl-vertex-attrib-pointer 0 2 (data-type float) #f 16 (offset->pointer 0))
  (gl-enable-vertex-attrib-array 1)
  (gl-vertex-attrib-pointer 1 2 (data-type float) #f 16 (offset->pointer 8))
  (gl-draw-elements (begin-mode triangles) 6 (data-type unsigned-int) %null-pointer)
  ((gl-state-swap state)))

(define (gl-state-begin-frame state)
  (set-gl-state-framebuffer! state null-gl-framebuffer))

(define (gl-state-end-frame state view)
  (swap-gl-state state view)
  (gl-state-gc state))

(define offset->pointer
  (let ((cache (make-hash-table)))
    (define (offset->pointer offset)
      (if (eq? offset 0)
          %null-pointer
          (or (hashv-ref cache offset)
              (let ((ptr (make-pointer offset)))
                (hashv-set! cache offset ptr)
                ptr))))
    offset->pointer))

(define (gl-begin-render-pass state cmd)
  (match cmd
    (($ <begin-render-pass-command> pass colors depth+stencil)
     (let ((fbo (gl-state-framebuffer-build state pass colors depth+stencil)))
       (set-gl-state-framebuffer! state fbo)
       ;; Disable scissor test so gl-clear will clear the entire
       ;; framebuffer.
       (set-gl-state-scissor-test! state #f)
       ;; Clear all attachments that have a load op of 'clear'.
       (let loop ((i 0))
         (when (< i (vector-length colors))
           (match (vector-ref colors i)
             (#(#f _ _) #f)
             (#(view resolve-target ($ <color-operation> clear-color 'clear))
              (set-gl-state-color-mask! state %default-color-mask)
              (set-gl-state-clear-color! state clear-color)
              (gl-draw-buffer (+ (version-3-0 color-attachment0) i))
              (gl-clear (clear-buffer-mask color-buffer))
              (loop (+ i 1)))
             (_ (loop (+ i 1))))))
       (match depth+stencil
         (#(#f _ _) #f)
         (#(view depth-op stencil-op)
          (match depth-op
            (($ <depth-operation> clear-value 'clear)
             (set-gl-state-depth-write! state #t)
             (set-gl-state-clear-depth! state clear-value)
             (gl-clear (clear-buffer-mask depth-buffer)))
            (_ #t))
          (match stencil-op
            (($ <stencil-operation> clear-value 'clear)
             (set-gl-state-stencil-write-mask! state #xffffFFFF)
             (set-gl-state-clear-stencil! state clear-value)
             (gl-clear (clear-buffer-mask stencil-buffer)))
            (_ #t))))))))

(define (gl-end-render-pass state)
  ;;(set-gl-state-render-pass! state #f)
  #t)

(define (gl-state-draw state cmd)
  (match cmd
    (($ <draw-command>
        ($ <gl-render-pipeline> shader begin-mode polygon-mode front-face
           cull-face color-format blend-mode color-mask depth-test
           stencil-test vattrs binding-layout)
        pass viewport scissor blend-constant stencil-reference
        start count instances index-buffer vertex-buffers bindings)
     (set-gl-state-framebuffer! state (gl-state-framebuffer-ref state pass))
     (set-gl-state-viewport! state viewport)
     (match scissor
       (#f (set-gl-state-scissor-test! state #f))
       (_
        (set-gl-state-scissor-test! state #t)
        (set-gl-state-scissor-rect! state scissor)))
     (set-gl-state-shader! state shader)
     (set-gl-state-polygon-mode! state polygon-mode)
     (set-gl-state-front-face! state front-face)
     (set-gl-state-color-mask! state color-mask)
     (match cull-face
       (#f (set-gl-state-face-culling! state #f))
       (face
        (set-gl-state-face-culling! state #t)
        (set-gl-state-cull-face! state face)))
     (match blend-mode
       (#f (set-gl-state-blending! state #f))
       (($ <gl-blend-mode> op func)
        (set-gl-state-blending! state #t)
        (set-gl-state-blend-op! state op)
        (set-gl-state-blend-func! state func)
        (set-gl-state-blend-constant! state blend-constant)))
     (match depth-test
       (#f (set-gl-state-depth-test! state #f))
       (($ <gl-depth-test> func write?)
        (set-gl-state-depth-test! state #t)
        (set-gl-state-depth-func! state func)
        (set-gl-state-depth-write! state write?)
        (match viewport
          (($ <viewport> _ _ _ _ depth-near depth-far)
           (set-gl-state-depth-range! state depth-near depth-far)))))
     (match stencil-test
       (#f (set-gl-state-stencil-test! state #f))
       (($ <gl-stencil-test> read-mask write-mask func-front func-back
           op-front op-back)
        (set-gl-state-stencil-test! state #f)
        (set-gl-state-stencil-write-mask! state write-mask)
        (set-gl-state-stencil-op-front! state op-front)
        (set-gl-state-stencil-op-front! state op-back)
        (set-gl-state-stencil-func-front! state func-front stencil-reference
                                          read-mask)
        (set-gl-state-stencil-func-back! state func-back stencil-reference
                                         read-mask)))
     ;; TODO: Setup multisample state.
     ;; Setup vertex attributes.
     (do ((i 0 (+ i 1)))
         ((= i (vector-length vattrs)))
       (let ((attrs (vector-ref vattrs i)))
         (set-gl-state-buffer-vertex! state (vector-ref vertex-buffers i))
         (do ((j 0 (+ j 1)))
             ((= j (vector-length attrs)))
           (match (vector-ref attrs j)
             (($ <gl-vertex-attribute> index size type normalized? stride
                                       pointer divisor)
              (gl-enable-vertex-attrib-array index)
              (gl-vertex-attrib-pointer index size type normalized? stride pointer)
              (when divisor
                (gl-vertex-attrib-divisor index divisor)))))))
     ;; Setup textures, samplers, and uniforms.
     ;;
     ;; Lots of loop variables here:
     ;; i: bindings vector index, the main loop iterator
     ;; s: current sampler unit
     ;; t: current texture unit
     ;; l: current shader location, used for sampler bindings
     ;; b: current uniform block index, used for uniform buffer bindings
     (let loop ((i 0) (s 0) (t 0) (l 0) (b 0))
       (when (< i (vector-length binding-layout))
         (match (vector-ref binding-layout i)
           (($ <texture-layout> sample-type dimension multisample?)
            (match (vector-ref bindings i)
              (#f (set-gl-state-texture! state t null-gl-texture))
              ((? gl-texture-view? view)
               (set-gl-state-texture! state t view))
              (obj (error "expected texture view binding" i obj)))
            (loop (+ i 1) s (+ t 1) l b))
           (($ <sampler-layout> type)
            (match (vector-ref bindings i)
              (#f (set-gl-state-sampler! state t null-gl-sampler))
              ((? gl-sampler? sampler)
               (set-gl-state-sampler! state s sampler))
              (obj (error "expected sampler binding" i obj)))
            ;; A sampler binding uses 1 shader location.
            (gl-uniform1i l s)
            (loop (+ i 1) (+ s 1) t (+ l 1) b))
           (($ <buffer-layout> type min-size)
            ;; A uniform buffer binding uses one uniform block binding
            ;; point.
            (match (vector-ref bindings i)
              ((? gl-buffer? buffer)
               (set-gl-state-buffer-uniform! state b buffer))
              (obj (error "expected uniform buffer binding" obj)))
            (loop (+ i 1) s t l (+ b 1))))))
     (if instances
         (if index-buffer
             (begin
               (set-gl-state-buffer-index! state index-buffer)
               (gl-draw-elements-instanced begin-mode count
                                           (data-type unsigned-int)
                                           (offset->pointer (* start 4))
                                           instances))
             (gl-draw-arrays-instanced begin-mode start count instances))
         (if index-buffer
             (begin
               (set-gl-state-buffer-index! state index-buffer)
               (gl-draw-elements begin-mode count
                                 (data-type unsigned-int)
                                 (offset->pointer (* start 4))))
             (gl-draw-arrays begin-mode start count))))))

(define (gl-state-submit state cmd)
  (cond
   ((draw-command? cmd)
    (gl-state-draw state cmd))
   ((begin-render-pass-command? cmd)
    (gl-begin-render-pass state cmd))
   ((end-render-pass-command? cmd)
    (gl-end-render-pass state))))


;;;
;;; OpenGL backend
;;;

(define (make-opengl-gpu gl-context swap init-width init-height)
  (define (parse-version str)
    (match (string-split str #\space)
      ((version . _) version)))
  (let* ((gl-version (gl-get-string (string-name version)))
         (glsl-version (gl-get-string (version-2-0 shading-language-version)))
         (vendor (gl-get-string (string-name vendor)))
         (renderer (gl-get-string (string-name renderer)))
         (extensions
          (let ((table (make-hash-table)))
            (for-each (lambda (name)
                        (hash-set! table name #t))
                      (string-split (gl-get-string (string-name extensions))
                                    #\space))
            table))
         (max-texture-size
          (gl-get-integer (get-p-name max-texture-size)))
         (max-3d-texture-size
          (gl-get-integer (version-1-2 max-3d-texture-size)))
         (max-array-texture-layers
          (gl-get-integer (version-3-0 max-array-texture-layers)))
         (max-textures
          (gl-get-integer (version-2-0 max-combined-texture-image-units)))
         (max-ubos
          (gl-get-integer (version-3-1 max-uniform-buffer-bindings)))
         (max-uniform-block-size
          (gl-get-integer (version-3-1 max-uniform-block-size)))
         (max-vertex-attrib-bindings
          (gl-get-integer (arb-vertex-attrib-binding max-vertex-attrib-bindings)))
         (max-vertex-attribs
          (gl-get-integer (version-2-0 max-vertex-attribs)))
         (max-varying-components
          (gl-get-integer (version-3-0 max-varying-components)))
         (max-varying-vectors
          (gl-get-integer (arb-es2-compatibility max-varying-vectors)))
         (max-color-attachments
          (gl-get-integer (version-3-0 max-color-attachments)))
         (limits
          (make-gpu-limits #:max-texture-dimension-1d max-texture-size
                           #:max-texture-dimension-2d max-texture-size
                           #:max-texture-dimension-3d max-3d-texture-size
                           #:max-texture-array-layers max-array-texture-layers
                           #:max-sampled-textures-per-shader-stage max-textures
                           #:max-samplers-per-shader-stage max-textures
                           #:max-uniform-buffers-per-shader-stage max-ubos
                           #:max-uniform-buffer-binding-size max-uniform-block-size
                           #:max-bindings 128
                           #:max-vertex-buffers max-vertex-attrib-bindings
                           #:max-buffer-size (* 2 1024 1024 1024) ; 2 GiB
                           #:max-vertex-attributes (* max-vertex-attrib-bindings
                                                      max-vertex-attribs)
                           #:max-vertex-buffer-array-stride 2048
                           #:max-inter-stage-shader-components max-varying-components
                           #:max-inter-stage-shader-variables max-varying-vectors
                           #:max-color-attachments max-color-attachments))
         (gl-state
          (%make-gl-state gl-context swap
                          (make-guardian)
                          gl-version
                          (parse-version glsl-version)
                          vendor renderer
                          limits
                          (hash-ref extensions "GL_ARB_texture_view")
                          (hash-ref extensions "GL_ARB_sampler_objects")
                          (hash-ref extensions "GL_ARB_uniform_buffer_object")
                          #f            ; blending
                          #f            ; face culling
                          #f            ; depth test
                          #f            ; stencil test
                          #f            ; scissor test
                          (make-viewport 0 0 init-width init-height)
                          (make-scissor-rect 0 0 init-width init-height)
                          (polygon-mode fill)
                          (cull-face-mode back)
                          (front-face-direction ccw)
                          (make-gl-blend-op (blend-equation-mode-ext func-add-ext)
                                            (blend-equation-mode-ext func-add-ext))
                          (make-gl-blend-func (blending-factor-src one)
                                              (blending-factor-dest zero)
                                              (blending-factor-src one)
                                              (blending-factor-dest zero))
                          %default-color-mask
                          (depth-function less)
                          #t                  ; depth write
                          (f64vector 0.0 1.0) ; depth range
                          #xffffFFFF          ; stencil write mask
                          ;; front/back stencil funcs
                          (vector (stencil-function always) 0 #xffffFFFF)
                          (vector (stencil-function always) 0 #xffffFFFF)
                          (make-gl-stencil-op (stencil-op keep)
                                              (stencil-op keep)
                                              (stencil-op keep))
                          (make-gl-stencil-op (stencil-op keep)
                                              (stencil-op keep)
                                              (stencil-op keep))
                          (make-color 0.0 0.0 0.0 0.0) ; clear color
                          1                            ; clear depth
                          0                            ; clear stencil
                          null-gl-buffer
                          null-gl-buffer
                          null-gl-buffer
                          null-gl-buffer
                          (make-vector max-ubos null-gl-buffer)
                          (make-vector max-textures null-gl-texture)
                          (make-vector max-textures null-gl-sampler)
                          null-gl-shader
                          null-gl-framebuffer
                          'default      ; mode
                          (make-weak-key-hash-table))))
    (gl-state-init! gl-state)
    ;; Enable seamless cubemaps.  There's never a need to disable it
    ;; so we don't need to track it in the GL state object.  It only
    ;; makes things better for skyboxes and such.  Some old hardware
    ;; might not support it, in which case this does nothign.
    (gl-enable (arb-seamless-cube-map texture-cube-map-seamless))
    (make-gpu "OpenGL"
              ;; Helpful description of driver details.
              (string-append "OpenGL version " (gl-state-gl-version gl-state)
                             ", GLSL version " (gl-state-glsl-version gl-state)
                             ", vendor: " (gl-state-vendor gl-state)
                             ", renderer: " (gl-state-renderer gl-state))
              gl-state
              #:limits limits
              #:begin-frame gl-state-begin-frame
              #:end-frame gl-state-end-frame
              #:make-buffer make-gl-buffer
              #:destroy-buffer destroy-gl-buffer
              #:map-buffer map-gl-buffer
              #:unmap-buffer unmap-gl-buffer
              #:write-buffer write-gl-buffer
              #:make-texture make-gl-texture
              #:destroy-texture destroy-gl-texture
              #:write-texture write-gl-texture
              #:make-texture-view make-gl-texture-view
              #:destroy-texture-view destroy-gl-texture-view
              #:make-sampler make-gl-sampler
              #:destroy-sampler destroy-gl-sampler
              #:make-shader make-gl-shader
              #:destroy-shader destroy-gl-shader
              #:make-render-pipeline make-gl-render-pipeline
              #:destroy-render-pipeline destroy-gl-render-pipeline
              #:submit gl-state-submit)))