[refactor] to get rid of finalizers. [add] pre-exit-hooks

5 files changed, 88 insertions, 72 deletions

diff --git a/src/application.lisp b/src/application.lisp
index 5b6e9ad..6869a56 100644
--- a/src/application.lisp
+++ b/src/application.lisp
@@ -96,7 +96,7 @@
   (dolist (unit (application-scene app))
     (drop-unit unit)
     (cleanup unit))
-  (trivial-garbage:gc :full t))
+  (pre-exit-hooks))
 
 (defun run-perframe (app)
   "Runs all of the handlers objects listening for perframe events, if
diff --git a/src/interactive/canvas.lisp b/src/interactive/canvas.lisp
index aef8ebb..d870ae8 100644
--- a/src/interactive/canvas.lisp
+++ b/src/interactive/canvas.lisp
@@ -94,22 +94,8 @@ e.g., drawing a line in a particular color."
 
 (defvar *canvas-shader-program* nil)
 (defvar *canvas-render-vao* nil)
-(defvar *canvas-count* 0)
-
-(defun canvas-finalizer ()
-  (decf *canvas-count*)
-  (unless (plusp *canvas-count*)
-    (when *canvas-render-vao*
-      (gl:delete-vertex-arrays (list *canvas-render-vao*)))
-    (when *canvas-shader-program*
-      (gl:delete-program *canvas-shader-program*))
-    (setf-many *canvas-fbo-vao*
-               *canvas-render-vao*
-               *canvas-shader-program*
-               nil)))
-
-
-(defun make-shared-canvas-render-objects ()
+
+(defun make-shared-canvas-gpu-objects ()
   (setf
    ;; compile shader program
    *canvas-shader-program*
@@ -149,7 +135,19 @@ e.g., drawing a line in a particular color."
   (gl:enable-vertex-attrib-array 0)
   (gl:vertex-attrib-pointer 0 2 :float 0 (* +float-size+ 2) 0)
   (gl:bind-buffer :array-buffer 0)
-  (gl:bind-vertex-array 0))
+  (gl:bind-vertex-array 0)
+
+  (unless (pre-exit-hook-exists-p :canvas-gpu-resources )
+    (pre-exit-hook :canvas-gpu-resources
+                   (lambda ()
+                     (when *canvas-render-vao*
+                       (gl:delete-vertex-arrays (list *canvas-render-vao*)))
+                     (when *canvas-shader-program*
+                       (gl:delete-program *canvas-shader-program*))
+                     (setf-many *canvas-fbo-vao*
+                                *canvas-render-vao*
+                                *canvas-shader-program*
+                                nil)))))
 
 (defclass/std canvas (unit interactive pixels)
   ((fbo :with :r :doc "framebuffer object for use in off-screen-rendering of this canvas to a texture")
@@ -157,14 +155,11 @@ e.g., drawing a line in a particular color."
 
 (defmethod cleanup ((canvas canvas))
   (cleanup (canvas-texture canvas))
-  (gl:delete-framebuffers (list (canvas-fbo canvas)))
-  (canvas-finalizer))
+  (gl:delete-framebuffers (list (canvas-fbo canvas))))
 
 (defmethod initialize-instance :after ((canvas canvas) &key)
   (unless *canvas-shader-program*
-    (make-shared-canvas-render-objects))
-  (incf *canvas-count*)
-  (trivial-garbage:finalize canvas #'canvas-finalizer)
+    (make-shared-canvas-gpu-objects))
   (with-slots (texture fbo base-width base-height) canvas
     (setf texture   (make-instance
                      'texture
diff --git a/src/interactive/image.lisp b/src/interactive/image.lisp
index 0089f57..1b3a817 100644
--- a/src/interactive/image.lisp
+++ b/src/interactive/image.lisp
@@ -14,63 +14,67 @@
 count and destroys shader-program if necessary."
   (decf *image-count*)
   (unless (plusp *image-count*)
-    (when *image-vao*
-      (gl:delete-vertex-arrays (list *image-vao*))
-      (setf *image-vao* nil))
-    (when *image-shader-program*
-      (gl:delete-program *image-shader-program*)
-      (setf *image-shader-program* nil))))
+    ))
 
 (defclass/std image (unit interactive)
   ((texture :ri :std (error "A image requires a texture."))))
 
+(defun make-shared-image-gpu-objects ()
+  (unless *image-shader-program*
+    (setf *image-shader-program*
+          (create-shader
+           '(:vertex
+             ((vert :vec2))
+             ((transform :mat4))
+             ((values
+               (* transform (vari:vec4 vert 0.0 1.0))
+               vert))) ;color
+           '(:fragment
+             ((tc :vec2))
+             ((tex :sampler-2d))
+             ((let ((frag  (vari:texture tex tc)))
+                (if (< (aref frag 3) 0.01)
+                    (vari:discard)
+                    frag))))))
+    (gl:program-uniformi
+     *image-shader-program*
+     (gl:get-uniform-location *image-shader-program* "TEX")
+     0))
+
+  (unless *image-vao*
+    (setf *image-vao* (gl:gen-vertex-array))
+    (gl:bind-vertex-array *image-vao*)
+    (let ((vbo (gl:gen-buffer)))
+      (with-gl-array (verts :float
+                            0.0 1.0 
+                            1.0 0.0 
+                            0.0 0.0 
+                            
+                            0.0 1.0 
+                            1.0 1.0 
+                            1.0 0.0 )
+        (gl:bind-buffer :array-buffer vbo)
+        (gl:buffer-data :array-buffer :static-draw verts)))
+    (gl:enable-vertex-attrib-array 0)
+    (gl:vertex-attrib-pointer 0 2 :float 0 (* +float-size+ 2) 0)
+    (gl:bind-buffer :array-buffer 0)
+    (gl:bind-vertex-array 0))
+
+  (unless (pre-exit-hook-exists-p :image-gpu-resources)
+    (pre-exit-hook :image-gpu-resources
+     (lambda ()
+       (when *image-vao*
+         (gl:delete-vertex-arrays (list *image-vao*))
+         (setf *image-vao* nil))
+       (when *image-shader-program*
+         (gl:delete-program *image-shader-program*)
+         (setf *image-shader-program* nil))))))
+
 (defmethod initialize-instance :after ((image image) &key)
-  (incf *image-count*)
-  (trivial-garbage:finalize image #'image-finalizer)
   (with-slots (base-width base-height texture) image
     (setf base-height (texture-height texture)
           base-width (texture-width texture))
-    (unless *image-shader-program*
-      (setf *image-shader-program*
-            (create-shader
-             '(:vertex
-               ((vert :vec2))
-               ((transform :mat4))
-               ((values
-                 (* transform (vari:vec4 vert 0.0 1.0))
-                 vert))) ;color
-             '(:fragment
-               ((tc :vec2))
-               ((tex :sampler-2d))
-               ((let ((frag  (vari:texture tex tc)))
-                  (if (< (aref frag 3) 0.01)
-                      (vari:discard)
-                      frag))))))
-      (gl:program-uniformi
-       *image-shader-program*
-       (gl:get-uniform-location *image-shader-program* "TEX")
-       0))
-    (unless *image-vao*
-      (setf *image-vao* (gl:gen-vertex-array))
-      (gl:bind-vertex-array *image-vao*)
-      (let ((vbo (gl:gen-buffer)))
-        (with-gl-array (verts :float
-                              0.0 1.0 
-                              1.0 0.0 
-                              0.0 0.0 
-                              
-                              0.0 1.0 
-                              1.0 1.0 
-                              1.0 0.0 )
-          (gl:bind-buffer :array-buffer vbo)
-          (gl:buffer-data :array-buffer :static-draw verts)))
-      (gl:enable-vertex-attrib-array 0)
-      (gl:vertex-attrib-pointer 0 2 :float 0 (* +float-size+ 2) 0)
-      (gl:bind-buffer :array-buffer 0)
-      (gl:bind-vertex-array 0))))
-
-(defmethod cleanup ((image image))
-  (image-finalizer))
+    (make-shared-image-gpu-objects)))
 
 (defmethod render ((image image))
   (with-slots (texture) image
diff --git a/src/pre-exit-hooks.lisp b/src/pre-exit-hooks.lisp
new file mode 100644
index 0000000..42e4195
--- /dev/null
+++ b/src/pre-exit-hooks.lisp
@@ -0,0 +1,16 @@
+;;; pre-exit-hooks.lisp
+
+(in-package :wheelwork)
+
+(defvar *pre-exit-hooks* (make-hash-table))
+
+(defun pre-exit-hook-exists-p (tag)
+  (gethash tag *pre-exit-hooks*))
+
+(defun pre-exit-hook (tag thunk)
+  (setf (gethash tag *pre-exit-hooks*)
+        thunk))
+
+(defun pre-exit-hooks ()
+  (loop for thunk being the hash-value of *pre-exit-hooks*
+        do (funcall thunk)))
diff --git a/wheelwork.asd b/wheelwork.asd
index 6d578a1..c2fa044 100644
--- a/wheelwork.asd
+++ b/wheelwork.asd
@@ -21,6 +21,7 @@
                (:file "utils")
                (:file "grid-geometry")
                (:file "region")
+               (:file "pre-exit-hooks")
                (:module "gl"
                 :components ((:file "util")
                              (:file "texture")