diff options
Diffstat (limited to 'chickadee/graphics/backend/opengl.scm')
| -rw-r--r-- | chickadee/graphics/backend/opengl.scm | 2088 |
1 files changed, 2088 insertions, 0 deletions
diff --git a/chickadee/graphics/backend/opengl.scm b/chickadee/graphics/backend/opengl.scm new file mode 100644 index 0000000..9c42538 --- /dev/null +++ b/chickadee/graphics/backend/opengl.scm @@ -0,0 +1,2088 @@ +;;; 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))) |