#33 Shading program libraries and dependencies

borodust · Oct 23, 2016 · 13fa24f · 13fa24f
1 parent 957c63c
commit 13fa24f
Show file tree

Hide file tree

Showing 12 changed files with 372 additions and 82 deletions.
diff --git a/cl-bodge.asd b/cl-bodge.asd
@@ -11,7 +11,7 @@
   :author "Pavel Korolev"
   :mailto "dev@borodust.org"
   :license "MIT"
-  :depends-on (alexandria cl-opengl cl-glfw3 cl-muth split-sequence sb-cga cffi clode
+  :depends-on (alexandria cl-opengl cl-glfw3 cl-muth sb-cga cffi clode
                           log4cl bordeaux-threads trivial-main-thread cl-openal cl-alc
                           cl-fad local-time blackbird trivial-garbage opticl)
   :serial t
@@ -75,7 +75,11 @@
                (:module resources
                         :serial t
                         :components ((:file "shader-source")
-                                     (:file "image")))
+                                     (:file "shader-library")
+                                     (:file "image")
+                                     (:module shaders
+                                              :components
+                                              ((:file "lighting")))))
                (:module scene
                         :serial t
                         :components ((:file "node")

diff --git a/concurrency/async.lisp b/concurrency/async.lisp
@@ -11,3 +11,31 @@
   `(alet* ,(loop for promise in promise-gens collecting
                `(nil ,promise))
      ,@body))
+
+
+(defmacro wait-for ((&rest bindings) &body body)
+  (with-gensyms (latch condition c)
+    (let ((gensymed (loop for b in bindings
+                       for (name value) = (if (atom b)
+                                              (list b nil)
+                                              (if (null (rest b))
+                                                  (append b nil)
+                                                  b))
+                       collect (list name (gensym (symbol-name name))
+                                     (gensym (symbol-name name)) value))))
+      `(let (,@(loop for b in gensymed collect (second b))
+             ,condition)
+         (wait-with-latch (,latch)
+           (finally
+               (catcher
+                (alet (,@(loop for b in gensymed collect (rest (rest b))))
+                  ,@(loop for b in gensymed
+                       for (g1 . g2) = (rest b) collect
+                         `(setf ,g1 ,(first g2))))
+                (t (,c) (setf ,condition ,c)))
+             (open-latch ,latch)))
+         (unless (null ,condition)
+           (error ,condition))
+         (let (,@(loop for (name . g1) in gensymed collect
+                      (list name (first g1))))
+           ,@body)))))
diff --git a/engine/thread-bound-system.lisp b/engine/thread-bound-system.lisp
@@ -25,24 +25,38 @@
   (:method (context system) (declare (ignore context system))))
 
 
