More cleanup.

assets/shader-image.lisp

@@ -18,15 +18,13 @@
   (render (// 'trial 'fullscreen-square) program))
 
 (defmethod render ((renderer image-renderer) (texture texture))
-  (let ((fbo (gl:gen-framebuffer)))
-    (gl:bind-framebuffer :framebuffer fbo)
+  (let ((framebuffer (make-instance 'framebuffer :data-pointer (gl:gen-framebuffer))))
     (unwind-protect
          (progn
-           (gl:viewport 0 0 (width texture) (height texture))
-           (%gl:framebuffer-texture :framebuffer :color-attachment0 (gl-name texture) 0)
+           (bind texture framebuffer)
+           (activate framebuffer)
            (render renderer NIL))
-      (gl:bind-framebuffer :framebuffer 0)
-      (gl:delete-framebuffers (list fbo)))))
+      (deallocate framebuffer))))
 
 (define-class-shader (image-renderer :vertex-shader)
   "

effects.lisp

@@ -47,13 +47,14 @@ void main(){
   ((iterations :initarg :iterations :initform 1 :accessor iterations)))
 
 (defmethod render ((pass iterative-post-effect-pass) (program shader-program))
-  (let* ((color (gl-name (color pass)))
+  (let* ((color (color pass))
          (ocolor color)
-         (previous (gl-name (previous-pass pass))))
+         (framebuffer (framebuffer pass))
+         (previous (previous-pass pass)))
     (flet ((swap-buffers ()
              (rotatef color previous)
-             (%gl:framebuffer-texture :framebuffer :color-attachment0 color 0)
-             (gl:bind-texture :texture-2d previous)))
+             (bind color framebuffer)
+             (bind previous 0)))
       (call-next-method)
       (loop with limit = (iterations pass)
             for i from 0
@@ -63,16 +64,16 @@ void main(){
                    (return)))
       ;; KLUDGE: this is wrong for even number of iterations. It essentially
       ;;         discards the last iteration, as it won't be displayed....
-      (when (/= ocolor color)
-        (%gl:framebuffer-texture :framebuffer :color-attachment0 ocolor 0)))))
+      (unless (eq ocolor color)
+        (bind ocolor (framebuffer pass))))))
 
 (define-shader-pass temporal-post-effect-pass (post-effect-pass)
   ((previous :port-type static-input :accessor previous)
    (color :port-type output :reader color)))
 
 (defmethod render :after ((pass temporal-post-effect-pass) thing)
   (rotatef (gl-name (previous pass)) (gl-name (color pass)))
-  (%gl:framebuffer-texture :framebuffer :color-attachment0 (gl-name (color pass)) 0))
+  (bind (color pass) (framebuffer pass)))
 
 (define-shader-pass copy-pass (simple-post-effect-pass)
   ())

pixel-pipeline.lisp

