From d2adfa5c5bae5d8ee20564ec9e50cae4b75f945d Mon Sep 17 00:00:00 2001 From: David Thompson Date: Sat, 30 Sep 2023 19:42:01 -0400 Subject: WIP: Switch to WebGPU-like API --- chickadee.scm | 126 +- chickadee/graphics/backend/opengl.scm | 896 ++++++++++++ chickadee/graphics/gpu.scm | 2482 +++++++++++---------------------- chickadee/graphics/shader.scm | 24 +- chickadee/graphics/texture.scm | 2 +- chickadee/graphics/viewport.scm | 8 +- guix.scm | 4 +- 7 files changed, 1808 insertions(+), 1734 deletions(-) create mode 100644 chickadee/graphics/backend/opengl.scm diff --git a/chickadee.scm b/chickadee.scm index 656ce0b..8343a6b 100644 --- a/chickadee.scm +++ b/chickadee.scm @@ -16,7 +16,7 @@ ;;; Commentary: ;; -;; Simple SDL + OpenGL game loop implementation. +;; Core event loop. ;; ;;; Code: @@ -26,12 +26,12 @@ #:use-module (chickadee game-loop) #:use-module (chickadee math matrix) #:use-module (chickadee graphics color) - #:use-module (chickadee graphics engine) #:use-module (chickadee graphics gpu) - #:use-module (chickadee graphics viewport) + ;; #:use-module (chickadee graphics viewport) #:use-module (chickadee utils) #:use-module (ice-9 atomic) #:use-module (ice-9 match) + #:use-module (ice-9 threads) #:use-module (sdl2) #:use-module (sdl2 events) #:use-module ((sdl2 input game-controller) #:prefix sdl2:) @@ -76,6 +76,9 @@ #:re-export (abort-game current-timestep)) + + + (define %time-freq (exact->inexact internal-time-units-per-second)) (define (elapsed-time) @@ -155,10 +158,8 @@ not being pushed at all." (define* (make-window #:key (title "Chickadee") fullscreen? resizable? (width 640) (height 480) (multisample? #t)) - ;; Hint that we want OpenGL 3.2 Core profile. Doesn't mean we'll - ;; get it, though! - (sdl2:set-gl-attribute! 'context-major-version 3) - (sdl2:set-gl-attribute! 'context-major-version 2) + ;; Hint that we want the core profile with deprecated features + ;; disabled. Doesn't mean we'll get it, though! (sdl2:set-gl-attribute! 'context-profile-mask 1) ; core profile (sdl2:set-gl-attribute! 'stencil-size 8) ; 8-bit stencil buffer (if multisample? @@ -254,7 +255,8 @@ border is disabled, otherwise it is enabled.") (window-height 480) window-fullscreen? window-resizable? - (clear-color %default-clear-color) + (clear-color black;; %default-clear-color + ) (update-hz 60) (load noop) (update noop) @@ -304,20 +306,19 @@ border is disabled, otherwise it is enabled.") #:fullscreen? window-fullscreen? #:resizable? window-resizable? #:multisample? #f))) - (default-viewport (vector - (make-viewport 0 0 window-width window-height - #:clear-color clear-color))) + ;; (default-viewport (vector + ;; (make-viewport 0 0 window-width window-height + ;; #:clear-color clear-color))) (default-projection (vector (orthographic-projection 0 window-width window-height 0 0 1))) - (gpu (make-gpu (window-gl-context window))) - (gfx (make-graphics-engine gpu))) + (gpu (make-gpu (unwrap-window window) (window-gl-context window)))) (define (invert-y y) ;; SDL's origin is the top-left, but our origin is the bottom ;; left so we need to invert Y coordinates that SDL gives us. (- window-height y)) - (define (input-sdl) + (define (flush-sdl-input) (define (process-event event) (cond ((quit-event? event) @@ -398,9 +399,9 @@ border is disabled, otherwise it is enabled.") ((width height) (set! window-width width) (set! window-height height) - (vector-set! default-viewport 0 - (make-viewport 0 0 width height - #:clear-color clear-color)) + ;; (vector-set! default-viewport 0 + ;; (make-viewport 0 0 width height + ;; #:clear-color clear-color)) (vector-set! default-projection 0 (orthographic-projection 0 width height 0 0 1)) (window-resize width height)))))) @@ -409,51 +410,58 @@ border is disabled, otherwise it is enabled.") (when event (process-event event) (loop (poll-event))))) - (define (update-sdl dt) - (input-sdl) - (update dt) - ;; Update audio after updating game state so that any sounds - ;; that were queued to play this frame start playing immediately. - (update-audio) - ;; Free any GPU resources that have been GC'd. - (graphics-engine-gc gfx)) - (define (render-sdl-opengl alpha) - (graphics-engine-reset! gfx) - ;; Enable seamless cube maps. - ;; TODO: This should go somewhere else. - (set-gpu-seamless-cube-maps! (current-gpu) #t) - (with-viewport (vector-ref default-viewport 0) - (clear-viewport) - (with-graphics-state ((projection (vector-ref default-projection 0))) - (draw alpha))) - (sdl2:swap-gl-window (unwrap-window window))) (define (on-error e stack) (error e stack) ;; Flush all input events that have occurred while in the error ;; state. (while (poll-event) #t)) - (dynamic-wind - (const #t) - (lambda () - (parameterize ((current-window window) - (current-graphics-engine gfx)) - ;; Attempt to activate vsync, if possible. Some systems do - ;; not support setting the OpenGL swap interval. - (catch #t - (lambda () - (sdl2:set-gl-swap-interval! 'vsync)) - (lambda args - (display "warning: could not enable vsync\n" - (current-error-port)))) - (sdl2:load-game-controller-mappings! - (scope-datadir "gamecontrollerdb.txt")) - (run-game* #:init load - #:update update-sdl - #:render render-sdl-opengl - #:error (and error on-error) - #:time elapsed-time - #:update-hz update-hz))) + ;; The game loop will run in its own thread so that updating game + ;; state can happen while rendering and input are being processed + ;; in the main thread and thus improving overall performance. + ;; This is where all user code is executed. + (define (game-loop) + (parameterize ((current-window window) + (current-gpu gpu)) + (run-game* #:init load + #:update update + #:render draw + #:error (and error on-error) + #:time elapsed-time + #:update-hz update-hz))) + ;; The main loop handles the input and rendering queues, as input + ;; polling and GPU calls have to be done from the main thread in + ;; SDL. + (define (main-loop) + (flush-sdl-input) + (update-audio) + ;; (graphics-engine-reset! gfx) + ;; Enable seamless cube maps. + ;; TODO: This should go somewhere else. + ;; (set-gpu-seamless-cube-maps! (current-gpu) #t) + ;; (with-viewport (vector-ref default-viewport 0) + ;; (clear-viewport) + ;; (with-graphics-state ((projection (vector-ref default-projection 0))) + ;; (draw alpha))) + (gpu-tick gpu) + (gpu-swap gpu) + ;; Free any GPU resources that have been GC'd. + (gpu-gc gpu) + (usleep 1) ; don't use 100% of the cpu pls + (main-loop)) + ;; Attempt to activate vsync, if possible. Some systems do + ;; not support setting the OpenGL swap interval. + (catch #t (lambda () - (quit-audio) - (sdl2:delete-gl-context! (window-gl-context window)) - (sdl2:close-window! (unwrap-window window)))))) + (sdl2:set-gl-swap-interval! 'vsync)) + (lambda args + (display "warning: could not enable vsync\n" + (current-error-port)))) + ;; Make lots of game controllers "just work." + (sdl2:load-game-controller-mappings! + (scope-datadir "gamecontrollerdb.txt")) + ;; Launch game loop in a separate thread and start the main loop. + (let ((game-thread (call-with-new-thread game-loop))) + (main-loop) + (quit-audio) + (sdl2:delete-gl-context! (window-gl-context window)) + (sdl2:close-window! (unwrap-window window))))) diff --git a/chickadee/graphics/backend/opengl.scm b/chickadee/graphics/backend/opengl.scm new file mode 100644 index 0000000..ab797a7 --- /dev/null +++ b/chickadee/graphics/backend/opengl.scm @@ -0,0 +1,896 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2023 David Thompson +;;; +;;; 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 GPU backend. Supports even old ass OpenGL 2.1 hardware that +;; lots of people are still using! +;; +;;; Code: + +(define-module (chickadee graphics backend opengl) + #:use-module (chickadee data array-list) + #:use-module (chickadee data queue) + #:use-module (chickadee graphics color) + #:use-module (chickadee graphics gpu) + #:use-module (chickadee math rect) + #: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 ((sdl2 video) #:select (gl-context-make-current! + swap-gl-window)) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:use-module ((system foreign) + #:select (bytevector->pointer + pointer->bytevector + pointer->string + pointer-address + make-pointer + %null-pointer))) + + +;;; +;;; Additional OpenGL wrappers +;;; + +;; TODO: Upstream these to guile-opengl + +(define gl-clear-color %glClearColor) +(define gl-scissor %glScissor) +(define gl-blend-func %glBlendFunc) +(define gl-blend-equation %glBlendEquation) +(define gl-texture-image-3d %glTexImage3D) +(define gl-texture-image-2d %glTexImage2D) +(define gl-texture-image-1d %glTexImage1D) +(define gl-copy-texture-image-2d %glCopyTexImage2D) +(define gl-copy-texture-image-1d %glCopyTexImage1D) +(define gl-copy-texture-sub-image-3d %glCopyTexSubImage3D) +(define gl-copy-texture-sub-image-2d %glCopyTexSubImage2D) +(define gl-copy-texture-sub-image-1d %glCopyTexSubImage1D) +(define gl-texture-sub-image-3d %glTexSubImage3D) +(define gl-texture-sub-image-2d %glTexSubImage2D) +(define gl-texture-sub-image-1d %glTexSubImage1D) +(define gl-compressed-texture-image-1d %glCompressedTexImage1D) +(define gl-compressed-texture-image-2d %glCompressedTexImage2D) +(define gl-compressed-texture-image-3d %glCompressedTexImage3D) +(define gl-compressed-texture-sub-image-1d %glCompressedTexSubImage1D) +(define gl-compressed-texture-sub-image-2d %glCompressedTexSubImage2D) +(define gl-compressed-texture-sub-image-3d %glCompressedTexSubImage3D) +(define gl-texture-parameter %glTexParameteri) +(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-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-integer-v %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 (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 (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 (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-generate-mipmap glGenerateMipmap) +(define gl-texture-view glTextureView) +(define gl-gen-samplers glGenSamplers) +(define gl-draw-arrays-instanced glDrawArraysInstanced) +(define gl-draw-elements-instanced glDrawElementsInstanced) +(define gl-vertex-attrib-divisor glVertexAttribDivisor) +(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))) + + +;;; +;;; Internal API imports +;;; + +(define-syntax-rule (define-internal-import name) + (define name (@@ (chickadee graphics gpu) name))) + +(define-internal-import buffer-handle) +(define-internal-import shader-module-handle) +(define-internal-import ) +(define-internal-import ) +(define-internal-import ) +(define-internal-import ) +(define-internal-import ) +(define-internal-import ) +(define-internal-import ) +(define-internal-import ) +(define-internal-import ) +(define-internal-import ) +(define-internal-import ) +(define-internal-import ) +(define-internal-import ) +(define-internal-import ) + + +;;; +;;; GPU backend +;;; + +(define-record-type + (%make-gl-buffer id) + gl-buffer? + (id gl-buffer-id) + (map-target gl-buffer-map-target set-gl-buffer-map-target!)) + +(define-record-type + (%make-gl-texture id) + gl-texture? + (id gl-texture-id)) + +(define-record-type + (%make-gl-texture-view id) + gl-texture-view? + (id gl-texture-view-id)) + +(define-record-type + (%make-gl-sampler id) + gl-sampler? + (id gl-sampler-id)) + +(define-record-type + (make-gl-shader id) + gl-shader? + (id gl-shader-id)) + +(define-record-type + (%make-gl-shader-module vertex fragment) + gl-shader-module? + (vertex gl-shader-module-vertex) + (fragment gl-shader-module-fragment)) + +(define-record-type + (make-gl-program id) + gl-program? + (id gl-program-id)) + +(define-record-type + (%make-gl-meta version glsl-version vendor renderer driver extensions) + gl-meta? + (version gl-meta-version) + (glsl-version gl-meta-glsl-version) + (vendor gl-meta-vendor) + (renderer gl-meta-renderer) + (driver gl-meta-driver) + (extensions gl-meta-extensions)) + +(define (make-gl-meta) + (define (get-string id) + (pointer->string (gl-get-string id))) + (define (parse-version str) + (match (string-split str #\space) + ((version . _) version))) + (let ((version (get-string (string-name version))) + (extensions (make-hash-table))) + (for-each (lambda (name) + (hash-set! extensions name #t)) + (string-split (get-string (string-name extensions)) + #\space)) + (%make-gl-meta (parse-version version) + (parse-version + (get-string + (version-2-0 shading-language-version))) + (get-string (string-name vendor)) + (get-string (string-name renderer)) + version + extensions))) + +(define (gl-meta-has-extension? meta name) + (hash-ref (gl-meta-extensions meta) name)) + +(define-record-type + (%make-gl-state window context meta queue) + gl-state? + (window gl-state-window) + (context gl-state-context) + (meta gl-state-meta) + (queue gl-state-queue) + (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!) + (program gl-state-program %set-gl-state-program!) + (cull-mode gl-state-cull-mode %set-gl-state-cull-mode!) + (front-face gl-state-front-face %set-gl-state-front-face!)) + +(define (make-gl-state window context) + (%make-gl-state window context (make-gl-meta) (make-queue))) + +(define debug-level (or (getenv "GL_DEBUG") -1)) + +(define (gl-debug level msg) + (when (>= debug-level level) + (format #t "gl: ~a\n" msg))) + +(define (gl-state-version>= state version) + (string>= (gl-meta-version (gl-state-meta state)) version)) + +(define-syntax-rule (gl-state-make-current! state) + (gl-context-make-current! (gl-state-window state) (gl-state-context state))) + +(define (gl-state-swap state) + (swap-gl-window (gl-state-window state))) + +(define (gl-state-enqueue state command-buffer) + (let ((q (gl-state-queue state))) + (for-each (lambda (cmd) (enqueue! q cmd)) + (command-buffer-commands command-buffer)))) + +(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 (gl-buffer-id buffer) (version-1-5 element-array-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 (gl-buffer-id buffer) (version-3-1 copy-read-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 (gl-buffer-id buffer) (version-3-1 copy-write-buffer)) + (%set-gl-state-buffer-copy-write! state buffer))) + +(define (set-gl-state-program! state program) + (unless (eq? (gl-state-program state) program) + (gl-use-program (gl-program-id program)) + (%set-gl-state-program! state program))) + +(define (set-gl-state-cull-mode! state cull-mode) + (unless (eq? (gl-state-cull-mode state) cull-mode) + (match cull-mode + ('none + (gl-disable (enable-cap cull-face))) + ('front + (gl-enable (enable-cap cull-face)) + (gl-cull-face (cull-face-mode front))) + ('back + (gl-enable (enable-cap cull-face)) + (gl-cull-face (cull-face-mode back)))) + (%set-gl-state-cull-mode! state cull-mode))) + +(define (set-gl-state-front-face! state front-face) + (unless (eq? (gl-state-front-face state) front-face) + (match front-face + ('ccw (gl-front-face (front-face-direction ccw))) + ('cw (gl-front-face (front-face-direction cw)))) + (%set-gl-state-front-face! state front-face))) + +;; (define (set-gl-state-blend-mode! state blend) +;; (unless (equal? (gl-state-blend state)) +;; (match blend +;; (#f (gl-disable (enable-cap blend))) +;; (($ ($ color-op color-src color-dst) +;; ($ alpha-op alpha-src alpha-dst)) +;; (gl-enable (enable-cap blend)) +;; (gl-blend-equation equation) +;; (gl-blend-func src dest))) +;; (%set-gl-state-blend! state blend))) + +(define *offset-cache* (make-hash-table)) + +(define (offset->pointer offset) + (or (hashv-ref *offset-cache* offset) + (let ((ptr (make-pointer offset))) + (hashv-set! *offset-cache* offset ptr) + ptr))) + +(define (gl-state-tick state) + (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 (primitive-mode primitive) + (match (primitive-state-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)))) + (define (apply-render-pipeline pipeline) + (match pipeline + (($ program + ($ _ buffers) + fragment + ($ _ front-face cull-mode _) + depth-stencil + multisample) + (set-gl-state-program! state program) + (set-gl-state-front-face! state front-face) + (set-gl-state-cull-mode! state cull-mode)))) + (define (apply-render-state render-state) + (match render-state + (($ (and pipeline ($ _ vertex fragment)) + vertex-buffers) + (apply-render-pipeline pipeline) + ;; Bind vertex buffers and setup vertex attributes. + (let loop ((layouts (vertex-state-buffers vertex)) + (i 0)) + (match layouts + (() #t) + ((($ stride step-mode attributes) . rest) + (set-gl-state-buffer-vertex! state + (buffer-handle + (vector-ref vertex-buffers i))) + (let attrib-loop ((attributes attributes)) + (match attributes + (() (loop rest (+ i 1))) + ((($ location format offset) . rest-attribs) + (gl-enable-vertex-attrib-array location) + (gl-vertex-attrib-pointer location + (format-component-count format) + (format-type format) + (format-normalized? format) + stride + (offset->pointer offset)) + (attrib-loop rest-attribs))) + attributes))))))) + (define (do-command cmd) + (match cmd + (($ render-state vertex-count instance-count + first-vertex first-instance) + (apply-render-state render-state) + ;; TODO: Support instanced rendering. + ;; TODO: Support index buffers. + (gl-draw-arrays (primitive-mode + (render-pipeline-primitive + (render-state-pipeline render-state))) + first-vertex vertex-count)))) + (gl-state-make-current! state) + (let ((q (gl-state-queue state))) + (let loop () + (unless (queue-empty? q) + (do-command (dequeue! q)) + (loop))))) + + +;;; +;;; Buffers +;;; + +;; 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. +;; +;; TODO: Do we somehow slowly emulate the missing buffer support on GL +;; versions? Or do we just leave that up to higher-level APIs to +;; handle? Punt for now and see what the situation is like when we +;; actually hit a real world compatibility problem. + +(define (make-gl-buffer state length usage) + (gl-state-make-current! state) + (let ((buffer (%make-gl-buffer (gl-generate-buffer)))) + (set-gl-state-buffer-vertex! state buffer) + ;; Allocate buffer memory. + (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 (gl-buffer-destroy state buffer) + (gl-delete-buffer (gl-buffer-id buffer))) + +(define (gl-buffer-map state buffer mode offset length) + (match mode + ('read + (let ((target (version-3-1 copy-write-buffer)) + (access (version-1-5 read-only))) + (set-gl-buffer-map-target! buffer target) + (set-gl-state-buffer-copy-write! target buffer) + (pointer->bytevector (gl-map-buffer target access) length offset))) + ('write + (let ((target (version-3-1 copy-read-buffer)) + (access (version-1-5 write-only))) + (set-gl-buffer-map-target! buffer target) + (set-gl-state-buffer-copy-read! target buffer) + (pointer->bytevector (gl-map-buffer target access) length offset))))) + +(define (gl-buffer-unmap state buffer) + (gl-unmap-buffer (gl-buffer-map-target buffer))) + +(define (gl-buffer-write state buffer buffer-offset data data-offset length) + (gl-state-make-current! state) + (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 samplers +;;; + +;; A texture simply maps to an OpenGL texture, but texture views and +;; samplers are where things get complicated. Texture views are +;; supported in OpenGL >= 4.3 so older versions have to fall back to +;; copying data into a new texture. Samplers are supported in OpenGL +;; >= 3.3 so older versions have to fall back to copying data into yet +;; another new texture and using glTexParameter. + +(define (make-gl-texture state width height depth mip-level-count + sample-count dimension format usage + view-formats) + (%make-gl-texture (gl-generate-texture))) + +(define (gl-texture-destroy state texture) + (gl-delete-texture (gl-texture-id texture))) + +(define (make-gl-texture-view state texture format dimension aspect base-mip-level + mip-level-count base-layer layer-count) + (if (gl-state-version>= state "4.3") + (let ((alias (gl-generate-texture))) + (gl-texture-view alias + (match dimension + ('2d (texture-target texture-2d)) + ('3d (texture-target texture-3d-ext))) + (gl-texture-id (texture-handle texture)) + ;; TODO: Respect format + (pixel-internal-format rgba8) + base-mip-level mip-level-count + base-layer layer-count) + (%make-gl-texture-view alias)) + (error "texture view emulation for OpenGL <= 4.3 unimplemented"))) + +(define (gl-texture-view-destroy view) + (gl-delete-texture (gl-texture-view-id view))) + +(define (make-gl-sampler state address-mode-u address-mode-v address-mode-w + mag-filter min-filter mipmap-filter) + (if (gl-state-version>= state "3.3") + (%make-gl-sampler (gl-generate-sampler)) + (error "sampler emulation for OpenGL <= 3.3 unimplemented"))) + +(define (gl-sampler-destroy sampler) + (gl-delete-sampler (gl-sampler-id sampler))) + + +;;; +;;; Shaders +;;; + +(define (make-gl-shader-module state vertex-source fragment-source) + (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-meta-glsl-version (gl-state-meta 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 (set-shader-source shader source) + (let ((bv (string->utf8 (string-append header source)))) + (gl-shader-source shader 1 + (bytevector->pointer + (u64vector + (pointer-address (bytevector->pointer bv)))) + (bytevector->pointer + (u32vector (bytevector-length bv)))))) + (define (shader-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? shader) + (let ((status (make-u32vector 1))) + (gl-get-shaderiv shader + (version-2-0 compile-status) + (bytevector->pointer status)) + (= (u32vector-ref status 0) 1))) + (define (compile shader source) + (set-shader-source shader source) + (gl-compile-shader shader) + (unless (compiled? shader) + (let ((msg (shader-info-log shader))) + (gl-delete-shader shader) + (error (format #f "failed to compile shader: ~a" msg))))) + (define (make-shader source type) + (let ((shader (gl-create-shader type))) + (compile shader source) + (make-gl-shader shader))) + (gl-state-make-current! state) + (%make-gl-shader-module (make-shader vertex-source (version-2-0 vertex-shader)) + (make-shader fragment-source (version-2-0 fragment-shader)))) + +(define (gl-shader-module-destroy state module) + (gl-state-make-current! state) + (gl-delete-shader (gl-shader-module-vertex module)) + (gl-delete-shader (gl-shader-module-fragment module))) + +(define (make-gl-render-pipeline state vertex fragment primitive + depth-stencil multisample) + (define (program-info-log program) + (let ((log-length-bv (make-u32vector 1 0))) + (gl-get-shaderiv program (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 program log-length %null-pointer + (bytevector->pointer log)) + (utf8->string log)))) + (define (linked? program) + (let ((status (make-u32vector 1 0))) + (gl-get-programiv program (version-2-0 link-status) + (bytevector->pointer status)) + (= (u32vector-ref status 0) 1))) + (gl-state-make-current! state) + (let ((program (gl-create-program)) + (vertex* (gl-shader-id + (gl-shader-module-vertex + (shader-module-handle + (vertex-state-module vertex))))) + (fragment* (gl-shader-id + (gl-shader-module-fragment + (shader-module-handle + (fragment-state-module fragment)))))) + (gl-attach-shader program vertex*) + (gl-attach-shader program fragment*) + (gl-link-program program) + (gl-detach-shader program vertex*) + (gl-detach-shader program fragment*) + (unless (linked? program) + (let ((msg (program-info-log program))) + (gl-delete-program program) + (error (format #f "failed to link shader: ~a" msg)))) + (make-gl-program program))) + +(define (gl-render-pipeline-destroy state program) + (gl-state-make-current! state) + (gl-delete-program (gl-program-id program))) + +(define-gpu-backend opengl + make-gl-state + #:tick gl-state-tick + #:swap gl-state-swap + #:enqueue gl-state-enqueue + #:make-buffer make-gl-buffer + #:buffer-destroy gl-buffer-destroy + #:buffer-map gl-buffer-map + #:buffer-unmap gl-buffer-unmap + #:buffer-write gl-buffer-write + #:make-texture make-gl-texture + #:texture-destroy gl-texture-destroy + #:make-texture-view make-gl-texture-view + #:texture-view-destroy gl-texture-view-destroy + #:make-sampler make-gl-sampler + #:sampler-destroy gl-sampler-destroy + #:make-shader-module make-gl-shader-module + #:shader-module-destroy gl-shader-module-destroy + #:make-render-pipeline make-gl-render-pipeline + #:render-pipeline-destroy gl-render-pipeline-destroy) diff --git a/chickadee/graphics/gpu.scm b/chickadee/graphics/gpu.scm index 70cf5d8..ab9bb89 100644 --- a/chickadee/graphics/gpu.scm +++ b/chickadee/graphics/gpu.scm @@ -15,1692 +15,862 @@ ;;; Commentary: ;; -;; Abstraction over OpenGL state. +;; WebGPU-like abstract GPU interface. ;; ;;; Code: (define-module (chickadee graphics gpu) #:use-module (chickadee graphics color) - #:use-module (chickadee math rect) - #: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 (ice-9 threads) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) - #:use-module ((system foreign) - #:select (bytevector->pointer - pointer->bytevector - pointer->string - pointer-address - make-pointer - %null-pointer)) - #:export (blend-mode? - blend-mode-equation - blend-mode-source-function - blend-mode-destination-function - blend:alpha - blend:multiply - blend:subtract - blend:add - blend:lighten - blend:darken - blend:screen - blend:replace - - front-face? - front-face-winding - front-face:cw - front-face:ccw - - cull-face-mode? - cull-face-mode-front? - cull-face-mode-back? - cull-face:none - cull-face:back - cull-face:front - cull-face:front+back - - polygon-mode? - polygon-mode-front - polygon-mode-back - polygon:fill - polygon:line - polygon:point - - make-color-mask - color-mask? - color-mask-red? - color-mask-green? - color-mask-blue? - color-mask-alpha? - color-mask:all - color-mask:none - color-mask:red - color-mask:green - color-mask:blue - color-mask:alpha - - make-depth-test - depth-test? - depth-test-write? - depth-test-function - depth-test-near - depth-test-far - depth-test:default - - make-stencil-test - stencil-test? - stencil-test-mask-front - stencil-test-mask-back - stencil-test-function-front - stencil-test-function-back - stencil-test-function-mask-front - stencil-test-function-mask-back - stencil-test-reference-front - stencil-test-reference-back - stencil-test-on-fail-front - stencil-test-on-fail-back - stencil-test-on-depth-fail-front - stencil-test-on-depth-fail-back - stencil-test-on-pass-front - stencil-test-on-pass-back - stencil-test:default - - make-window-rect - window-rect? - window-rect-x - window-rect-y - window-rect-width - window-rect-height - window-rect:empty - - fresh-gpu-framebuffer - free-gpu-framebuffer - gpu-framebuffer? - gpu-framebuffer-id - gpu-framebuffer-init - gpu-framebuffer:null - - fresh-gpu-renderbuffer - free-gpu-renderbuffer - gpu-renderbuffer? - gpu-renderbuffer-id - gpu-renderbuffer:null - - fresh-gpu-buffer - free-gpu-buffer - gpu-buffer? - gpu-buffer-id - gpu-buffer-upload - gpu-buffer-map - gpu-buffer-unmap - gpu-buffer-target - gpu-buffer:null - - fresh-gpu-vertex-array - free-gpu-vertex-array - gpu-vertex-array? - gpu-vertex-array-id - gpu-vertex-array-apply-attribute - gpu-vertex-array:null - - fresh-gpu-texture - free-gpu-texture - gpu-texture? - gpu-texture-id - gpu-texture-target - gpu-texture-upload-2d - gpu-texture-upload-2d/sub - gpu-texture-copy-image - gpu-texture-generate-mipmap - gpu-texture-upload-cube-map-positive-x - gpu-texture-upload-cube-map-negative-x - gpu-texture-upload-cube-map-positive-y - gpu-texture-upload-cube-map-negative-y - gpu-texture-upload-cube-map-positive-z - gpu-texture-upload-cube-map-negative-z - set-gpu-texture-min-filter! - set-gpu-texture-mag-filter! - set-gpu-texture-wrap-r! - set-gpu-texture-wrap-s! - set-gpu-texture-wrap-t! - gpu-texture:null - - fresh-gpu-shader - free-gpu-shader - gpu-shader? - gpu-shader-id - gpu-shader-compiled? - gpu-shader-info-log - set-gpu-shader-source - gpu-shader-compile - gpu-shader:null - - fresh-gpu-program - free-gpu-program - gpu-program? - gpu-program-id - gpu-program-linked? - gpu-program-attach-shader - gpu-program-link - gpu-program-info-log - gpu-program-uniform-count - gpu-program-attribute-count - gpu-program-uniform-ref - gpu-program-attribute-ref - set-gpu-program-uniform:signed-int - set-gpu-program-uniform:unsigned-int - set-gpu-program-uniform:float - set-gpu-program-uniform:vec2 - set-gpu-program-uniform:vec3 - set-gpu-program-uniform:vec4 - set-gpu-program-uniform:mat3 - set-gpu-program-uniform:mat4 - gpu-program:null - - make-gpu - gpu? - gpu-gl-context - gpu-gl-version - gpu-glsl-version - gpu-max-texture-size - gpu-max-texture-units - gpu-front-face - gpu-blend-mode - gpu-cull-face-mode - gpu-polygon-mode - gpu-color-mask - gpu-depth-test - gpu-stencil-test - gpu-scissor-test - gpu-multisample? - gpu-seamless-cube-maps? - gpu-viewport - gpu-clear-color - gpu-framebuffer - gpu-renderbuffer - gpu-buffer - gpu-vertex-array - gpu-program - gpu-texture - set-gpu-front-face! - set-gpu-blend-mode! - set-gpu-cull-face-mode! - set-gpu-polygon-mode! - set-gpu-color-mask! - set-gpu-depth-test! - set-gpu-stencil-test! - set-gpu-scissor-test! - set-gpu-multisample! - set-gpu-seamless-cube-maps! - set-gpu-viewport! - set-gpu-clear-color! - set-gpu-framebuffer! - set-gpu-renderbuffer! - set-gpu-buffer! - set-gpu-vertex-array! - set-gpu-program! - set-gpu-texture! + #:use-module (srfi srfi-9 gnu) + #:export (make-gpu + gpu-tick + gpu-swap gpu-gc - gpu-reset! - gpu-clear-viewport - gpu-draw - gpu-draw/indexed - gpu-draw/instanced - gpu-draw/instanced+indexed)) + gpu-submit + current-gpu + define-gpu-backend + + make-buffer + buffer? + buffer-available? + buffer-destroyed? + buffer-mapped? + buffer-destroy! + buffer-map! + buffer-unmap! + bytevector->buffer + + make-texture + texture-destroy! + texture? + texture-gpu + texture-handle + texture-destroyed? + texture-width + texture-height + texture-layers + texture-mip-level-count + texture-sample-count + texture-dimension + texture-format + texture-usage + texture-view-formats + + make-texture-view + texture-view-destroy! + texture-view? + texture-view-gpu + texture-view-handle + texture-view-destroyed? + texture-view-texture + texture-view-format + texture-view-dimension + texture-view-aspect + texture-view-base-mip-level + texture-view-mip-level-count + texture-view-base-layer + texture-view-layer-count + + make-sampler + sampler-destroy! + sampler? + sampler-gpu + sampler-handle + sampler-destroyed? + sampler-address-mode-u + sampler-address-mode-v + sampler-address-mode-w + sampler-mag-filter + sampler-min-filter + sampler-mipmap-filter + + make-shader-module + shader-module? + shader-module-vertex + shader-module-fragment + + make-vertex-attribute + vertex-attribute? + vertex-attribute-location + vertex-attribute-format + vertex-attribute-offset + + make-vertex-buffer-layout + vertex-buffer-layout? + vertex-buffer-layout-stride + vertex-buffer-layout-step-mode + vertex-buffer-layout-attributes + + make-vertex-state + vertex-state? + vertex-state-module + vertex-state-buffers + + make-blend-component + blend-component? + blend-component-operation + blend-component-src-factor + blend-component-dst-factor + + make-blend-state + blend-state? + blend-state-color + blend-state-alpha + + make-color-target-state + color-target-state? + color-target-state-format + color-target-state-blend + color-target-state-write-mask + + make-fragment-state + fragment-state? + fragment-state-module + fragment-state-targets + + make-primitive-state + primitive-state? + primitive-state-topology + primitive-state-front-face + primitive-state-cull-mode + primitive-state-unclipped-depth? + + make-stencil-face-state + stencil-face-state? + stencil-face-state-compare + stencil-face-state-fail-op + stencil-face-state-depth-fail-op + stencil-face-state-pass-op + + make-depth-stencil-format + depth-stencil-format? + depth-stencil-state-format + depth-stencil-state-depth-write-enabled? + depth-stencil-state-compare-function + depth-stencil-state-stencil-front + depth-stencil-state-stencil-back + depth-stencil-state-stencil-read-mask + depth-stencil-state-stencil-write-mask + + make-multisample-state + multisample-state? + multisample-state-count + multisample-state-mask + multisample-state-alpha-to-coverage? + + make-render-pipeline + render-pipeline? + render-pipeline-vertex + render-pipeline-fragment + render-pipeline-primitive + render-pipeline-depth-stencil + render-pipeline-multisample + + make-color-attachment + color-attachment? + color-attachment-view + color-attachment-resolve-target + color-attachment-clear-color + color-attachment-load-op + color-attachment-store-op + + make-depth-stencil-attachment + depth-stencil-attachment? + depth-stencil-attachment-view + depth-stencil-attachment-depth-clear-value + depth-stencil-attachment-depth-load-op + depth-stencil-attachment-depth-store-op + depth-stencil-attachment-depth-read-only? + depth-stencil-attachment-stencil-clear-value + depth-stencil-attachment-stencil-load-op + depth-stencil-attachment-stencil-store-op + depth-stencil-attachment-stencil-read-only? + + make-render-pass-descriptor + render-pass-descriptor? + render-pass-descriptor?-color-attachments + render-pass-descriptor?-depth-stencil-attachment + render-pass-descriptor?-max-draw-count + + render-state? + render-state-pipeline + render-state-vertex-buffers + + command-buffer? + command-buffer-commands + + make-command-encoder + command-encoder? + command-encoder-finish + begin-render-pass + + render-pass-encoder? + render-pass-encoder-pipeline + render-pass-encoder-vertex-buffers + set-render-pass-encoder-pipeline! + set-render-pass-encoder-vertex-buffer! + render-pass-draw + end-render-pass)) + +(define-syntax-rule (define-record-type* name + make pred + (field accessor default) ...) + (begin + (define-record-type name + (%make field ...) + pred + (field accessor) ...) + (define* (make #:key (field default) ...) + (%make field ...)))) ;;; -;;; Additional OpenGL wrappers +;;; Generic GPU ;;; -(define gl-clear-color %glClearColor) -(define gl-scissor %glScissor) -(define gl-blend-func %glBlendFunc) -(define gl-blend-equation %glBlendEquation) -(define gl-texture-image-3d %glTexImage3D) -(define gl-texture-image-2d %glTexImage2D) -(define gl-texture-image-1d %glTexImage1D) -(define gl-copy-texture-image-2d %glCopyTexImage2D) -(define gl-copy-texture-image-1d %glCopyTexImage1D) -(define gl-copy-texture-sub-image-3d %glCopyTexSubImage3D) -(define gl-copy-texture-sub-image-2d %glCopyTexSubImage2D) -(define gl-copy-texture-sub-image-1d %glCopyTexSubImage1D) -(define gl-texture-sub-image-3d %glTexSubImage3D) -(define gl-texture-sub-image-2d %glTexSubImage2D) -(define gl-texture-sub-image-1d %glTexSubImage1D) -(define gl-compressed-texture-image-1d %glCompressedTexImage1D) -(define gl-compressed-texture-image-2d %glCompressedTexImage2D) -(define gl-compressed-texture-image-3d %glCompressedTexImage3D) -(define gl-compressed-texture-sub-image-1d %glCompressedTexSubImage1D) -(define gl-compressed-texture-sub-image-2d %glCompressedTexSubImage2D) -(define gl-compressed-texture-sub-image-3d %glCompressedTexSubImage3D) -(define gl-texture-parameter %glTexParameteri) -(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-use-program %glUseProgram) -(define gl-delete-program %glDeleteProgram) -(define gl-detach-shader %glDetachShader) -(define gl-link-program %glLinkProgram) -(define gl-bind-attrib-location %glBindAttribLocation) -(define gl-attach-shader %glAttachShader) -(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-uniform4f %glUniform4f) -(define gl-point-size %glPointSize) -(define gl-get-string %glGetString) -(define gl-get-integer-v %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 (glGenerateMipmap (target GLenum) -> void) - "Generate mipmaps for the texture attached to target of the active -texture unit.") - -(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 (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 (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-generate-mipmap glGenerateMipmap) -(define gl-draw-arrays-instanced glDrawArraysInstanced) -(define gl-draw-elements-instanced glDrawElementsInstanced) -(define gl-vertex-attrib-divisor glVertexAttribDivisor) -(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-delete-framebuffer glDeleteFramebuffers) -(define gl-bind-framebuffer glBindFramebuffer) -(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-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-syntax-rule (define-gpu-type name make pred + (mutex mutex-accessor) + (guardian guardian-accessor) + (internal internal-accessor) + (vfield vfield-accessor + (vfield-dispatch vfield-dispatch-args ...)) + ...) + (begin + (define-record-type name + (%make mutex guardian internal vfield ...) + pred + (mutex mutex-accessor) + (guardian guardian-accessor) + (internal internal-accessor) + (vfield vfield-accessor) ...) + (define* (make internal #:key vfield ...) + (%make (make-recursive-mutex) (make-guardian) internal vfield ...)) + (define (vfield-dispatch gpu vfield-dispatch-args ...) + (with-mutex (mutex-accessor gpu) + ((vfield-accessor gpu) + (internal-accessor gpu) + vfield-dispatch-args ...))) + ...)) + +(define-gpu-type + %make-gpu + gpu? + (mutex gpu-mutex) + (guardian gpu-guardian) + (internal gpu-internal) + (tick %gpu-tick (gpu-tick)) + (swap %gpu-swap (gpu-swap)) + (enqueue %gpu-enqueue (backend:enqueue command-buffer)) + (make-buffer %gpu-make-buffer + (backend:make-buffer length usage)) + (buffer-destroy %gpu-buffer-destroy + (backend:buffer-destroy buffer)) + (buffer-map %gpu-buffer-map + (backend:buffer-map buffer mode offset sizes)) + (buffer-unmap %gpu-buffer-unmap + (backend:buffer-unmap buffer)) + (buffer-write %gpu-buffer-write + (backend:buffer-write buffer buffer-offset data data-offset + length)) + (make-texture %gpu-make-texture + (backend:make-texture width height depth mip-level-count + sample-count dimension format usage + view-formats)) + (texture-destroy %gpu-texture-destroy (backend:texture-destroy texture)) + (make-texture-view %gpu-make-texture-view + (backend:make-texture-view texture format dimension aspect + base-mip-level mip-level-count + base-depth depth)) + (texture-view-destroy %gpu-texture-view-destroy + (backend:texture-view-destroy view)) + (make-sampler %gpu-make-sampler + (backend:make-sampler address-mode-u address-mode-v + address-mode-w mag-filter min-filter + mipmap-filter)) + (sampler-destroy %gpu-sampler-destroy (backend:sampler-destroy module)) + (make-shader-module %gpu-make-shader-module + (backend:make-shader-module vertex-source fragment-source)) + (shader-module-destroy %gpu-shader-module-destroy + (backend:shader-module-destroy module)) + (make-render-pipeline %gpu-make-render-pipeline + (backend:make-render-pipeline vertex fragment + primitive depth-stencil + multisample)) + (render-pipeline-destroy %gpu-render-pipeline-destroy + (backend:render-pipeline-destroy pipeline))) + +(define (gpu-guard! gpu obj) + ((gpu-guardian gpu) obj)) + +(define *gpu-backends* (make-hash-table)) + +(define (gpu-backend-ref name) + (hashq-ref *gpu-backends* name)) + +(define (gpu-backend-set! name proc) + (hashq-set! *gpu-backends* name proc)) + +(define-syntax-rule (define-gpu-backend name + internal-constructor + args ...) + (gpu-backend-set! 'name + (lambda (window context) + (%make-gpu (internal-constructor window context) + args ...)))) + +(define current-gpu (make-parameter #f)) + +;; TODO: Respect the args according to WebGPU spec. +;; +;; TODO: Platform detection + open SDL window with proper GL, Vulkan, +;; or Metal flag. Forcing OpenGL for now. +(define* (make-gpu window context #:key + power-preference + (required-features '()) + (required-limits '())) + ;; Include module at runtime to avoid circular reference. + ;; + ;; TODO: Programatically discover backend modules, load them, and + ;; pick the "best" one. + (module-use! (current-module) + (resolve-interface + '(chickadee graphics backend opengl))) + ((gpu-backend-ref 'opengl) window context)) ;;; -;;; GPU settings +;;; Buffers ;;; -(define-syntax symbol->enum - (syntax-rules () - ((_ (x enum)) (error "symbol->enum: no match for" x)) - ((_ (x enum) (sym name override-enum) . rest) - (if (eq? x 'sym) (override-enum name) (symbol->enum (x enum) . rest))) - ((_ (x enum) (sym name) . rest) - (if (eq? x 'sym) (enum name) (symbol->enum (x enum) . rest))) - ((_ (x enum) (sym) . rest) - (symbol->enum (x enum) (sym sym) . rest)))) - -(define-syntax enum->symbol - (syntax-rules () - ((_ (n enum)) (error "enum->symbol: no match for" n)) - ((_ (n enum) (sym name override-enum) . rest) - (if (eqv? n (override-enum name)) 'sym (enum->symbol (n enum) . rest))) - ((_ (n enum) (sym name) . rest) - (if (eqv? n (enum name)) 'sym (enum->symbol (n enum) . rest))) - ((_ (n enum) (name) . rest) - (enum->symbol (n enum) (name name) . rest)))) - -(define-syntax-rule (define-enum-converters enum ->enum ->symbol clause ...) - (begin - (define (->enum sym) - (symbol->enum (sym enum) clause ...)) - (define (->symbol n) - (enum->symbol (n enum) clause ...)))) - -(define-syntax-rule (define-config-type name - constructor - pred - ((raw-field raccessor) ...) - ((enum-field %eaccessor eaccessor ->gl ->scheme) ...)) - (begin - (define-record-type name - (%make raw-field ... enum-field ...) - pred - (raw-field raccessor) ... - (enum-field %eaccessor) ...) - (define (constructor raw-field ... enum-field ...) - (%make raw-field ... (->gl enum-field) ...)) - (define (eaccessor obj) - (->scheme (%eaccessor obj))) - ...)) +(define-record-type + (%make-buffer gpu handle length usage state map-state) + buffer? + (gpu buffer-gpu) + (handle buffer-handle) + (length buffer-length) + (usage buffer-usage) + (state buffer-state set-buffer-state!) + (map-state buffer-map-state set-buffer-map-state!) + (mapping buffer-mapping set-buffer-mapping!)) + +(define (print-buffer buffer port) + (match buffer + (($ _ handle length usage) + (format #t "#" + handle length usage)))) + +(set-record-type-printer! print-buffer) + +(define (buffer-available? buffer) + (eq? (buffer-state buffer) 'available)) + +(define (buffer-destroyed? buffer) + (eq? (buffer-state buffer) 'destroyed)) + +(define (buffer-mapped? buffer) + (eq? (buffer-map-state buffer) 'mapped)) + +;; TODO: Validate length is > 0 and < max length. +;; TODO: Validate usage flags. +(define* (make-buffer gpu length #:optional (usage '(vertex))) + (let ((handle (backend:make-buffer gpu length usage))) + (%make-buffer gpu handle length usage 'available 'unmapped))) + +;; TODO: Ensure buffer is unmapped first. +(define (buffer-destroy! buffer) + (unless (buffer-destroyed? buffer) + (backend:buffer-destroy (buffer-gpu buffer) (buffer-handle buffer)) + (set-buffer-state! buffer 'destroyed))) + +(define (buffer-map! buffer mode offset size) + (backend:buffer-map (buffer-gpu buffer) (buffer-handle buffer) + mode offset size)) + +(define (buffer-unmap! buffer) + (when (buffer-mapped? buffer) + (backend:buffer-unmap (buffer-gpu buffer) (buffer-handle buffer)) + (set-buffer-mapping! buffer #f))) + +(define* (bytevector->buffer gpu bv #:optional (usage '(vertex))) + (let* ((length (bytevector-length bv)) + (buffer (make-buffer gpu length usage))) + (backend:buffer-write gpu (buffer-handle buffer) 0 bv 0 (bytevector-length bv)) + buffer)) + + +;;; +;;; Textures +;;; -(define-enum-converters begin-mode - symbol->begin-mode - begin-mode->symbol - (points) - (lines) - (line-loop) - (line-strip) - (triangles) - (triangle-strip) - (triangle-fan)) - -(define-enum-converters data-type - symbol->data-type - data-type->symbol - (byte) - (unsigned-byte) - (short) - (unsigned-short) - (int) - (unsigned-int) - (float) - (double)) - -(define (symbol->buffer-target target) - (match target - ('vertex (version-1-5 array-buffer)) - ('index (version-1-5 element-array-buffer)))) - -(define (symbol->buffer-usage usage) - (match usage - ('static (version-1-5 static-draw)) - ('stream (version-1-5 stream-draw)))) - -(define (symbol->access-mode mode) - (match mode - ('read-write (version-1-5 read-write)) - ('read-only (version-1-5 read-only)) - ('write-only (version-1-5 write-only)))) - -(define-enum-converters texture-min-filter - symbol->texture-min-filter - texture-min-filter->symbol - (nearest) - (linear) - (nearest-mipmap-nearest) - (linear-mipmap-nearest) - (nearest-mipmap-linear) - (linear-mipmap-linear)) - -(define-enum-converters texture-mag-filter - symbol->texture-mag-filter - texture-mag-filter->symbol - (nearest) - (linear)) - -(define (symbol->texture-target target) - (match target - ('2d (texture-target texture-2d)) - ('cube-map (version-1-3 texture-cube-map)))) - -(define (symbol->texture-wrap-mode mode) - (match mode - ('repeat (texture-wrap-mode repeat)) - ('mirrored-repeat (version-1-4 mirrored-repeat)) - ('clamp (texture-wrap-mode clamp)) - ('clamp-to-border (texture-wrap-mode clamp-to-border-sgis)) - ('clamp-to-edge (texture-wrap-mode clamp-to-edge-sgis)))) - -(define-enum-converters pixel-format - symbol->pixel-format - pixel-format->symbol - (rgb) - (rgba)) - -(define-enum-converters blend-equation-mode-ext - symbol->blend-equation - blend-equation->symbol - (add func-add-ext) - (subtract func-subtract-ext) - (reverse-subtract func-reverse-subtract-ext) - (min min-ext) - (max max-ext) - (alpha-min alpha-min-sgix) - (alpha-max alpha-max-sgix)) - -(define-enum-converters blending-factor-src - symbol->blend-factor-source - blend-factor-source->symbol - (zero) - (one) - (destination-color dst-color) - (one-minus-destination-color one-minus-dst-color) - (source-alpha-saturate src-alpha-saturate) - (source-alpha src-alpha) - (one-minus-source-alpha one-minus-src-alpha) - (destination-alpha dst-alpha) - (one-minus-destination-alpha one-minus-dst-alpha) - (constant-color constant-color-ext) - (one-minus-constant-color one-minus-constant-color-ext) - (contstant-alpha constant-alpha-ext) - (one-minus-constant-alpha one-minus-constant-alpha-ext)) - -(define-enum-converters blending-factor-dest - symbol->blend-factor-destination - blend-factor-destination->symbol - (zero) - (one) - (source-color src-color) - (one-minus-source-color one-minus-src-color) - (source-alpha src-alpha) - (one-minus-source-alpha one-minus-src-alpha) - (destination-alpha dst-alpha) - (one-minus-destination-alpha one-minus-dst-alpha) - (constant-color constant-color-ext) - (one-minus-constant-color one-minus-constant-color-ext) - (contstant-alpha constant-alpha-ext) - (one-minus-constant-alpha one-minus-constant-alpha-ext)) - -(define-config-type - make-blend-mode - blend-mode? - () - ((equation %blend-mode-equation - blend-mode-equation - symbol->blend-equation - blend-equation->symbol) - (source %blend-mode-source-function - blend-mode-source-function - symbol->blend-factor-source - blend-factor-source->symbol) - (destination %blend-mode-destination-function - blend-mode-destination-function - symbol->blend-factor-destination - blend-factor-destination->symbol))) - -(define (bind-blend-mode blend-mode) - (match blend-mode - (#f (gl-disable (enable-cap blend))) - (($ equation src dest) - (gl-enable (enable-cap blend)) - (gl-blend-equation equation) - (gl-blend-func src dest)))) - -(define blend:alpha (make-blend-mode 'add 'source-alpha 'one-minus-source-alpha)) -(define blend:multiply (make-blend-mode 'add 'destination-color 'zero)) -(define blend:subtract (make-blend-mode 'reverse-subtract 'one 'zero)) -(define blend:add (make-blend-mode 'add 'one 'one)) -(define blend:lighten (make-blend-mode 'max 'one 'zero)) -(define blend:darken (make-blend-mode 'min 'one 'zero)) -(define blend:screen (make-blend-mode 'add 'one 'one-minus-source-color)) -(define blend:replace (make-blend-mode 'add 'one 'zero)) - -(define-enum-converters front-face-direction - symbol->front-face-direction - front-face-direction->symbol - (cw) - (ccw)) - -(define-config-type - make-front-face - front-face - () - ((winding %front-face-winding - front-face-winding - symbol->front-face-direction - front-face-direction->symbol))) - -(define (bind-front-face front-face) - (gl-front-face (%front-face-winding front-face))) - -(define front-face:cw (make-front-face 'cw)) -(define front-face:ccw (make-front-face 'ccw)) - -(define-config-type - make-cull-face-mode - cull-face-mode? - ((front? cull-face-mode-front?) - (back? cull-face-mode-back?)) - ()) - -(define (bind-cull-face-mode mode) - (match mode - (($ #t #t) - (gl-enable (enable-cap cull-face)) - (gl-cull-face (cull-face-mode front-and-back))) - (($ #t #f) - (gl-enable (enable-cap cull-face)) - (gl-cull-face (cull-face-mode front))) - (($ #f #t) - (gl-enable (enable-cap cull-face)) - (gl-cull-face (cull-face-mode back))) - (_ - (gl-disable (enable-cap cull-face))))) - -(define cull-face:none (make-cull-face-mode #f #f)) -(define cull-face:back (make-cull-face-mode #f #t)) -(define cull-face:front (make-cull-face-mode #t #f)) -(define cull-face:front+back (make-cull-face-mode #t #t)) - -(define-enum-converters polygon-mode - symbol->polygon-mode - polygon-mode->symbol - (fill) - (line) - (point)) - -(define-config-type - make-polygon-mode - polygon-mode? - () - ((front %polygon-mode-front - polygon-mode-front - symbol->polygon-mode - polygon-mode->symbol) - (back %polygon-mode-back - polygon-mode-back - symbol->polygon-mode - polygon-mode->symbol))) - -(define (bind-polygon-mode mode) - (match mode - (($ front back) - (if (= front back) - (gl-polygon-mode (cull-face-mode front-and-back) front) - (begin - (gl-polygon-mode (cull-face-mode front) front) - (gl-polygon-mode (cull-face-mode back) back)))))) - -(define polygon:fill (make-polygon-mode 'fill 'fill)) -(define polygon:line (make-polygon-mode 'line 'line)) -(define polygon:point (make-polygon-mode 'point 'point)) - -(define-config-type - make-color-mask - color-mask? - ((red? color-mask-red?) - (green? color-mask-green?) - (blue? color-mask-blue?) - (alpha? color-mask-alpha?)) - ()) - -(define (bind-color-mask mask) - (gl-color-mask (color-mask-red? mask) - (color-mask-green? mask) - (color-mask-blue? mask) - (color-mask-alpha? mask))) - -(define color-mask:all (make-color-mask #t #t #t #t)) -(define color-mask:none (make-color-mask #f #f #f #f)) -(define color-mask:red (make-color-mask #t #f #f #f)) -(define color-mask:green (make-color-mask #f #t #f #f)) -(define color-mask:blue (make-color-mask #f #f #t #f)) -(define color-mask:alpha (make-color-mask #f #f #f #t)) - -(define-enum-converters depth-function - symbol->depth-function - depth-function->symbol - (always) - (never) - (= equal) - (!= notequal) - (< less) - (<= lequal) - (> greater) - (>= gequal)) - -(define-config-type - %make-depth-test - depth-test? - ((near depth-test-near) - (far depth-test-far) - (write? depth-test-write?)) - ((function %depth-test-function - depth-test-function - symbol->depth-function - depth-function->symbol))) - -(define* (make-depth-test #:key (near 0.0) (far 1.0) (write? #t) (function '<)) - (%make-depth-test near far write? function)) - -(define (bind-depth-test depth-test) - (match depth-test - (#f (gl-disable (enable-cap depth-test))) - (($ near far write? func) - (gl-enable (enable-cap depth-test)) - (gl-depth-func func) - (gl-depth-mask write?) - (gl-depth-range near far)))) - -(define depth-test:default (make-depth-test)) - -(define-enum-converters stencil-op - symbol->stencil-op - stencil-op->symbol - (zero) - (keep) - (replace) - (invert) - (increment incr) - (decrement decr) - (increment-wrap incr-wrap version-1-4) - (decrement-wrap decr-wrap version-1-4)) - -(define-enum-converters stencil-function - symbol->stencil-function - stencil-function->symbol - (always) - (never) - (= equal) - (!= notequal) - (< less) - (<= lequal) - (> greater) - (>= gequal)) - -(define-config-type - %make-stencil-test - stencil-test? - ((mask-front stencil-test-mask-front) - (mask-back stencil-test-mask-back) - (function-mask-front stencil-test-function-mask-front) - (function-mask-back stencil-test-function-mask-back) - (reference-front stencil-test-reference-front) - (reference-back stencil-test-reference-back)) - ((function-front %stencil-test-function-front - stencil-test-function-front - symbol->stencil-function - stencil-function->symbol) - (function-back %stencil-test-function-back - stencil-test-function-back - symbol->stencil-function - stencil-function->symbol) - (on-fail-front %stencil-test-on-fail-front - stencil-test-on-fail-front - symbol->stencil-op - stencil-op->symbol) - (on-fail-back %stencil-test-on-fail-back - stencil-test-on-fail-back - symbol->stencil-op - stencil-op->symbol) - (on-depth-fail-front %stencil-test-on-depth-fail-front - stencil-test-on-depth-fail-front - symbol->stencil-op - stencil-op->symbol) - (on-depth-fail-back %stencil-test-on-depth-fail-back - stencil-test-on-depth-fail-back - symbol->stencil-op - stencil-op->symbol) - (on-pass-front %stencil-test-on-pass-front - stencil-test-on-pass-front - symbol->stencil-op - stencil-op->symbol) - (on-pass-back %stencil-test-on-pass-back - stencil-test-on-pass-back - symbol->stencil-op - stencil-op->symbol))) - -(define* (make-stencil-test #:key (mask #xff) (function 'always) - (function-mask #xff) (reference 0) - (on-fail 'keep) (on-depth-fail 'keep) (on-pass 'keep) - (mask-front mask) (mask-back mask) - (function-front function) (function-back function) - (function-mask-front function-mask) - (function-mask-back function-mask) - (reference-front reference) - (reference-back reference) - (on-fail-front on-fail) (on-fail-back on-fail) - (on-depth-fail-front on-depth-fail) - (on-depth-fail-back on-depth-fail) - (on-pass-front on-pass) (on-pass-back on-pass)) - (%make-stencil-test mask-front mask-back - function-mask-front function-mask-back - reference-front reference-back - function-front function-back - on-fail-front on-fail-back - on-depth-fail-front on-depth-fail-back - on-pass-front on-pass-back)) - -(define (bind-stencil-test stencil-test) - (match stencil-test - (#f (gl-disable (enable-cap stencil-test))) - (($ mask-front mask-back - function-mask-front function-mask-back - reference-front reference-back - function-front function-back - on-fail-front on-fail-back - on-depth-fail-front on-depth-fail-back - on-pass-front on-pass-back) - (gl-enable (enable-cap stencil-test)) - ;; Mask - (gl-stencil-mask-separate (cull-face-mode front) mask-front) - (gl-stencil-mask-separate (cull-face-mode back) mask-back) - ;; Function - (gl-stencil-func-separate (cull-face-mode front) - function-front reference-front mask-front) - (gl-stencil-func-separate (cull-face-mode back) - function-back reference-back mask-back) - ;; Operation - (gl-stencil-op-separate (cull-face-mode front) - on-fail-front on-depth-fail-front on-pass-front) - (gl-stencil-op-separate (cull-face-mode back) - on-fail-back on-depth-fail-back on-pass-back)))) - -(define stencil-test:default (make-stencil-test)) - -(define (bind-multisample multisample?) - (if multisample? - (gl-enable (version-1-3 multisample)) - (gl-disable (version-1-3 multisample)))) - -(define (bind-seamless-cube-maps seamless-cube-maps?) - (if seamless-cube-maps? - (gl-enable (version-3-2 texture-cube-map-seamless)) - (gl-disable (version-3-2 texture-cube-map-seamless)))) - -(define (bind-clear-color color) - (gl-clear-color (color-r color) - (color-g color) - (color-b color) - (color-a color))) - -(define-record-type - (make-window-rect x y width height) - window-rect? - (x window-rect-x) - (y window-rect-y) - (width window-rect-width) - (height window-rect-height)) - -(define window-rect:empty (make-window-rect 0 0 0 0)) - -(define (bind-scissor-test rect) - (match rect - (#f (gl-disable (enable-cap scissor-test))) - (($ x y width height) - (gl-enable (enable-cap scissor-test)) - (gl-scissor x y width height)))) - -(define (bind-viewport rect) - (match rect - (($ x y width height) - (gl-viewport x y width height)))) +(define-record-type + (%make-texture gpu handle destroyed? width height layers mip-level-count + sample-count dimension format usage view-formats) + texture? + (gpu texture-gpu) + (handle texture-handle) + (destroyed? texture-destroyed? set-texture-destroyed!) + (width texture-width) + (height texture-height) + (layers texture-layers) + (mip-level-count texture-mip-level-count) + (sample-count texture-sample-count) + (dimension texture-dimension) + (format texture-format) + (usage texture-usage) + (view-formats texture-view-formats)) + +(define (print-texture texture port) + (match texture + (($ _ handle _ width height layers _ _ dimension format* usage) + (format #t "#" + handle width height layers dimension format* usage)))) + +(set-record-type-printer! print-texture) + +(define* (make-texture gpu #:key + (width 1) + (height 1) + (layers 0) + (mip-level-count 1) + (sample-count 1) + (dimension '2d) + format usage + (view-formats '())) + (let ((handle (backend:make-texture gpu width height layers mip-level-count + sample-count dimension format usage + view-formats))) + (%make-texture gpu handle #f width height layers mip-level-count + sample-count dimension format usage view-formats))) + +(define (texture-destroy! texture) + (unless (texture-destroyed? texture) + (backend:texture-destroy (texture-gpu texture) (texture-handle texture)) + (set-texture-destroyed! texture #t))) + +(define-record-type + (%make-texture-view gpu handle destroyed? texture format dimension aspect + base-mip-level mip-level-count base-layer layer-count) + texture-view? + (gpu texture-view-gpu) + (handle texture-view-handle) + (destroyed? texture-view-destroyed? set-texture-view-destroyed!) + (texture texture-view-texture) + (format texture-view-format) + (dimension texture-view-dimension) ; 2d or 3d + (aspect texture-view-aspect) ; all, stencil-only, depth-only + (base-mip-level texture-view-base-mip-level) + (mip-level-count texture-view-mip-level-count) + (base-layer texture-view-base-layer) + (layer-count texture-view-layer-count)) + +(define (print-texture-view view port) + (match view + (($ _ handle _ texture format* dimension) + (format #t "#" + handle texture format* dimension)))) + +(set-record-type-printer! print-texture-view) + +(define* (make-texture-view gpu texture #:key + format + (dimension '2d) + (aspect 'all) + (base-mip-level 0) + (mip-level-count 0) + (base-layer 0) + (layer-count 0)) + (let ((handle (backend:make-texture-view gpu texture format dimension aspect + base-mip-level mip-level-count + base-layer layer-count))) + (%make-texture-view gpu handle #f texture format dimension aspect + base-mip-level mip-level-count base-layer layer-count))) + +(define (texture-view-destroy! view) + (unless (texture-view-destroyed? view) + (backend:texture-view-destroy (texture-view-gpu view) + (texture-view-handle view)) + (set-texture-view-destroyed! view #t))) + +;; TODO: lod, compare, anisotropy. +(define-record-type + (%make-sampler gpu handle destroyed? + address-mode-u address-mode-v address-mode-w + mag-filter min-filter mipmap-filter) + sampler? + (gpu sampler-gpu) + (handle sampler-handle) + (destroyed? sampler-destroyed? set-sampler-destroyed!) + ;; clamp-to-edge, repeat, or mirror-repeat + (address-mode-u sampler-address-mode-u) + (address-mode-v sampler-address-mode-v) + (address-mode-w sampler-address-mode-w) + ;; nearest or linear + (mag-filter sampler-mag-filter) + (min-filter sampler-min-filter) + (mipmap-filter sampler-mipmap-filter)) + +(define (print-sampler view port) + (match view + (($ _ handle _ u v w mag min mip) + (format #t "#" + handle u v w mag min mip)))) + +(set-record-type-printer! print-sampler) + +(define* (make-sampler gpu #:key + (address-mode-u 'clamp-to-edge) + (address-mode-v 'clamp-to-edge) + (address-mode-w 'clamp-to-edge) + (mag-filter 'nearest) + (min-filter 'nearest) + (mipmap-filter 'nearest)) + (let ((handle (backend:make-sampler gpu address-mode-u address-mode-v + address-mode-w mag-filter min-filter + mipmap-filter))) + (%make-sampler gpu handle #f address-mode-u address-mode-v + address-mode-w mag-filter min-filter + mipmap-filter))) + +(define (sampler-destroy! sampler) + (unless (sampler-destroyed? sampler) + (backend:sampler-destroy (sampler-gpu sampler) (sampler-handle sampler)) + (set-sampler-destroyed! sampler #t))) ;;; -;;; GPU objects +;;; Shader modules ;;; -(define-syntax-rule (define-gpu-type name - (constructor (cparams ...) cargs ...) - (free free-exp) - (bind bind-exp) - (null null-args ...) - pred - (field accessor) ...) - (begin - (define-record-type name - (%make field ... deleted?) - pred - (field accessor) ... - (deleted? %deleted? %set-deleted!)) - (define (constructor cparams ...) - (%make cargs ... #f)) - (define null (%make null-args ... #f)) - (define (free obj) - (match obj - (($ name field ... deleted?) - (unless deleted? - free-exp - (%set-deleted! obj #t))))) - (define (bind obj) - (match obj - (($ name field ... deleted?) - (if deleted? - (error "GPU object has been deleted" obj) - bind-exp)))))) - -(define-gpu-type - (make-gpu-framebuffer () (gl-generate-framebuffer)) - (free-gpu-framebuffer (gl-delete-framebuffer id)) - (bind-gpu-framebuffer (gl-bind-framebuffer (version-3-0 framebuffer) id)) - (gpu-framebuffer:null 0) - gpu-framebuffer? - (id gpu-framebuffer-id)) - -(define-gpu-type - (make-gpu-renderbuffer () (gl-generate-renderbuffer)) - (free-gpu-renderbuffer (gl-delete-renderbuffer id)) - (bind-gpu-renderbuffer (gl-bind-renderbuffer (version-3-0 renderbuffer) id)) - (gpu-renderbuffer:null 0) - gpu-renderbuffer? - (id gpu-renderbuffer-id)) - -(define-gpu-type - (make-gpu-buffer (target usage) - (gl-generate-buffer) - (symbol->buffer-target target) - (symbol->buffer-usage usage) - (and (eq? usage 'stream) (make-hash-table))) - (free-gpu-buffer (gl-delete-buffer id)) - (bind-gpu-buffer (gl-bind-buffer target id)) - (gpu-buffer:null 0 (symbol->buffer-target 'vertex) - (symbol->buffer-usage 'static) #f) - gpu-buffer? - (id gpu-buffer-id) - (target gpu-buffer-target) - (usage gpu-buffer-usage) - (stream-cache gpu-buffer-stream-cache)) - -(define-gpu-type - (make-gpu-vertex-array () (gl-generate-vertex-array)) - (free-gpu-vertex-array (gl-delete-vertex-array id)) - (bind-gpu-vertex-array (gl-bind-vertex-array id)) - (gpu-vertex-array:null 0) - gpu-vertex-array? - (id gpu-vertex-array-id)) - -(define-gpu-type - (make-gpu-texture (target) - (gl-generate-texture) - (symbol->texture-target target)) - (free-gpu-texture (gl-delete-texture id)) - (bind-gpu-texture (gl-bind-texture target id)) - (gpu-texture:null 0 (texture-target texture-2d)) - gpu-texture? - (id gpu-texture-id) - (target gpu-texture-target)) - -(define-gpu-type - (make-gpu-shader (type) - (gl-create-shader - (match type - ('vertex (version-2-0 vertex-shader)) - ('fragment (version-2-0 fragment-shader))))) - (free-gpu-shader (gl-delete-shader id)) - ;; Shaders are not bound but rather attached to a program, which is - ;; bound, so this is a stub. - (bind-gpu-shader #t) - (gpu-shader:null 0) - gpu-shader? - (id gpu-shader-id)) - -(define-gpu-type - (make-gpu-program () (gl-create-program)) - (free-gpu-program (gl-delete-program id)) - (bind-gpu-program (gl-use-program id)) - (gpu-program:null 0) - gpu-program? - (id gpu-program-id)) +(define-record-type + (%make-shader-module gpu handle state) + shader-module? + (gpu shader-module-gpu) + (handle shader-module-handle) + (state shader-module-state set-shader-module-state!)) + +(define (print-shader-module shader port) + (match shader + (($ _ handle) + (format #t "#" handle)))) + +(set-record-type-printer! print-shader-module) + +(define (shader-module-available? shader-module) + (eq? (shader-module-state shader-module) 'available)) + +(define (shader-module-destroyed? shader-module) + (eq? (shader-module-state shader-module) 'destroyed)) + +(define* (make-shader-module gpu #:key vertex-source fragment-source) + (let ((handle (backend:make-shader-module gpu vertex-source fragment-source))) + (%make-shader-module gpu handle 'available))) + +(define (shader-module-destroy! module) + (unless (shader-module-destroyed? module) + (backend:shader-module-destroy (shader-module-gpu module) + (shader-module-handle module)) + (set-shader-module-state! module 'destroyed))) ;;; -;;; State management +;;; Render pipelines ;;; -;; An abstraction over the annoying OpenGL context state. Minimizes -;; GPU calls by keeping a local cache. -(define-record-type - (%make-gpu gl-context gl-version glsl-version max-texture-size - max-texture-units guardian textures) - gpu? - ;; Metadata: - (gl-context gpu-gl-context) - (gl-version gpu-gl-version) - (glsl-version gpu-glsl-version) - (max-texture-size gpu-max-texture-size) - (max-texture-units gpu-max-texture-units) - ;; GC integration for GPU data. - (guardian gpu-guardian) - ;; OpenGL state: - (front-face gpu-front-face %set-gpu-front-face!) - (blend-mode gpu-blend-mode %set-gpu-blend-mode!) - (cull-face-mode gpu-cull-face-mode %set-gpu-cull-face-mode!) - (polygon-mode gpu-polygon-mode %set-gpu-polygon-mode!) - (color-mask gpu-color-mask %set-gpu-color-mask!) - (depth-test gpu-depth-test %set-gpu-depth-test!) - (stencil-test gpu-stencil-test %set-gpu-stencil-test!) - (scissor-test gpu-scissor-test %set-gpu-scissor-test!) - (viewport gpu-viewport %set-gpu-viewport!) - (clear-color gpu-clear-color %set-gpu-clear-color!) - (multisample? gpu-multisample? %set-gpu-multisample!) - (seamless-cube-maps! gpu-seamless-cube-maps? %set-gpu-seamless-cube-maps!) - (framebuffer gpu-framebuffer %set-gpu-framebuffer!) - (renderbuffer gpu-renderbuffer %set-gpu-renderbuffer!) - (buffer gpu-buffer %set-gpu-buffer!) - (vertex-array gpu-vertex-array %set-gpu-vertex-array!) - (program gpu-program %set-gpu-program!) - ;; Unlike the other state, many textures can be bound to different - ;; units, and the maximum number of texture units varies from - ;; machine to machine. So, we use a vector to hold the state of - ;; this unknown (until runtime) amount of textures. - (textures gpu-textures)) - -(define (make-gpu gl-context) - (define (get-param name) - (let ((bv (make-s32vector 1))) - (gl-get-integer-v name (bytevector->pointer bv)) - (s32vector-ref bv 0))) - (define (extract-version attr) - (match (string-split (pointer->string (gl-get-string attr)) #\space) - ((version . _) version) - (_ "unknown"))) - (let* ((gl-version (extract-version (string-name version))) - (glsl-version (extract-version (version-2-0 shading-language-version))) - (max-texture-size (get-param (get-p-name max-texture-size))) - (max-texture-units (get-param (version-1-3 max-texture-units))) - (guardian (make-guardian)) - (textures (make-vector max-texture-units #f))) - (%make-gpu gl-context gl-version glsl-version max-texture-size - max-texture-units guardian textures))) - -(define-syntax-rule (define-gpu-setter name %set! ref bind pred) - (define (name gpu obj) - (unless (pred obj (ref gpu)) - (bind obj) - (%set! gpu obj)))) - -(define-gpu-setter set-gpu-front-face! - %set-gpu-front-face! gpu-front-face bind-front-face eq?) -(define-gpu-setter set-gpu-blend-mode! - %set-gpu-blend-mode! gpu-blend-mode bind-blend-mode eq?) -(define-gpu-setter set-gpu-cull-face-mode! - %set-gpu-cull-face-mode! gpu-cull-face-mode bind-cull-face-mode eq?) -(define-gpu-setter set-gpu-polygon-mode! - %set-gpu-polygon-mode! gpu-polygon-mode bind-polygon-mode eq?) -(define-gpu-setter set-gpu-color-mask! - %set-gpu-color-mask! gpu-color-mask bind-color-mask equal?) -(define-gpu-setter set-gpu-depth-test! - %set-gpu-depth-test! gpu-depth-test bind-depth-test equal?) -(define-gpu-setter set-gpu-stencil-test! - %set-gpu-stencil-test! gpu-stencil-test bind-stencil-test equal?) -(define-gpu-setter set-gpu-scissor-test! - %set-gpu-scissor-test! gpu-scissor-test bind-scissor-test equal?) -(define-gpu-setter set-gpu-viewport! - %set-gpu-viewport! gpu-viewport bind-viewport equal?) -(define-gpu-setter set-gpu-clear-color! - %set-gpu-clear-color! gpu-clear-color bind-clear-color equal?) -(define-gpu-setter set-gpu-multisample! - %set-gpu-multisample! gpu-multisample? bind-multisample eq?) -(define-gpu-setter set-gpu-seamless-cube-maps! - %set-gpu-seamless-cube-maps! gpu-seamless-cube-maps? bind-seamless-cube-maps eq?) -(define-gpu-setter set-gpu-framebuffer! - %set-gpu-framebuffer! gpu-framebuffer bind-gpu-framebuffer eq?) -(define-gpu-setter set-gpu-renderbuffer! - %set-gpu-renderbuffer! gpu-renderbuffer bind-gpu-renderbuffer eq?) -(define-gpu-setter set-gpu-buffer! - %set-gpu-buffer! gpu-buffer bind-gpu-buffer eq?) -(define-gpu-setter set-gpu-vertex-array! - %set-gpu-vertex-array! gpu-vertex-array bind-gpu-vertex-array eq?) -(define-gpu-setter set-gpu-program! - %set-gpu-program! gpu-program bind-gpu-program eq?) - -(define (gpu-texture gpu unit) - (vector-ref (gpu-textures gpu) unit)) - -(define (set-active-texture-unit! n) - (set-gl-active-texture (+ (version-1-3 texture0) n))) - -(define (set-gpu-texture! gpu unit texture) - (unless (eq? texture (gpu-texture gpu unit)) - (set-active-texture-unit! unit) - (bind-gpu-texture texture) - (vector-set! (gpu-textures gpu) unit texture))) +(define-record-type* + make-vertex-attribute + attribute? + (location vertex-attribute-location #f) + (format vertex-attribute-format #f) + (offset vertex-attribute-offset 0)) + +(define-record-type* + make-vertex-buffer-layout + vertex-buffer-layout? + (stride vertex-buffer-layout-stride 0) + (step-mode vertex-buffer-layout-step-mode 'vertex) + (attributes vertex-buffer-layout-attributes '())) + +(define-record-type* + make-vertex-state + vertex-state? + (module vertex-state-module #f) + (buffers vertex-state-buffers '())) + +(define-record-type* + make-blend-component + blend-component? + (operation blend-component-operation 'add) + (src-factor blend-component-src-factor 'one) + (dst-factor blend-component-dst-factor 'zero)) + +(define-record-type* + make-blend-state + blend-state? + (color blend-state-color (make-blend-component)) + (alpha blend-state-alpha (make-blend-component))) + +(define-record-type* + make-color-target-state + color-target-state? + (format color-target-state-format #f) + (blend color-target-state-blend #f) + (write-mask color-target-state-write-mask #xf)) + +(define-record-type* + make-fragment-state + fragment-state? + (module fragment-state-module #f) + (targets fragment-state-targets '())) + +(define-record-type* + make-primitive-state + primitive-state + (topology primitive-state-topology 'triangle-list) + (front-face primitive-state-front-face 'ccw) + (cull-mode primitive-state-cull-mode 'none) + (unclipped-depth? primitive-state-unclipped-depth? #f)) + +(define-record-type* + make-stencil-face-state + stencil-face-state? + (compare stencil-face-state-compare 'always) + (fail-op stencil-face-state-fail-op 'keep) + (depth-fail-op stencil-face-state-depth-fail-op 'keep) + (pass-op stencil-face-state-pass-op 'keep)) + +;; TODO: depth bias fields. +(define-record-type* + make-depth-stencil-state + depth-stencil-state? + (format depth-stencil-state-format #f) + (depth-write-enabled? depth-stencil-state-depth-write-enabled? #f) + (compare-function depth-stencil-state-compare-function #f) + (stencil-front depth-stencil-state-stencil-front (make-stencil-face-state)) + (stencil-back depth-stencil-state-stencil-back (make-stencil-face-state)) + (stencil-read-mask depth-stencil-state-stencil-read-mask #xffffffff) + (stencil-write-mask depth-stencil-state-stencil-write-mask #xffffffff)) + +(define-record-type* + make-multisample-state + multisample-state? + (count multisample-state-count 1) + (mask multisample-state-mask #xffffffff) + (alpha-to-coverage? multisample-state-alpha-to-coverage? #f)) + +(define-record-type + (%make-render-pipeline handle vertex fragment primitive depth-stencil multisample) + render-pipeline? + (handle render-pipeline-handle) + (vertex render-pipeline-vertex) + (fragment render-pipeline-fragment) + (primitive render-pipeline-primitive) + (depth-stencil render-pipeline-depth-stencil) + (multisample render-pipeline-multisample)) + +(define* (make-render-pipeline gpu #:key vertex fragment + (primitive (make-primitive-state)) + depth-stencil + (multisample (make-multisample-state))) + (unless (vertex-state? vertex) + (error "vertex state is required")) + (let ((handle (backend:make-render-pipeline gpu vertex fragment primitive + depth-stencil multisample))) + (%make-render-pipeline handle vertex fragment primitive depth-stencil + multisample))) + +(define default-clear-color (make-color 0.0 0.0 0.0 0.0)) + +(define-record-type* + make-color-attachment + color-attachment? + (view color-attachment-view #f) + (resolve-target color-attachment-resolve-target #f) + (clear-color color-attachment-clear-color default-clear-color) + (load-op color-attachment-load-op 'clear) + (store-op color-attachment-store-op 'store)) + +(define-record-type* + make-depth-stencil-attachment + depth-stencil-attachment? + (view depth-stencil-attachment-view #f) + (depth-clear-value depth-stencil-attachment-depth-clear-value 0.0) + (depth-load-op depth-stencil-attachment-depth-load-op 'clear) + (depth-store-op depth-stencil-attachment-depth-store-op 'store) + (depth-read-only? depth-stencil-attachment-depth-read-only? #f) + (stencil-clear-value depth-stencil-attachment-stencil-clear-value 0) + (stencil-load-op depth-stencil-attachment-stencil-load-op 'clear) + (stencil-store-op depth-stencil-attachment-stencil-store-op 'store) + (stencil-read-only? depth-stencil-attachment-stencil-read-only? #f)) + +(define-record-type* + make-render-pass-descriptor + render-pass-descriptor? + (color-attachments render-pass--descriptorcolor-attachments '()) + (depth-stencil-attachment render-pass-descriptor-depth-stencil-attachment #f) + (max-draw-count render-pass-descriptor-max-draw-count 50000000)) + +;; (define-record-type +;; (make-buffer-binding-layout type) +;; buffer-binding-layout? +;; ;; uniform, storage, or read-only-storage +;; (type buffer-binding-layout-type)) + +;; (define-record-type +;; (make-sampler-binding-layout type) +;; ;; filtering or non-filtering +;; (type sampler-binding-layout-type)) + +;; (define-record-type +;; (make-texture-binding-layout type dimension multisample?) +;; texture-binding-layout? +;; ;; float, unfilterable-float, depth, sint, uint +;; (type texture-binding-layout-type) +;; (dimension texture-binding-layout-dimension) ; 2d or 3d +;; (multisample? texture-binding-layout-multisample?)) + +;; (define-record-type +;; (make-binding-layout index stages kind) +;; binding-layout? +;; (index binding-layout-index) ; integer +;; (stages binding-layout-stages) ; vertex, fragment, or compute +;; (kind binding-layout-kind)) + +;; (define-record-type +;; (make-bind-group-entry index resource) +;; bind-group-entry? +;; (index bind-group-entry-index) +;; (resource bind-group-entry-resource)) + +;; (define-record-type +;; (make-bind-group layout bindings) +;; bind-group? +;; (layout bind-group-layout) +;; (bindings bind-group-bindings)) + +;; ;; A single GPU command. These objects are re-used over and over to +;; ;; reduce allocation during rendering. Not directly exposed to users. +;; (define-record-type +;; (make-render-command op arg1 arg2 arg3 arg4 arg5) +;; render-command? +;; (op render-command-op) +;; (arg1 render-command-arg1) +;; (arg2 render-command-arg2) +;; (arg3 render-command-arg3) +;; (arg4 render-command-arg4) +;; (arg5 render-command-arg5)) + + +;;; +;;; Commands +;;; + +(define-record-type + (make-command-buffer commands) + command-buffer? + (commands command-buffer-commands)) + +;; A public wrapper around a command buffer. The command encoder asks +;; the GPU for a command buffer (so that the GPU can reuse command +;; buffers repeatedly to reduce allocation), fills it up with +;; commands, and then submits the buffer back to the GPU for +;; execution. +(define-record-type + (%make-command-encoder state commands) + command-encoder? + (state command-encoder-state set-command-encoder-state!) + (commands command-encoder-commands set-command-encoder-commands!)) + +;; TODO: Don't hardcode this limit and move the limit into the GPU +;; object. +(define max-vertex-buffers 8) + +(define-record-type + (make-render-pass-encoder state command-encoder descriptor pipeline + vertex-buffers) + render-pass-encoder? + (state render-pass-encoder-state set-render-pass-encoder-state!) + (command-encoder render-pass-encoder-command-encoder) + (descriptor render-pass-encoder-descriptor) + (pipeline render-pass-encoder-pipeline set-render-pass-encoder-pipeline!) + (vertex-buffers render-pass-encoder-vertex-buffers + set-render-pass-encoder-vertex-buffers!)) + +(define-record-type + (%make-render-state pipeline vertex-buffers) + render-state? + (pipeline render-state-pipeline) + (vertex-buffers render-state-vertex-buffers)) + +(define-record-type + (make-draw-command render-state vertex-count instance-count + first-vertex first-instance) + draw-command? + (render-state draw-command-render-state) + (vertex-count draw-command-vertex-count) + (instance-count draw-command-instance-count) + (first-vertex draw-command-first-vertex) + (first-instance draw-command-first-instance)) + +(define (make-render-state pipeline vertex-buffers) + (%make-render-state pipeline (vector-copy vertex-buffers))) + +(define (make-command-encoder) + (%make-command-encoder 'open '())) + +(define (command-encoder-add! encoder command) + (set-command-encoder-commands! encoder + (cons command + (command-encoder-commands encoder)))) + +(define (command-encoder-finish encoder) + (make-command-buffer (reverse (command-encoder-commands encoder)))) + +(define (begin-render-pass command-encoder pass-descriptor) + (make-render-pass-encoder 'open command-encoder pass-descriptor + #f (make-vector max-vertex-buffers #f))) + +(define (end-render-pass pass) + (set-render-pass-encoder-state! pass 'closed)) + +(define (render-pass-encoder->render-state pass) + (match pass + (($ _ _ _ pipeline vertex-buffers) + (make-render-state pipeline vertex-buffers)))) + +(define (set-render-pass-encoder-vertex-buffer! pass index buffer) + (vector-set! (render-pass-encoder-vertex-buffers pass) index buffer)) + +(define* (render-pass-draw pass vertex-count #:key + (instance-count 1) + (first-vertex 0) + (first-instance 0)) + (let ((cmd (make-draw-command (render-pass-encoder->render-state pass) + vertex-count instance-count + first-vertex first-instance))) + (command-encoder-add! (render-pass-encoder-command-encoder pass) cmd))) + +(define (gpu-submit gpu command-buffer) + (with-mutex (gpu-mutex gpu) + (backend:enqueue gpu command-buffer))) + + +;;; +;;; Garbage collection +;;; (define (gpu-gc gpu) - (let ((guardian (gpu-guardian gpu))) - (let loop () - (match (guardian) - (#f *unspecified*) - ((? gpu-framebuffer? fb) - (free-gpu-framebuffer fb) - (loop)) - ((? gpu-renderbuffer? rb) - (free-gpu-renderbuffer rb) - (loop)) - ((? gpu-buffer? buf) - (free-gpu-buffer buf) - (loop)) - ((? gpu-vertex-array? va) - (free-gpu-vertex-array va) - (loop)) - ((? gpu-texture? t) - (free-gpu-texture t) - (loop)) - ((? gpu-shader? s) - (free-gpu-shader s) - (loop)) - ((? gpu-program? p) - (free-gpu-program p) - (loop)))))) - -(define (guard! gpu obj) - ((gpu-guardian gpu) obj) - obj) - -(define-syntax-rule (define-fresh name constructor params ...) - (define (name gpu params ...) - (guard! gpu (constructor params ...)))) - -(define-fresh fresh-gpu-framebuffer make-gpu-framebuffer) -(define-fresh fresh-gpu-renderbuffer make-gpu-renderbuffer) -(define-fresh fresh-gpu-buffer make-gpu-buffer target usage) -(define-fresh fresh-gpu-vertex-array make-gpu-vertex-array) -(define-fresh fresh-gpu-texture make-gpu-texture target) -(define-fresh fresh-gpu-shader make-gpu-shader type) -(define-fresh fresh-gpu-program make-gpu-program) - -(define (gpu-reset! gpu) - (set-gpu-front-face! gpu front-face:ccw) - (set-gpu-blend-mode! gpu blend:replace) - (set-gpu-cull-face-mode! gpu cull-face:back) - (set-gpu-polygon-mode! gpu polygon:fill) - (set-gpu-color-mask! gpu color-mask:all) - (set-gpu-depth-test! gpu #f) - (set-gpu-stencil-test! gpu #f) - (set-gpu-scissor-test! gpu #f) - (set-gpu-viewport! gpu window-rect:empty) - (set-gpu-clear-color! gpu black) - (set-gpu-multisample! gpu #f) - (set-gpu-seamless-cube-maps! gpu #f) - (set-gpu-framebuffer! gpu gpu-framebuffer:null) - (set-gpu-renderbuffer! gpu gpu-renderbuffer:null) - (set-gpu-buffer! gpu gpu-buffer:null) - (set-gpu-vertex-array! gpu gpu-vertex-array:null) - (set-gpu-program! gpu gpu-program:null) - (let ((textures (gpu-textures gpu))) - (let loop ((i 0)) - (when (< i (vector-length textures)) - (set-gpu-texture! gpu i gpu-texture:null) - (loop (+ i 1)))))) - -(define (set-gpu-texture-min-filter! gpu texture filter) - (set-gpu-texture! gpu 0 texture) - (set-active-texture-unit! 0) - (gl-texture-parameter (gpu-texture-target texture) - (texture-parameter-name texture-min-filter) - (symbol->texture-min-filter filter))) - -(define (set-gpu-texture-mag-filter! gpu texture filter) - (set-gpu-texture! gpu 0 texture) - (set-active-texture-unit! 0) - (gl-texture-parameter (gpu-texture-target texture) - (texture-parameter-name texture-mag-filter) - (symbol->texture-mag-filter filter))) - -(define (set-gpu-texture-wrap-r! gpu texture mode) - (set-gpu-texture! gpu 0 texture) - (set-active-texture-unit! 0) - (gl-texture-parameter (gpu-texture-target texture) - (texture-parameter-name texture-wrap-r-ext) - (symbol->texture-wrap-mode mode))) - -(define (set-gpu-texture-wrap-s! gpu texture mode) - (set-gpu-texture! gpu 0 texture) - (set-active-texture-unit! 0) - (gl-texture-parameter (gpu-texture-target texture) - (texture-parameter-name texture-wrap-s) - (symbol->texture-wrap-mode mode))) - -(define (set-gpu-texture-wrap-t! gpu texture mode) - (set-gpu-texture! gpu 0 texture) - (set-active-texture-unit! 0) - (gl-texture-parameter (gpu-texture-target texture) - (texture-parameter-name texture-wrap-t) - (symbol->texture-wrap-mode mode))) - -(define-inlinable (tex-image-2d gpu target level internal-format - width height pixel-format pixels) - (gl-texture-image-2d target - level - (symbol->pixel-format internal-format) - width height 0 - (symbol->pixel-format pixel-format) - (color-pointer-type unsigned-byte) - (or pixels %null-pointer))) - -(define (gpu-texture-upload-2d gpu texture level internal-format - width height pixel-format pixels) - (set-gpu-texture! gpu 0 texture) - (set-active-texture-unit! 0) - (tex-image-2d gpu (gpu-texture-target texture) level internal-format - width height pixel-format pixels)) - -(define (gpu-texture-upload-2d/sub gpu texture level x y width height - pixel-format pixels) - (set-gpu-texture! gpu 0 texture) - (set-active-texture-unit! 0) - (gl-texture-sub-image-2d (gpu-texture-target texture) 0 - x y width height - (symbol->pixel-format pixel-format) - (color-pointer-type unsigned-byte) - pixels)) - -(define (gpu-texture-copy-image gpu texture level pixel-format dst offset) - (set-gpu-texture! gpu 0 texture) - (set-active-texture-unit! 0) - (gl-get-tex-image (gpu-texture-target texture) level - (symbol->pixel-format pixel-format) - (color-pointer-type unsigned-byte) - (bytevector->pointer dst offset))) - -(define (gpu-texture-upload-cube-map-positive-x gpu texture internal-format - width height pixel-format - pixels) - (set-gpu-texture! gpu 0 texture) - (set-active-texture-unit! 0) - (tex-image-2d gpu (version-1-3 texture-cube-map-positive-x) - 0 internal-format - width height pixel-format pixels)) - -(define (gpu-texture-upload-cube-map-negative-x gpu texture internal-format - width height pixel-format - pixels) - (set-gpu-texture! gpu 0 texture) - (set-active-texture-unit! 0) - (tex-image-2d gpu (version-1-3 texture-cube-map-negative-x) - 0 internal-format - width height pixel-format pixels)) - -(define (gpu-texture-upload-cube-map-positive-y gpu texture internal-format - width height pixel-format - pixels) - (set-gpu-texture! gpu 0 texture) - (set-active-texture-unit! 0) - (tex-image-2d gpu (version-1-3 texture-cube-map-positive-y) - 0 internal-format - width height pixel-format pixels)) - -(define (gpu-texture-upload-cube-map-negative-y gpu texture internal-format - width height pixel-format - pixels) - (set-gpu-texture! gpu 0 texture) - (set-active-texture-unit! 0) - (tex-image-2d gpu (version-1-3 texture-cube-map-negative-y) - 0 internal-format - width height pixel-format pixels)) - -(define (gpu-texture-upload-cube-map-positive-z gpu texture internal-format - width height pixel-format - pixels) - (set-gpu-texture! gpu 0 texture) - (set-active-texture-unit! 0) - (tex-image-2d gpu (version-1-3 texture-cube-map-positive-z) - 0 internal-format - width height pixel-format pixels)) - -(define (gpu-texture-upload-cube-map-negative-z gpu texture internal-format - width height pixel-format - pixels) - (set-gpu-texture! gpu 0 texture) - (set-active-texture-unit! 0) - (tex-image-2d gpu (version-1-3 texture-cube-map-negative-z) - 0 internal-format - width height pixel-format pixels)) - -(define (gpu-texture-generate-mipmap gpu texture) - (set-gpu-texture! gpu 0 texture) - (set-active-texture-unit! 0) - (gl-generate-mipmap (gpu-texture-target texture))) - -(define %draw-buffers - (bytevector->pointer (u32vector (version-3-0 color-attachment0)))) - -(define (gpu-framebuffer-init gpu framebuffer renderbuffer texture width height) - (set-gpu-framebuffer! gpu framebuffer) - ;; Setup depth buffer. - (set-gpu-renderbuffer! gpu renderbuffer) - (gl-renderbuffer-storage (version-3-0 renderbuffer) - (arb-framebuffer-object depth24-stencil8) - width - height) - (set-gpu-renderbuffer! gpu gpu-renderbuffer:null) - (gl-framebuffer-renderbuffer (version-3-0 framebuffer) - (arb-framebuffer-object depth-stencil-attachment) - (version-3-0 renderbuffer) - renderbuffer) - ;; Setup framebuffer texture. - (gl-framebuffer-texture-2d (version-3-0 framebuffer) - (version-3-0 color-attachment0) - (texture-target texture-2d) - (gpu-texture-id texture) - 0) - (gl-draw-buffers 1 %draw-buffers) - ;; Check for errors. - (unless (= (gl-check-framebuffer-status (version-3-0 framebuffer)) - (version-3-0 framebuffer-complete)) - (error "Framebuffer cannot be created"))) - -(define (gpu-buffer-upload gpu buffer usage data length offset) - (set-gpu-buffer! gpu buffer) - (gl-buffer-data (gpu-buffer-target buffer) - length - (if data - (bytevector->pointer data offset) - %null-pointer) - (symbol->buffer-usage usage))) - -;; For streaming buffers, we use buffer re-specification to achieve -;; good throughput. However, it requires getting a new data pointer -;; every frame and allocating a Scheme bytevector for that memory -;; region. Allocating this bytevector every frame causes significant -;; GC pressure. It turns out that GPU drivers tend to return the same -;; set of pointers over and over, or at least the driver I'm using -;; does this. So, by caching bytevectors for those memory regions we -;; avoid bytevector allocation after a frame or two of warmup. -(define (pointer->bytevector/cached buffer pointer length) - (let* ((cache (gpu-buffer-stream-cache buffer)) - (address (pointer-address pointer)) - (cached (hashv-ref cache address))) - ;; It could be that there is a cached bytevector for the address, - ;; but the bytevector is a different length. We must treat this - ;; as a cache miss and allocate a new bytevector. - (if (and cached (= (bytevector-length cached) length)) - cached - (let ((bv (pointer->bytevector pointer length))) - (hashv-set! cache address bv) - bv)))) - -(define (gpu-buffer-map gpu buffer length mode) - (let ((target (gpu-buffer-target buffer)) - (usage (gpu-buffer-usage buffer))) - (set-gpu-buffer! gpu buffer) - (when (= usage (version-1-5 stream-draw)) - ;; Orphan the buffer to avoid implicit synchronization. - ;; https://www.opengl.org/wiki/Buffer_Object_Streaming#Buffer_re-specification - (gl-buffer-data target length %null-pointer (gpu-buffer-usage buffer))) - (let ((ptr (gl-map-buffer target (symbol->access-mode mode)))) - (pointer->bytevector/cached buffer ptr length)))) - -(define (gpu-buffer-unmap gpu buffer) - (set-gpu-buffer! gpu buffer) - (gl-unmap-buffer (gpu-buffer-target buffer))) - -(define *offset-cache* (make-hash-table)) - -(define (offset->pointer offset) - (or (hashv-ref *offset-cache* offset) - (let ((ptr (make-pointer offset))) - (hashv-set! *offset-cache* offset ptr) - ptr))) - -(define (gpu-vertex-array-apply-attribute gpu array buffer index size type - normalized? stride offset divisor) - (set-gpu-vertex-array! gpu array) - (set-gpu-buffer! gpu buffer) - (gl-enable-vertex-attrib-array index) - (gl-vertex-attrib-pointer index size (symbol->data-type type) normalized? - stride (offset->pointer offset)) - (when divisor - (gl-vertex-attrib-divisor index divisor))) - -(define (gpu-clear-viewport flags) - (gl-clear - (fold (lambda (flag result) - (logior (match flag - ('depth-buffer 256) - ('accum-buffer 512) - ('stencil-buffer 1024) - ('color-buffer 16384)) - result)) - 0 flags))) - -(define (gpu-draw gpu mode count offset) - (gl-draw-arrays (symbol->begin-mode mode) offset count)) - -(define (gpu-draw/indexed gpu indices type mode count offset) - (set-gpu-buffer! gpu indices) - (gl-draw-elements (symbol->begin-mode mode) - count - (symbol->data-type type) - (offset->pointer offset))) - -(define (gpu-draw/instanced gpu mode count offset instances) - (gl-draw-arrays-instanced (symbol->begin-mode mode) offset count instances)) - -(define (gpu-draw/instanced+indexed gpu indices type mode count offset instances) - (set-gpu-buffer! gpu indices) - (gl-draw-elements-instanced (symbol->begin-mode mode) - count - (symbol->data-type type) - (offset->pointer offset) - instances)) - -(define (gpu-shader-compiled? shader) - (let ((status (make-u32vector 1))) - (gl-get-shaderiv (gpu-shader-id shader) - (version-2-0 compile-status) - (bytevector->pointer status)) - (= (u32vector-ref status 0) 1))) - -(define (set-gpu-shader-source shader source) - (let ((bv (string->utf8 source))) - (gl-shader-source (gpu-shader-id shader) - 1 - (bytevector->pointer - (u64vector - (pointer-address (bytevector->pointer bv)))) - (bytevector->pointer - (u32vector (bytevector-length bv)))))) - -(define (gpu-shader-compile shader) - (gl-compile-shader (gpu-shader-id shader))) - -(define (set-gpu-program-uniform:signed-int location ptr) - (gl-uniform1iv location 1 ptr)) - -(define (set-gpu-program-uniform:unsigned-int location ptr) - (gl-uniform1uiv location 1 ptr)) - -(define (set-gpu-program-uniform:float location ptr) - (gl-uniform1fv location 1 ptr)) - -(define (set-gpu-program-uniform:vec2 location ptr) - (gl-uniform2fv location 1 ptr)) - -(define (set-gpu-program-uniform:vec3 location ptr) - (gl-uniform3fv location 1 ptr)) - -(define (set-gpu-program-uniform:vec4 location ptr) - (gl-uniform4fv location 1 ptr)) - -(define (set-gpu-program-uniform:mat3 location ptr) - (gl-uniform-matrix3fv location 1 #f ptr)) - -(define (set-gpu-program-uniform:mat4 location ptr) - (gl-uniform-matrix4fv location 1 #f ptr)) - -(define (gpu-program-linked? program) - (let ((status (make-u32vector 1))) - (gl-get-programiv (gpu-program-id program) - (version-2-0 link-status) - (bytevector->pointer status)) - (= (u32vector-ref status 0) 1))) - -(define (gpu-shader-info-log shader) - (let ((log-length-bv (make-u32vector 1))) - (gl-get-shaderiv (gpu-shader-id shader) (version-2-0 info-log-length) - (bytevector->pointer log-length-bv)) - (u32vector-ref log-length-bv 0) - ;; 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)))) - (gl-get-shader-info-log (gpu-shader-id shader) log-length - %null-pointer (bytevector->pointer log)) - (utf8->string log)))) - -(define (gpu-program-info-log program) - (let ((log-length-bv (make-u32vector 1))) - (gl-get-shaderiv (gpu-shader-id program) (version-2-0 info-log-length) - (bytevector->pointer log-length-bv)) - (u32vector-ref log-length-bv 0) - ;; 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)))) - (gl-get-shader-info-log (gpu-shader-id program) log-length - %null-pointer (bytevector->pointer log)) - (utf8->string log)))) - -(define (gpu-program-attach-shader program shader) - (gl-attach-shader (gpu-program-id program) (gpu-shader-id shader))) - -(define (gpu-program-link program) - (gl-link-program (gpu-program-id program))) - -(define (gpu-program-uniform-count program) - (let ((bv (make-u32vector 1))) - (gl-get-programiv (gpu-program-id program) - (arb-shader-objects active-uniforms) - (bytevector->pointer bv)) - (u32vector-ref bv 0))) - -(define (gpu-program-attribute-count program) - (let ((bv (make-u32vector 1))) - (gl-get-programiv (gpu-program-id program) - (arb-shader-objects active-attributes) - (bytevector->pointer bv)) - (u32vector-ref bv 0))) - -(define (utf8->string* bv length) - (let ((bv* (make-bytevector length))) - (bytevector-copy! bv 0 bv* 0 length) - (utf8->string bv*))) - -(define (parse-data-type type) - (cond - ((= type (version-2-0 bool)) 'bool) - ((= type (data-type int)) 'int) - ((= type (data-type unsigned-int)) 'unsigned-int) - ((= type (data-type float)) 'float) - ((= type (version-2-0 float-vec2)) 'float-vec2) - ((= type (version-2-0 float-vec3)) 'float-vec3) - ((= type (version-2-0 float-vec4)) 'float-vec4) - ((= type (version-2-0 float-mat3)) 'mat3) - ((= type (version-2-0 float-mat4)) 'mat4) - ((= type (version-2-0 sampler-2d)) 'sampler-2d) - ((= type (version-2-0 sampler-cube)) 'sampler-cube) - (else - (error "unsupported OpenGL uniform type" type)))) - -(define (gpu-program-uniform-ref program index) - (let ((length-bv (make-u32vector 1)) - (size-bv (make-u32vector 1)) - (type-bv (make-u32vector 1)) - (name-bv (make-bytevector 255))) - (gl-get-active-uniform (gpu-program-id program) - index - (bytevector-length name-bv) - (bytevector->pointer length-bv) - (bytevector->pointer size-bv) - (bytevector->pointer type-bv) - (bytevector->pointer name-bv)) - (let* ((name-length (u32vector-ref length-bv 0)) - (name (utf8->string* name-bv name-length)) - (location (gl-get-uniform-location (gpu-program-id program) name)) - (size (u32vector-ref size-bv 0)) - (type (parse-data-type (u32vector-ref type-bv 0)))) - (values name location size type)))) - -(define (gpu-program-attribute-ref program index) - (let ((length-bv (make-u32vector 1)) - (size-bv (make-u32vector 1)) - (type-bv (make-u32vector 1)) - (name-bv (make-bytevector 255))) - (gl-get-active-attrib (gpu-program-id program) - index - (bytevector-length name-bv) - (bytevector->pointer length-bv) - (bytevector->pointer size-bv) - (bytevector->pointer type-bv) - (bytevector->pointer name-bv)) - (let* ((length (u32vector-ref length-bv 0)) - (name (utf8->string* name-bv length)) - (size (u32vector-ref size-bv 0)) - (type (parse-data-type (u32vector-ref type-bv 0))) - (location (gl-get-attrib-location (gpu-program-id program) - name))) - (values name location size type)))) + (with-mutex (gpu-mutex gpu) + (let ((guardian (gpu-guardian gpu))) + (let loop () + (let ((obj (guardian))) + (when obj + (match obj + ((? buffer? buffer) (buffer-destroy! buffer)) + ((? texture? texture) (texture-destroy! texture)) + ((? shader-module? module) (shader-module-destroy! module))) + (loop))))))) diff --git a/chickadee/graphics/shader.scm b/chickadee/graphics/shader.scm index 9974b38..83f0b46 100644 --- a/chickadee/graphics/shader.scm +++ b/chickadee/graphics/shader.scm @@ -134,7 +134,7 @@ #:serializer (lambda (bv i bool) (bytevector-s32-native-set! bv i (if bool 1 0))) - #:setter set-gpu-program-uniform:signed-int + #:setter 'set-gpu-program-uniform:signed-int #:null #false) (define-shader-primitive-type int @@ -144,7 +144,7 @@ #:serializer (lambda (bv i n) (bytevector-s32-native-set! bv i n)) - #:setter set-gpu-program-uniform:signed-int + #:setter 'set-gpu-program-uniform:signed-int #:null 0) (define-shader-primitive-type unsigned-int @@ -156,7 +156,7 @@ #:serializer (lambda (bv i u) (bytevector-u32-native-set! bv i u)) - #:setter set-gpu-program-uniform:unsigned-int + #:setter 'set-gpu-program-uniform:unsigned-int #:null 0) (define-shader-primitive-type float @@ -166,7 +166,7 @@ #:serializer (lambda (bv i f) (bytevector-ieee-single-native-set! bv i f)) - #:setter set-gpu-program-uniform:float + #:setter 'set-gpu-program-uniform:float #:null 0.0) (define-shader-primitive-type float-vec2 @@ -177,7 +177,7 @@ (let ((unwrap-vec2 (@@ (chickadee math vector) unwrap-vec2))) (lambda (bv i v) (bytevector-copy! (unwrap-vec2 v) 0 bv i 8))) - #:setter set-gpu-program-uniform:vec2 + #:setter 'set-gpu-program-uniform:vec2 #:null (vec2 0.0 0.0)) (define-shader-primitive-type float-vec3 @@ -188,7 +188,7 @@ (let ((unwrap-vec3 (@@ (chickadee math vector) unwrap-vec3))) (lambda (bv i v) (bytevector-copy! (unwrap-vec3 v) 0 bv i 12))) - #:setter set-gpu-program-uniform:vec3 + #:setter 'set-gpu-program-uniform:vec3 #:null (vec3 0.0 0.0 0.0)) (define-shader-primitive-type float-vec4 @@ -207,7 +207,7 @@ (bytevector-copy! (unwrap-rect v) 0 bv i 16)) ((color? v) (bytevector-copy! (unwrap-color v) 0 bv i 16))))) - #:setter set-gpu-program-uniform:vec4 + #:setter 'set-gpu-program-uniform:vec4 #:null (make-null-rect)) (define-shader-primitive-type mat3 @@ -218,7 +218,7 @@ (let ((matrix3-bv (@@ (chickadee math matrix) matrix3-bv))) (lambda (bv i m) (bytevector-copy! (matrix3-bv m) 0 bv i (* 3 3 4)))) - #:setter set-gpu-program-uniform:mat3 + #:setter 'set-gpu-program-uniform:mat3 #:null (make-identity-matrix3)) (define-shader-primitive-type mat4 @@ -230,7 +230,7 @@ (lambda (bv i m) ;; 4 rows x 4 columns x 4 bytes per float = 4^3 (bytevector-copy! (matrix4-bv m) 0 bv i (* 4 4 4)))) - #:setter set-gpu-program-uniform:mat4 + #:setter 'set-gpu-program-uniform:mat4 #:null (make-identity-matrix4)) (define-shader-primitive-type sampler-2d @@ -240,7 +240,7 @@ #:serializer (lambda (bv i texture-unit) (bytevector-s32-native-set! bv i texture-unit)) - #:setter set-gpu-program-uniform:signed-int + #:setter 'set-gpu-program-uniform:signed-int #:null 0) (define-shader-primitive-type sampler-cube @@ -250,7 +250,7 @@ #:serializer (lambda (bv i texture-unit) (bytevector-s32-native-set! bv i texture-unit)) - #:setter set-gpu-program-uniform:signed-int + #:setter 'set-gpu-program-uniform:signed-int #:null 0) @@ -497,7 +497,7 @@ (type attribute-type)) (define null-shader - (%make-shader gpu-program:null (make-hash-table) (make-hash-table) #f #f)) + (%make-shader 'gpu-program:null (make-hash-table) (make-hash-table) #f #f)) (define (make-shader vertex-port fragment-port) "Read GLSL source from VERTEX-PORT and FRAGMENT-PORT and compile diff --git a/chickadee/graphics/texture.scm b/chickadee/graphics/texture.scm index faf9953..112b25f 100644 --- a/chickadee/graphics/texture.scm +++ b/chickadee/graphics/texture.scm @@ -113,7 +113,7 @@ (texture-wrap-t texture)))) (define null-texture - (%make-texture gpu-texture:null '2d #f 'linear 'linear 'repeat 'repeat 0 0 0 0 + (%make-texture 'gpu-texture:null '2d #f 'linear 'linear 'repeat 'repeat 0 0 0 0 (make-rect 0.0 0.0 0.0 0.0) (make-rect 0.0 0.0 0.0 0.0))) (define (texture-null? texture) diff --git a/chickadee/graphics/viewport.scm b/chickadee/graphics/viewport.scm index 9d93c0e..dd51b57 100644 --- a/chickadee/graphics/viewport.scm +++ b/chickadee/graphics/viewport.scm @@ -63,10 +63,10 @@ viewport with CLEAR-COLOR when clearing the screen. Clear the buffers denoted by the list of symbols in CLEAR-FLAGS. Possible values for CLEAR-FLAGS are 'color-buffer', 'depth-buffer', 'accum-buffer', and 'stencil-buffer'." - (%make-viewport (make-window-rect (assert-non-negative-integer x) - (assert-non-negative-integer y) - (assert-non-negative-integer width) - (assert-non-negative-integer height)) + (%make-viewport `(make-window-rect ,(assert-non-negative-integer x) + ,(assert-non-negative-integer y) + ,(assert-non-negative-integer width) + ,(assert-non-negative-integer height)) clear-color clear-flags)) diff --git a/guix.scm b/guix.scm index 50237e3..b6c44eb 100644 --- a/guix.scm +++ b/guix.scm @@ -60,7 +60,7 @@ (define target-guile guile-3.0-latest) (define guile-sdl2 - (let ((commit "e9a7f5e748719ce5b6ccd08ff91861b578034ea6")) + (let ((commit "b4f168ee72fecd8cc97d87ee032ea47283585f46")) (package (name "guile-sdl2") (version (string-append "0.7.0-1." (string-take commit 7))) @@ -71,7 +71,7 @@ (commit commit))) (sha256 (base32 - "0ay7mcar8zs0j5rihwlzi0l46vgg9i93piip4v8a3dzwjx3myr7v")))) + "07rl7ll03wh6n6yshlcw6l6hz73iwwai3r6xhvmnywpx8wpkxfhv")))) (build-system gnu-build-system) (arguments '(#:make-flags '("GUILE_AUTO_COMPILE=0"))) -- cgit v1.2.3