Permalink
Browse files

A swath of untested changes to untangle some of the mess and speed up…

… some things.

- Remove redefinition-notifying-class as the weak pointer strategy often left virtually dead objects being notified. Plus it was gross to begin with.
- Add a default method on (handle event T) that handles it in the context handler to allow global event issues via context.
- Add class-changed event (but nothing signals them yet, see fixme)
- Add caching for effective-shader-class
- Fix the naming of some functions
- Make the way shaders are recombined make more sense and follow the intended MOP protocol more closely.
- Do not define classes like shader-entities, subjects, shader-subjects, or shader-passes at compile time.
  • Loading branch information...
Shinmera committed Oct 30, 2018
1 parent e109902 commit 3a5f4ef7259418e4da2373650ad4ba900b58d2d2
Showing with 105 additions and 190 deletions.
  1. +4 −0 context.lisp
  2. +2 −0 entity.lisp
  3. +3 −0 event-loop.lisp
  4. +2 −8 package.lisp
  5. +0 −62 redefinition-notifying-class.lisp
  6. +36 −45 shader-entity.lisp
  7. +43 −49 shader-pass.lisp
  8. +4 −6 shader-subject.lisp
  9. +10 −18 subject.lisp
  10. +1 −2 trial.asd
View
@@ -153,6 +153,10 @@
(v:warn :trial.context "~a attempted to release ~a even though ~a is active."
this context *context*))))))
(defmethod handle (event (global (eql T)))
(unless (boundp *context*)
(handle event (handler *context*))))
(defclass resize (event)
((width :initarg :width :reader width)
(height :initarg :height :reader height)))
View
@@ -20,3 +20,5 @@
(defmethod matches (a (b entity))
(matches b a))
;; FIXME: send out redefinition signals
View
@@ -146,3 +146,6 @@
(defclass tick (event)
((tt :initarg :tt :accessor tt)
(dt :initarg :dt :accessor dt)))
(defclass class-changed (event)
((changed-class :initarg :changed-class :accessor changed-class)))
View
@@ -443,12 +443,6 @@
#:rail-location
#:linear-rail
#:rail-times)
;; redefinition-notifying-class.lisp
(:export
#:redefinition-notifying-class
#:class-redefinition-listeners
#:add-class-redefinition-listener
#:remove-class-redefinition-listener)
;; render-texture.lisp
(:export
#:render-texture
@@ -532,7 +526,8 @@
#:define-class-shader
#:shader-entity
#:define-shader-entity
#:determine-effective-shader-class)
#:effective-shader-class
#:compute-effective-shader-class)
;; shader-pass.lisp
(:export
#:shader-pass-class
@@ -559,7 +554,6 @@
#:prepare-pass-program
#:per-object-pass
#:assets
#:notify-class-redefinition
#:single-shader-pass
#:shader-program
#:post-effect-pass)

This file was deleted.

Oops, something went wrong.
View
@@ -6,10 +6,11 @@
(in-package #:org.shirakumo.fraf.trial)
(defclass shader-entity-class (redefinition-notifying-class)
(defclass shader-entity-class (standard-class)
((effective-shaders :initform () :accessor effective-shaders)
(direct-shaders :initform () :initarg :shaders :accessor direct-shaders)
(inhibited-shaders :initform () :initarg :inhibit-shaders :accessor inhibited-shaders)))
(inhibited-shaders :initform () :initarg :inhibit-shaders :accessor inhibited-shaders)
(effective-shader-class :accessor effective-shader-class)))
(defmethod c2mop:validate-superclass ((class shader-entity-class) (superclass t))
NIL)
@@ -59,26 +60,34 @@
(string shader)
(list (destructuring-bind (pool path) shader
(pool-path pool path))))))))
(setf (effective-shaders class) effective-shaders)))
effective-shaders))
(defmethod compute-effective-shaders :after ((class shader-entity-class))
;; Propagate
(loop for sub-class in (c2mop:class-direct-subclasses class)
when (and (typep sub-class 'shader-entity-class)
(c2mop:class-finalized-p sub-class))
do (compute-effective-shaders sub-class)))
(defmethod compute-effective-shader-class ((class shader-entity-class))
(if (direct-shaders class)
class
(let* ((effective-superclasses (list (find-class 'shader-entity))))
;; Loop through superclasses and push new, effective superclasses.
(loop for superclass in (c2mop:class-direct-superclasses class)
for effective-class = (effective-shader-class superclass)
do (when (and effective-class (not (find effective-class effective-superclasses)))
(push effective-class effective-superclasses)))
;; If we have one or two --one always being the shader-entity class--
;; then we just return the more specific of the two, as there's no class
;; combination happening that would produce new shaders.
(if (<= (length effective-superclasses) 2)
(first effective-superclasses)
class))))
(defmethod c2mop:finalize-inheritance :after ((class shader-entity-class))
(dolist (super (c2mop:class-direct-superclasses class))
(unless (c2mop:class-finalized-p super)
(c2mop:finalize-inheritance super)))
(compute-effective-shaders class))
(defmethod (setf effective-shaders) :after (value (class shader-entity-class))
(notify-class-redefinition class class))
(setf (effective-shaders class) (compute-effective-shaders class))
(setf (effective-shader-class class) (compute-effective-shader-class class)))
(defmethod (setf direct-shaders) :after (value (class shader-entity-class))
(compute-effective-shaders class))
(when (c2mop:class-finalized-p class)
(reinitialize-instance class)))
(defmethod effective-shaders ((class symbol))
(effective-shaders (find-class class)))
@@ -110,6 +119,12 @@
(defmethod remove-class-shader (type (class symbol))
(remove-class-shader type (find-class class)))
(defmethod effective-shader-class ((name symbol))
(effective-shader-class (find-class name)))
(defmethod effective-shader-class ((class standard-class))
NIL)
(defmethod make-class-shader-program ((class shader-entity-class))
(make-instance 'shader-program
:shaders (loop for (type source) on (effective-shaders class) by #'cddr
@@ -147,18 +162,19 @@
(defmethod remove-class-shader (type (subject shader-entity))
(remove-class-shader type (class-of subject)))
(defmethod effective-shader-class ((object shader-entity))
(effective-shader-class (class-of object)))
(defmethod make-class-shader-program ((subject shader-entity))
(make-class-shader-program (class-of subject)))
(defmacro define-shader-entity (&environment env name direct-superclasses direct-slots &rest options)
(unless (find-if (lambda (c) (c2mop:subclassp (find-class c T env) 'shader-entity)) direct-superclasses)
(setf direct-superclasses (append direct-superclasses (list 'shader-entity))))
(setf direct-superclasses (append direct-superclasses (list 'shader-entity)))
(unless (find :metaclass options :key #'first)
(push '(:metaclass shader-entity-class) options))
`(eval-when (:compile-toplevel :load-toplevel :execute)
(defclass ,name ,direct-superclasses
,direct-slots
,@options)))
`(defclass ,name ,direct-superclasses
,direct-slots
,@options))
(define-class-shader (shader-entity :vertex-shader)
"#version 330 core")
@@ -170,28 +186,3 @@ out vec4 color;
void main(){
color = vec4(1.0, 1.0, 1.0, 1.0);
}")
(defmethod determine-effective-shader-class ((name symbol))
(determine-effective-shader-class (find-class name)))
(defmethod determine-effective-shader-class ((object shader-entity))
(determine-effective-shader-class (class-of object)))
(defmethod determine-effective-shader-class ((class standard-class))
NIL)
(defmethod determine-effective-shader-class ((class shader-entity-class))
(if (direct-shaders class)
class
(let* ((effective-superclasses (list (find-class 'shader-entity))))
;; Loop through superclasses and push new, effective superclasses.
(loop for superclass in (c2mop:class-direct-superclasses class)
for effective-class = (determine-effective-shader-class superclass)
do (when (and effective-class (not (find effective-class effective-superclasses)))
(push effective-class effective-superclasses)))
;; If we have one or two --one always being the shader-entity class--
;; then we just return the more specific of the two, as there's no class
;; combination happening that would produce new shaders.
(if (<= (length effective-superclasses) 2)
(first effective-superclasses)
class))))
View
@@ -67,9 +67,6 @@
(:metaclass shader-pass-class)
(:inhibit-shaders (shader-entity :fragment-shader)))
(defmethod initialize-instance :after ((pass shader-pass) &key)
(add-class-redefinition-listener pass (class-of pass)))
(define-class-shader (shader-pass :fragment-shader)
"#version 330 core")
@@ -104,14 +101,12 @@
(when pass (load pass)))))
(defmacro define-shader-pass (&environment env name direct-superclasses direct-slots &rest options)
(unless (find-if (lambda (c) (c2mop:subclassp (find-class c T env) 'shader-pass)) direct-superclasses)
(setf direct-superclasses (append direct-superclasses (list 'shader-pass))))
(setf direct-superclasses (append direct-superclasses (list 'shader-pass)))
(unless (find :metaclass options :key #'car)
(push '(:metaclass shader-pass-class) options))
`(eval-when (:compile-toplevel :load-toplevel :execute)
(defclass ,name ,direct-superclasses
,direct-slots
,@options)))
`(defclass ,name ,direct-superclasses
,direct-slots
,@options))
(defun generate-prepare-pass-program (&optional (units (gl:get* :max-texture-image-units)))
(check-type units (integer 1))
@@ -135,42 +130,40 @@
(define-shader-pass per-object-pass ()
((assets :initform (make-hash-table :test 'eql) :accessor assets)))
(defmethod register-object-for-pass :after ((pass per-object-pass) (object shader-entity))
(add-class-redefinition-listener pass (determine-effective-shader-class object))
(add-class-redefinition-listener pass (class-of object)))
;; FIXME: Maybe consider determining effective class for each
;; individual shader stage as they might each change
;; at different levels and could thus be cached more
;; effectively.
;; FIXME: Share SHADER assets between shader programs by caching
;; them... somewhere somehow?
(defmethod notify-class-redefinition ((pass per-object-pass) (class shader-entity-class))
;; FIXME: What happens if the effective shader class changes?
(let ((assets (assets pass)))
(flet ((refresh (class)
(let ((prev (gethash class assets))
(new (make-pass-shader-program pass class)))
(if (and prev (allocated-p prev))
(with-context (*context*)
(with-simple-restart (continue "Ignore the change and continue with the hold shader.")
(dolist (shader (shaders new))
(unless (allocated-p shader) (allocate shader)))
(allocate new)
(deallocate prev)
(setf (gethash class assets) new)))
(setf (gethash class assets) new)))))
(cond ((eql class (class-of pass))
;; Pass changed, recompile everything
(loop for class being the hash-keys of assets
do (refresh class)))
((eql class (determine-effective-shader-class class))
;; Object changed, recompile it
(refresh class))))))
(define-handler (per-object-pass class-changed) (ev)
(let* ((pass per-object-pass)
(class (changed-class ev))
(assets (assets pass)))
(when (typep class 'shader-entity-class)
;; FIXME: What happens if the effective shader class changes?
(flet ((refresh (class)
(let ((prev (gethash class assets))
(new (make-pass-shader-program pass class)))
(if (and prev (allocated-p prev))
(with-context (*context*)
(with-simple-restart (continue "Ignore the change and continue with the hold shader.")
(dolist (shader (shaders new))
(unless (allocated-p shader) (allocate shader)))
(allocate new)
(deallocate prev)
(setf (gethash class assets) new)))
(setf (gethash class assets) new)))))
(cond ((eql class (class-of pass))
;; Pass changed, recompile everything
(loop for class being the hash-keys of assets
do (refresh class)))
((eql class (effective-shader-class class))
;; Object changed, recompile it
(refresh class)))))))
(defmethod shader-program-for-pass ((pass per-object-pass) (subject shader-entity))
;; FIXME: FIXME: FIXME: FIXME: THIS REALLY NEEDS A FIX AS IT IS SUPER INEFFICIENT!
(gethash (determine-effective-shader-class subject) (assets pass)))
(gethash (effective-shader-class subject) (assets pass)))
(defmethod coerce-pass-shader ((pass per-object-pass) class type spec)
(glsl-toolkit:merge-shader-sources
@@ -183,7 +176,7 @@
(register-object-for-pass pass object)))
(defmethod register-object-for-pass ((pass per-object-pass) (class shader-entity-class))
(let ((effective-class (determine-effective-shader-class class)))
(let ((effective-class (effective-shader-class class)))
(unless (gethash effective-class (assets pass))
(let ((program (make-pass-shader-program pass effective-class)))
(when (gl-name (framebuffer pass))
@@ -203,17 +196,18 @@
(define-shader-pass single-shader-pass (bakable)
((shader-program :initform NIL :accessor shader-program)))
(defmethod notify-class-redefinition ((pass single-shader-pass) class)
(when (eql class (class-of pass))
(let* ((old (shader-program pass))
(new (make-class-shader-program pass)))
(when (and old (gl-name old))
(with-context (*context*)
(dolist (shader (dependencies new))
(unless (gl-name shader) (load shader)))
(load new)
(deallocate old)))
(setf (shader-program pass) new))))
(define-handler (single-shader-pass class-changed) (ev)
(let ((pass single-shader-pass))
(when (eql (changed-class ev) (class-of pass))
(let* ((old (shader-program pass))
(new (make-class-shader-program pass)))
(when (and old (gl-name old))
(with-context (*context*)
(dolist (shader (dependencies new))
(unless (gl-name shader) (load shader)))
(load new)
(deallocate old)))
(setf (shader-program pass) new)))))
(defmethod bake ((pass single-shader-pass))
(setf (shader-program pass) (make-class-shader-program pass)))
View
@@ -14,11 +14,9 @@
(:metaclass shader-subject-class))
(defmacro define-shader-subject (&environment env name direct-superclasses direct-slots &rest options)
(unless (find-if (lambda (c) (c2mop:subclassp (find-class c T env) 'shader-subject)) direct-superclasses)
(setf direct-superclasses (append direct-superclasses (list 'shader-subject))))
(setf direct-superclasses (append direct-superclasses (list 'shader-subject)))
(unless (find :metaclass options :key #'first)
(push '(:metaclass shader-subject-class) options))
`(eval-when (:compile-toplevel :load-toplevel :execute)
(defclass ,name ,direct-superclasses
,direct-slots
,@options)))
`(defclass ,name ,direct-superclasses
,direct-slots
,@options))
Oops, something went wrong.

0 comments on commit 3a5f4ef

Please sign in to comment.