diff options
| -rw-r--r-- | Makefile.am | 1 | ||||
| -rw-r--r-- | sly/game.scm | 2 | ||||
| -rw-r--r-- | sly/guardian.scm | 69 | ||||
| -rw-r--r-- | sly/render/mesh.scm | 27 | ||||
| -rw-r--r-- | sly/render/shader.scm | 28 | ||||
| -rw-r--r-- | sly/render/texture.scm | 20 |
6 files changed, 109 insertions, 38 deletions
diff --git a/Makefile.am b/Makefile.am index f63e3da..fe5348a 100644 --- a/Makefile.am +++ b/Makefile.am @@ -29,6 +29,7 @@ SOURCES = \ sly/event.scm \ sly/fps.scm \ sly/game.scm \ + sly/guardian.scm \ sly/input/keyboard.scm \ sly/input/mouse.scm \ sly/live-reload.scm \ diff --git a/sly/game.scm b/sly/game.scm index 38d230e..66f0893 100644 --- a/sly/game.scm +++ b/sly/game.scm @@ -31,6 +31,7 @@ #:use-module (gl) #:use-module (sly agenda) #:use-module (sly event) + #:use-module (sly guardian) #:use-module (sly math) #:use-module (sly signal) #:use-module (sly math vector) @@ -184,6 +185,7 @@ milliseconds of the last iteration of the game loop." (stop-game-loop))) ;; Let's play! (run-hook game-start-hook) + (run-guardian) (game-loop (sdl-ticks) 0)) (lambda (cont callback) (when (procedure? callback) diff --git a/sly/guardian.scm b/sly/guardian.scm new file mode 100644 index 0000000..6bdfcd0 --- /dev/null +++ b/sly/guardian.scm @@ -0,0 +1,69 @@ +;;; Sly +;;; Copyright © 2016 David Thompson <davet@gnu.org> +;;; +;;; Sly is free software: you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation, either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; Sly is distributed in the hope that it will be useful, but WITHOUT +;;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +;;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public +;;; License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Garbage collector for foreign objects. +;; +;;; Code: + +(define-module (sly guardian) + #:use-module (ice-9 match) + #:use-module (sly agenda) + #:export (register-finalizer + guard + run-guardian)) + +(define-syntax-rule (push! variable value) + (set! variable (cons value variable))) + +(define %guardian (make-guardian)) + +(define %finalizers '()) + +(define (register-finalizer predicate finalizer) + "Register FINALIZER, a procedure that frees a foreign resource, to +be used for objects that satisfy PREDICATE." + (push! %finalizers (cons predicate finalizer))) + +(define (guard obj) + "Protect OBJ from garbage collection until its finalizer has been +applied. OBJ is returned unmodified." + (%guardian obj) + obj) + +(define (lookup-finalizer obj) + "Return the finalization procedure for OBJ, or #f if none is found." + (let loop ((finalizers %finalizers)) + (match finalizers + (() #f) + (((predicate . finalizer) . rest) + (if (predicate obj) + finalizer + (loop rest)))))) + +(define (run-guardian) + "Start the guardian worker coroutine on the current agenda." + (schedule-each + (lambda () + (let loop ((obj (%guardian))) + (when obj + (let ((finalizer (lookup-finalizer obj))) + (if finalizer + (finalizer obj) + (error "no finalizer found for object" obj))) + (loop (%guardian))))))) diff --git a/sly/render/mesh.scm b/sly/render/mesh.scm index acf9a0f..f1d6e2c 100644 --- a/sly/render/mesh.scm +++ b/sly/render/mesh.scm @@ -34,6 +34,7 @@ #:use-module (gl low-level) #:use-module (gl enums) #:use-module (sly utils) + #:use-module (sly guardian) #:use-module (sly wrappers gl) #:use-module (sly math vector) #:use-module (sly render color) @@ -264,17 +265,18 @@ allows vertex buffers to be updated with new vertex data." (length mesh-length) (vertex-buffers mesh-vertex-buffers)) -(define-guardian mesh-guardian - (lambda (mesh) - ;; Delete vertex array and vertex buffers. - (glDeleteVertexArrays 1 (u32vector (mesh-id mesh))) - (let ((buffers (mesh-vertex-buffers mesh))) - (glDeleteBuffers (length buffers) - (list->u32vector - (map (match-lambda - ((_ . vbo) - (vertex-buffer-id vbo))) - buffers)))))) +(define (free-mesh mesh) + ;; Delete vertex array and vertex buffers. + (glDeleteVertexArrays 1 (u32vector (mesh-id mesh))) + (let ((buffers (mesh-vertex-buffers mesh))) + (glDeleteBuffers (length buffers) + (list->u32vector + (map (match-lambda + ((_ . vbo) + (vertex-buffer-id vbo))) + buffers))))) + +(register-finalizer mesh? free-mesh) (define null-mesh (%make-mesh 0 0 '())) @@ -309,8 +311,7 @@ allows vertex buffers to be updated with new vertex data." (vertex-attrib-pointer vertex-position-location position-buffer) (vertex-attrib-pointer vertex-texture-location texture-buffer) (apply-vertex-buffer index-buffer)) - (mesh-guardian mesh) - mesh)) + (guard mesh))) (define (build-mesh indices positions textures) (let ((index-buffer (vector->vertex-buffer indices #t)) diff --git a/sly/render/shader.scm b/sly/render/shader.scm index 556d626..3367b57 100644 --- a/sly/render/shader.scm +++ b/sly/render/shader.scm @@ -26,6 +26,7 @@ #:use-module (gl) #:use-module (gl low-level) #:use-module (sly utils) + #:use-module (sly guardian) #:use-module (sly math transform) #:use-module (sly math vector) #:use-module (sly render color) @@ -88,10 +89,11 @@ (eq? (shader-stage-type stage) 'fragment)) ;; Reap GL shaders when their wrapper objects are GC'd. -(define-guardian shader-stage-guardian - (lambda (stage) - (false-if-exception - (glDeleteShader (shader-stage-id stage))))) +(define (free-shader-stage stage) + (false-if-exception + (glDeleteShader (shader-stage-id stage)))) + +(register-finalizer shader-stage? free-shader-stage) (define-status %shader-stage-compiled? glGetShaderiv compile-status) @@ -135,10 +137,9 @@ or 'fragment') and compile the GLSL program contained in the string SOURCE." (let* ((id (glCreateShader (gl-shader-type type))) (stage (%make-shader-stage type id))) - (shader-stage-guardian stage) (set-shader-stage-source stage source) (compile-shader-stage stage) - stage)) + (guard stage))) (define (make-vertex-shader-stage source) "Create a new GLSL vertex shader stage and compile the GLSL program @@ -205,10 +206,11 @@ stored in the file FILE-NAME." (uniform-location uniform) (error "Uniform not found: " name)))) -(define-guardian shader-guardian - (lambda (shader) - (false-if-exception - (glDeleteProgram (shader-id shader))))) +(define (free-shader shader) + (false-if-exception + (glDeleteProgram (shader-id shader)))) + +(register-finalizer shader? free-shader) (define-status shader-linked? glGetProgramiv link-status) (define-logger display-linking-error glGetProgramiv glGetProgramInfoLog) @@ -252,10 +254,8 @@ VERTEX-STAGE and FRAGMENT-STAGE." (for-each (lambda (stage) (glDetachShader id (shader-stage-id stage))) stages) - (let* ((uniforms (map build-uniform uniforms)) - (shader (%make-shader id uniforms))) - (shader-guardian shader) - shader)) + (let* ((uniforms (map build-uniform uniforms))) + (guard (%make-shader id uniforms)))) throw (lambda _ ;; Make sure to delete program in case linking fails. diff --git a/sly/render/texture.scm b/sly/render/texture.scm index bb7f88c..2e77b0f 100644 --- a/sly/render/texture.scm +++ b/sly/render/texture.scm @@ -31,8 +31,9 @@ #:use-module (gl contrib packed-struct) #:use-module (sdl2 image) #:use-module (sdl2 surface) - #:use-module (sly render color) + #:use-module (sly guardian) #:use-module (sly utils) + #:use-module (sly render color) #:use-module (sly math vector) #:use-module (sly wrappers gl) #:export (make-texture @@ -90,9 +91,7 @@ a texture object (if this texture only represents a region of another texture) or #f. WIDTH and HEIGHT are the texture dimensions in pixels. S1, T1, S2, and T2 are the OpenGL texture coordinates representing the area of the texture that will be rendered." - (let ((texture (%make-texture id parent width height s1 t1 s2 t2))) - (texture-guardian texture) - texture)) + (guard (%make-texture id parent width height s1 t1 s2 t2))) (define (make-texture-region texture x y width height) "Creates new texture region object. TEXTURE is the region's parent @@ -109,13 +108,12 @@ that will be rendered, in pixels." (/ (+ x width) w) (/ (+ y height) h)))) -;; Use a guardian and an after GC hook that ensures that OpenGL -;; textures are deleted when texture objects are GC'd. -(define-guardian texture-guardian - (lambda (texture) - ;; Do not reap texture regions - (unless (texture-region? texture) - (gl-delete-texture (texture-id texture))))) +(define (free-texture texture) + ;; Do not reap texture regions. + (unless (texture-region? texture) + (gl-delete-texture (texture-id texture)))) + +(register-finalizer texture? free-texture) (define* (bytevector->texture pixels width height min-filter mag-filter #:optional (format (pixel-format rgba))) |