@@ -68,20 +68,19 @@
          ,@(when iterate
              (destructuring-bind (times (a b)) iterate
                `((defmethod render ((pass ,name) (program shader-program))
-                   (let ((in (gl-name (slot-value pass ',a)))
-                         (out (gl-name (slot-value pass ',b)))
+                   (let ((in (slot-value pass ',a))
+                         (out (slot-value pass ',b))
                          (unit-id (unit-id (port pass ',a)))
                          (attachment (attachment (port pass ',b)))
                          (times ,times))
-                     (gl:active-texture unit-id)
                      (dotimes (i times)
                        (call-next-method)
                        (when (< i (1- times))
                          (rotatef in out)
-                         (%gl:bind-texture :texture-2d in)
-                         (%gl:framebuffer-texture :framebuffer attachment out 0)))
-                     (setf (gl-name (slot-value pass ',a)) in)
-                     (setf (gl-name (slot-value pass ',b)) out))))))))))
+                         (bind in unit-id)
+                         (bind out framebuffer)))
+                     (setf (gl-name (slot-value pass ',a)) (gl-name in))
+                     (setf (gl-name (slot-value pass ',b)) (gl-name out)))))))))))
 
 (defclass pixel-pipeline (pipeline)
   ((width :initarg :width :accessor width)
@@ -177,13 +176,11 @@
              (setf (dirty-p pipeline) NIL))
            (let ((in (aref (passes pipeline) 0))
                  (out (aref (passes pipeline) (1- (length (passes pipeline))))))
-             (%gl:bind-framebuffer :framebuffer (gl-name (framebuffer out)))
+             (activate (framebuffer out))
              ,@(loop for (out in) in loopback
                      collect `(rotatef (gl-name (slot-value in ',in))
                                        (gl-name (slot-value out ',out)))
-                     collect `(%gl:framebuffer-texture
-                               :framebuffer (attachment (port out ',out))
-                               (gl-name (slot-value out ',out)) 0))))
+                     collect `(bind (slot-value out ',out) (framebuffer out)))))
 
          ,@(loop for (kind name type . args) in slots
                  when (eql :uniform kind)

renderer/particle.lisp

@@ -384,14 +384,12 @@
         (setf (emit-count struct) to-emit)
         (setf (randomness struct) (random 1.0)))
       ;; Simulate with compute shaders
-      (%gl:bind-buffer :dispatch-indirect-buffer (gl-name particle-argument-buffer))
-      (render kickoff-pass NIL)
-      (render emit-pass NIL)
+      (render kickoff-pass particle-argument-buffer)
+      (render emit-pass 0)
       (simulate-particles particle-emitter)
       ;; Swap the buffers
       (rotatef (binding-point alive-particle-buffer-0)
                (binding-point alive-particle-buffer-1))
-      (%gl:bind-buffer :dispatch-indirect-buffer 0)
       (setf (to-emit particle-emitter) emit-carry))))
 
 (define-handler (particle-emitter class-changed) ()
@@ -429,10 +427,8 @@
     (with-buffer-tx (struct particle-emitter-buffer)
       (setf (emit-count struct) count)
       (setf (randomness struct) (random 1.0)))
-    (%gl:bind-buffer :dispatch-indirect-buffer (gl-name particle-argument-buffer))
-    (render kickoff-pass NIL)
-    (render emit-pass NIL)
-    (%gl:bind-buffer :dispatch-indirect-buffer 0)))
+    (render kickoff-pass (gl-name particle-argument-buffer))
+    (render emit-pass NIL)))
 
 (define-shader-pass depth-colliding-particle-simulate-pass (particle-simulate-pass)
   ((depth-tex :port-type fixed-input :accessor depth)

renderer/shadow-map.lisp

@@ -156,7 +156,7 @@
 
 (defmethod render-frame :before ((pass standard-shadows-pass) frame)
   (let ((program (shadow-map-program pass))
-        (map (gl-name (shadow-map pass)))
+        (map (shadow-map pass))
         (lights (shadow-map-lights pass)))
     (activate (shadow-map-framebuffer pass))
     (activate program)
@@ -168,8 +168,8 @@
     (dotimes (id (length lights))
       (when (aref lights id)
         (setf (uniform program "shadow_map_id") id)
-        (%gl:framebuffer-texture-layer :framebuffer :depth-attachment map 0 id)
-        (gl:clear :depth-buffer)
+        (bind map (shadow-map-framebuffer pass))
+        (clear (shadow-map-framebuffer pass))
         (loop for (object) across frame
               do (when (typep object 'standard-renderable)
                    (with-pushed-matrix ()

resources/compute-shader.lisp

@@ -9,12 +9,29 @@
 (defclass compute-shader (shader-program)
   ((shader-source :initarg :source :initform (arg! :source) :accessor shader-source)
    (shaders :initform ())
-   (workgroup-size :initarg :workgroup-size :initform (vec 1 1 1) :accessor workgroup-size)))
+   (work-groups :initarg :work-groups :initform (vec 1 1 1) :accessor work-groups)
+   (barrier :initform 4294967295)))
+
+(defmethod initialize-instance :after ((shader compute-shader) &key)
+  (unless (integerp (slot-value shader 'barrier))
+    (setf (barrier shader) (slot-value shader 'barrier))))
+
+(defmethod shared-initialize :after ((shader compute-shader) slots &key (barrier NIL barrier-p))
+  (when barrier-p (setf (barrier shader) barrier)))
 
 (defmethod print-object ((shader compute-shader) stream)
   (print-unreadable-object (shader stream :type T :identity T)
     (format stream "~:[~;ALLOCATED~]" (allocated-p shader))))
 
+(defmethod barrier ((shader compute-shader))
+  (cffi:foreign-bitfield-symbols '%gl::MemoryBarrierMask (slot-value shader 'barrier)))
+
+(defmethod (setf barrier) ((bits list) (shader compute-shader))
+  (setf (slot-value shader 'barrier) (cffi:foreign-bitfield-value '%gl::MemoryBarrierMask bits)))
+
+(defmethod (setf barrier) ((bits symbol) (shader compute-shader))
+  (setf (slot-value shader 'barrier) (cffi:foreign-bitfield-value '%gl::MemoryBarrierMask (list bits))))
+
 (defmethod allocate ((shader compute-shader))
   (let ((source (shader-source shader))
         (shdr (gl:create-shader :compute-shader))
@@ -28,15 +45,47 @@
           (when (eql :es (profile *context*))
             (setf source (glsl-toolkit:transform source :es (version *context*)))))
         (gl:shader-source shdr source)
-        (gl:compile-shader shdr)
+        (gl:compile-shader shdr)2
         (unless (gl:get-shader shdr :compile-status)
           (error 'shader-compilation-error :shader shader :log (gl:get-shader-info-log shdr)))
         (v:debug :trial.asset "Compiled shader ~a: ~%~a" shader source)
         (link-program shader (list shdr))
         (gl:delete-shader shdr)
         (setf (data-pointer shader) prog)))))
 
-(defmethod activate ((shader compute-shader))
-  (call-next-method)
-  (let ((size (workgroup-size shader)))
-    (%gl:dispatch-compute (truncate (vx size)) (truncate (vy size)) (truncate (vz size)))))
+(defmethod render ((shader compute-shader) (target null))
+  (let ((work-groups (work-groups shader))
+        (barrier (slot-value shader 'barrier)))
+    (etypecase work-groups
+      (vec3
+       (%gl:dispatch-compute
+        (truncate (vx work-groups))
+        (truncate (vy work-groups))
+        (truncate (vz work-groups))))
+      (integer
+       (%gl:dispatch-compute-indirect work-groups))
+      (buffer-object
+       (%gl:bind-buffer :dispatch-indirect-buffer (gl-name work-groups))
+       (%gl:dispatch-compute-indirect 0)))
+    (when (/= 0 barrier)
+      (%gl:memory-barrier barrier))))
+
+(defmethod render ((shader compute-shader) (offset integer))
+  (let ((work-groups (work-groups shader))
+        (barrier (slot-value shader 'barrier)))
+    (etypecase work-groups
+      (buffer-object
+       (%gl:bind-buffer :dispatch-indirect-buffer (gl-name work-groups))
+       (%gl:dispatch-compute-indirect offset)))
+    (when (/= 0 barrier)
+      (%gl:memory-barrier barrier))))
+
+(defmethod render ((shader compute-shader) (target buffer-object))
+  (let ((work-groups (work-groups shader))
+        (barrier (slot-value shader 'barrier)))
+    (%gl:bind-buffer :dispatch-indirect-buffer (gl-name work-groups))
+    (%gl:dispatch-compute-indirect (etypecase work-groups
+                                     (integer work-groups)
+                                     (null 0)))
+    (when (/= 0 barrier)
+      (%gl:memory-barrier barrier))))

resources/framebuffer.lisp

@@ -29,6 +29,18 @@
   (append (call-next-method)
           (mapcar #'second (attachments framebuffer))))
 
+(defun check-framebuffer-size (framebuffer texture)
+  (cond ((null (width framebuffer))
+         (setf (width framebuffer) (width texture)))
+        ((/= (width framebuffer) (width texture))
+         (error "Cannot attach~%  ~a~%to~%  ~a~%, as the width is mismatched."
+                texture framebuffer)))
+  (cond ((null (height framebuffer))
+         (setf (height framebuffer) (height texture)))
+        ((/= (height framebuffer) (height texture))
+         (error "Cannot attach~%  ~a~%to~%  ~a~%, as the height is mismatched."
+                texture framebuffer))))
+
 (defun bind-framebuffer-attachments (framebuffer attachments)
   (let ((color-attachments (loop for attachment in attachments
                                  unless (find (first attachment) '(:depth-attachment :stencil-attachment :depth-stencil-attachment))
@@ -42,18 +54,9 @@
           (check-framebuffer-attachment attachment)
           (check-type texture texture)
           (check-allocated texture)
+          (check-framebuffer-size framebuffer texture)
           (v:debug :trial.framebuffer "Attaching ~a~@[:~a~] as ~a to ~a."
                    texture layer attachment framebuffer)
-          (cond ((null (width framebuffer))
-                 (setf (width framebuffer) (width texture)))
-                ((/= (width framebuffer) (width texture))
-                 (error "Cannot attach~%  ~a~%to~%  ~a~%, as the width is mismatched."
-                        texture framebuffer)))
-          (cond ((null (height framebuffer))
-                 (setf (height framebuffer) (height texture)))
-                ((/= (height framebuffer) (height texture))
-                 (error "Cannot attach~%  ~a~%to~%  ~a~%, as the height is mismatched."
-                        texture framebuffer)))
           (if layer
               (%gl:framebuffer-texture-layer :framebuffer attachment (gl-name texture) level layer)
               (%gl:framebuffer-texture :framebuffer attachment (gl-name texture) level))
@@ -78,6 +81,19 @@
     (with-cleanup-on-failure (bind-framebuffer-attachments framebuffer (attachments framebuffer))
       (bind-framebuffer-attachments framebuffer attachments))))
 
+(defmethod bind ((texture texture) (framebuffer framebuffer))
+  (check-framebuffer-size framebuffer texture)
+  (gl:bind-framebuffer (gl-name framebuffer))
+  (case (internal-format texture)
+    ((:depth-component :depth-component16 :depth-component24 :depth-component32 :depth-component32f)
+     (%gl:framebuffer-texture :framebuffer :depth-attachment (gl-name texture) 0))
+    ((:stencil-index :stencil-index1 :stencil-index4 :stencil-index8 :stencil-index16)
+     (%gl:framebuffer-texture :framebuffer :stencil-attachment (gl-name texture) 0))
+    ((:depth-stencil :depth24-stencil8 :depth32f-stencil8)
+     (%gl:framebuffer-texture :framebuffer :depth-stencil-attachment (gl-name texture) 0))
+    (T
+     (%gl:framebuffer-texture :framebuffer :color-attachment0 (gl-name texture) 0))))
+
 (defmethod allocate ((framebuffer framebuffer))
   (let ((fbo (gl:gen-framebuffer)))
     (with-cleanup-on-failure (gl:delete-framebuffers (list fbo))
@@ -95,12 +111,18 @@
     (setf (width framebuffer) width)
     (setf (height framebuffer) height)))
 
+;; TODO: avoid rebinding framebuffer if already bound
 (defmethod activate ((framebuffer framebuffer))
   (gl:bind-framebuffer :framebuffer (gl-name framebuffer))
   (gl:viewport 0 0 (width framebuffer) (height framebuffer))
   (let ((bits (slot-value framebuffer 'clear-bits)))
     (when (< 0 bits) (%gl:clear bits))))
 
+(defmethod clear ((framebuffer framebuffer))
+  (gl:bind-framebuffer :framebuffer (gl-name framebuffer))
+  (let ((bits (slot-value framebuffer 'clear-bits)))
+    (when (< 0 bits) (%gl:clear bits))))
+
 (defmethod render ((source framebuffer) (target integer))
   (gl:bind-framebuffer :read-framebuffer (gl-name source))
   (gl:bind-framebuffer :draw-framebuffer target)

shader-pass.lisp

@@ -490,49 +490,19 @@ void main(){
   color = texture(previous_pass, uv);
 }")
 
-(define-shader-pass compute-pass (single-shader-pass)
-  ((work-groups :initform (vec 1 1 1) :initarg :work-groups :accessor work-groups)
-   (barrier :initform 4294967295)))
-
-(defmethod initialize-instance :after ((pass compute-pass) &key)
-  (unless (integerp (slot-value pass 'barrier))
-    (setf (barrier pass) (slot-value pass 'barrier))))
-
-(defmethod shared-initialize :after ((pass compute-pass) slots &key (barrier NIL barrier-p))
-  (when barrier-p (setf (barrier pass) barrier)))
+(define-shader-pass compute-pass (single-shader-pass compute-shader)
+  ())
 
 (defmethod handle ((event event) (pass compute-pass)))
 
-(defmethod barrier ((pass compute-pass))
-  (cffi:foreign-bitfield-symbols '%gl::MemoryBarrierMask (slot-value pass 'barrier)))
+(defmethod shader-program ((pass compute-pass))
+  pass)
 
-(defmethod (setf barrier) ((bits list) (pass compute-pass))
-  (setf (slot-value pass 'barrier) (cffi:foreign-bitfield-value '%gl::MemoryBarrierMask bits)))
+(defmethod shaders ((pass compute-pass))
+  (shaders (make-shader-program pass)))
 
-(defmethod (setf barrier) ((bits symbol) (pass compute-pass))
-  (setf (slot-value pass 'barrier) (cffi:foreign-bitfield-value '%gl::MemoryBarrierMask (list bits))))
-
-(defmethod render ((pass compute-pass) (_ null))
-  (bind-textures pass)
-  (render pass (or (shader-program pass)
-                   (error "Shader program was never allocated!!"))))
-
-(defmethod render ((pass compute-pass) (program shader-program))
-  (let ((work-groups (work-groups pass))
-        (barrier (slot-value pass 'barrier)))
-    (etypecase work-groups
-      (vec3
-       (%gl:dispatch-compute
-        (truncate (vx work-groups))
-        (truncate (vy work-groups))
-        (truncate (vz work-groups))))
-      (integer
-       (%gl:dispatch-compute-indirect work-groups))
-      (buffer-object
-       (%gl:bind-buffer :dispatch-indirect-buffer (gl-name work-groups))
-       (%gl:dispatch-compute-indirect 0)))
-    (when (/= 0 barrier)
-      (%gl:memory-barrier barrier))))
+(defmethod render :before ((pass compute-pass) (_ null))
+  (bind-textures pass))
 
 (defmethod render ((pass compute-pass) (work-groups vec3))
   (setf (work-groups pass) work-groups)