+(defmacro %log-unexpected-error (block-name)
+  `(lambda (e)
+     (log:error "Unexpected error during task execution: ~a" e)
+     (break)
+     (return-from ,block-name)))
+
+
 (defgeneric start-system-loop (system)
   (:method ((this thread-bound-system))
-    (loop while (enabledp this) do
-         (handler-case
-             (funcall (pop-from (%job-queue-of this)))
-           (interrupted ()) ; just continue execution
-           (t (e) (log:error "Unexpected error during task execution: ~a" e))))))
+      (loop while (enabledp this) do
+           (block interruptible
+             (handler-bind ((interrupted (lambda (e)
+                                           (declare (ignore e))
+                                           (return-from interruptible))) ; leave loop
+                            (t (%log-unexpected-error interruptible)))
+               (funcall (pop-from (%job-queue-of this))))))))
 
 
 (defmethod execute ((this thread-bound-system) fn)
   (with-promise (resolve reject)
-    (handler-case
-        (put-into (%job-queue-of this)
-                  (lambda ()
+    (handler-bind ((interrupted (lambda (e)
+                                  (declare (ignore e))
+                                  (error "Cannot execute task: ~a offline."
+                                         (class-name (class-of this)))))
+                   (t (lambda (e) (reject e))))
+      (let ((task (lambda ()
                     (handler-bind ((t (lambda (e) (log:error "~a" e) (break) (reject e))))
-                      (resolve (funcall fn)))))
-      (interrupted () (error "Cannot execute task: ~a offline."
-                             (class-name (class-of this)))))))
+                      (resolve (funcall fn))))))
+        (with-slots (thread) this
+          (if (eq (bt:current-thread) (with-system-lock-held (this) thread))
+              (funcall task)
+              (put-into (%job-queue-of this) task)))))))
 
 
 (defmethod enable ((this thread-bound-system))

diff --git a/graphics/shading.lisp b/graphics/shading.lisp
@@ -1,58 +1,92 @@
 (in-package :cl-bodge.graphics)
 
-(defclass shading-program (gl-object) ()
-  (:default-initargs :id (gl:create-program)))
 
+(defclass shader (gl-object)
+  ((type :initarg :type :reader shader-type-of)))
 
-(define-destructor shading-program ((id id-of) (sys system-of))
+
+(define-destructor shader ((id id-of) (sys system-of))
   (-> sys
-    (gl:delete-program id)))
+    (gl:delete-shader id)))
 
 
-(defun compile-shader (type source)
+(defun %compile-shader (type source)
   (let ((shader (gl:create-shader type)))
     (gl:shader-source shader source)
     (gl:compile-shader shader)
     shader))
 
 
-(defun make-program (this shader-sources)
-  (let ((program (id-of this))
-        (shaders (loop for src in shader-sources collect
-                      (compile-shader (shader-type-of src) (shader-text-of src)))))
-    (loop for shader in shaders do (gl:attach-shader program shader))
-    (gl:link-program program)
-    (unless (gl:get-program program :link-status)
-      (let ((shader-logs (apply #'concatenate 'string
-                                (loop for shader in shaders collecting
-                                     (format nil "~%~a:~%~a"
-                                             (cffi:foreign-enum-keyword
-                                              '%gl:enum
-                                              (gl:get-shader shader :shader-type))
-                                             (gl:get-shader-info-log shader)))))
-            (program-log (gl:get-program-info-log program)))
-        (error "Program linking failed. Logs:~%~a~%~a" shader-logs program-log)))
-    (loop for shader in shaders do
-         (gl:detach-shader program shader)
-         (gl:delete-shader shader))))
-
-
-(defmethod initialize-instance :after ((this shading-program) &key shader-sources separable-p)
+(defmethod initialize-instance ((this shader) &key type source system)
+  (call-next-method this :id (%compile-shader type source) :system system :type type))
+
+
+(definline compile-shader (system type source)
+  (make-instance 'shader :type type :source source :system system))
+
+
+;;;
+;;;
+;;;
+(defclass shading-program (gl-object) ()
+  (:default-initargs :id (gl:create-program)))
+
+
+(define-destructor shading-program ((id id-of) (sys system-of))
+  (-> sys
+    (gl:delete-program id)))
+
+
+(defun %make-program (this shader-sources precompiled-shaders)
+  (let* ((program (id-of this))
+         (shaders (loop for src in shader-sources collect
+                       (compile-shader (system-of this)
+                                       (shader-type-of src)
+                                       (shader-text-of src))))
+         (all-shaders (append precompiled-shaders shaders)))
+    (unwind-protect
+         (loop for shader in all-shaders do
+              (gl:attach-shader program (id-of shader)))
+      (gl:link-program program)
+      (unless (gl:get-program program :link-status)
+        (let ((shader-logs (apply #'concatenate 'string
+                                  (loop for shader in all-shaders collecting
+                                       (format nil "~%~a:~%~a"
+                                               (shader-type-of shader)
+                                               (gl:get-shader-info-log (id-of shader))))))
+              (program-log (gl:get-program-info-log program)))
+          (error "Program linking failed. Logs:~%~a~%~a" shader-logs program-log)))
+      (loop for shader in all-shaders do
+           (gl:detach-shader program (id-of shader)))
+      (loop for shader in shaders do
+           (dispose shader)))))
+
+
+(defmethod initialize-instance :after ((this shading-program)
+                                       &key shader-sources shaders separable-p)
   (gl:program-parameteri (id-of this) :program-separable separable-p)
-  (make-program this shader-sources))
+  (%make-program this shader-sources shaders))
 
 
-(declaim (inline make-shading-program))
-(defun make-shading-program (system &rest shader-sources)
+(definline make-shading-program (system &rest shader-sources)
   (make-instance 'shading-program :system system :shader-sources shader-sources))
 
 
-(declaim (inline make-separable-shading-program))
-(defun make-separable-shading-program (system &rest shader-sources)
+(definline make-separable-shading-program (system &rest shader-sources)
   (make-instance 'shading-program :system system :shader-sources shader-sources
                  :separable-p t))
 
 
+(definline link-separable-shading-program (system &rest shaders)
+  (make-instance 'shading-program :system system :shaders shaders
+                 :separable-p t))
+
+
+(definline build-separable-shading-program (system shader-sources shaders)
+  (make-instance 'shading-program :system system :shaders shaders
+                 :shader-sources shader-sources :separable-p t))
+
+
 (defun use-shading-program (program)
   (gl:use-program (id-of program)))
 
@@ -74,8 +108,8 @@
       (single-float (gl:program-uniformf (id-of program) variable-idx value))
       (vec (gl:program-uniformfv (id-of program) variable-idx (vec->array value)))
       (square-mat (gl:program-uniform-matrix (id-of program) variable-idx
-                                                (square-matrix-size value)
-                                                (vector (mat->array value)) nil)))))
+                                             (square-matrix-size value)
+                                             (vector (mat->array value)) nil)))))
 
 
 ;;;

diff --git a/memory/disposable.lisp b/memory/disposable.lisp
@@ -5,12 +5,31 @@
   (:method (obj) '()))
 
 
+(defstruct holder
+  (value nil :type boolean))
+
+
+(defclass disposable ()
+  ((finalized-p :initform (make-holder))))
+
+
+(defun finalizedp (disposable)
+  (holder-value (slot-value disposable 'finalized-p)))
+
+
+(defmethod initialize-instance :around ((this disposable) &key)
+  (call-next-method)
+  (if-let ((destructor (destructor-of this)))
+    (loop for finalizer in (destructor-of this) do
+         (finalize this finalizer))))
+
+
 (definline dispose (obj)
   (if (finalizedp obj)
       (error "Attempt to dispose already finalized object.")
       (loop for finalizer in (destructor-of obj) do
            (funcall finalizer)
-         finally (setf (slot-value obj 'finalized-p) t))))
+         finally (setf (holder-value (slot-value obj 'finalized-p)) t))))
 
 
 (definline %ensure-not-null (value)
@@ -33,25 +52,6 @@ Check define-destructor documentation.")
                  (call-next-method)))))))
 
 
-(defstruct holder
-  (value nil :type boolean))
-
-
-(defclass disposable ()
-  ((finalized-p :initform (make-holder))))
-
-
-(defun finalizedp (disposable)
-  (holder-value (slot-value disposable 'finalized-p)))
-
-
-(defmethod initialize-instance :around ((this disposable) &key)
-  (call-next-method)
-  (if-let ((destructor (destructor-of this)))
-    (loop for finalizer in (destructor-of this) do
-         (finalize this finalizer))))
-
-
 (defmacro with-disposable ((var) obj &body body)
   (once-only (obj)
     `(let ((,var ,obj))

diff --git a/packages.lisp b/packages.lisp
@@ -16,12 +16,30 @@
            copy-memory
 
            ensure-not-null
-           if-unbound))
+           if-unbound
+
+           class-name-of
+           dolines))
 
 
 (defpackage :cl-bodge.concurrency
   (:nicknames :ge.mt)
-  (:use :cl :alexandria :bordeaux-threads :cl-muth :blackbird)
+  (:use :cl :alexandria :bordeaux-threads :cl-muth)
+  (:import-from :blackbird
+                promisep
+                promise-finished-p
+                create-promise
+                with-promise
+                promisify
+                attach
+                catcher
+                tap
+                finally
+                alet
+                alet*
+                aif
+                multiple-promise-bind
+                all)
   (:export make-job-queue
            push-job
            push-body-into
@@ -42,6 +60,7 @@
            finally
            when-all
            when-all*
+           wait-for
            alet
            alet*
            aif
@@ -197,8 +216,12 @@
            make-mesh
            make-indexed-mesh
 
+           compile-shader
            make-shading-program
            make-separable-shading-program
+           link-separable-shading-program
+           build-separable-shading-program
+
            use-shading-program
            program-uniform-variable
 
@@ -265,10 +288,13 @@
 
 (defpackage :cl-bodge.resources
   (:nicknames :ge.rsc)
-  (:use :cl-bodge.utils
-        :cl :alexandria)
+  (:use :cl-bodge.utils :cl-bodge.graphics :cl-bodge.graphics.resources
+        :cl-bodge.concurrency :cl-bodge.memory
+        :cl :alexandria :cl-muth)
   (:export load-shader-source
-           load-png-image))
+           load-png-image
+           build-shading-program))
+
 
 
 (defpackage :cl-bodge.scene