Renaud Casenave-Péré
f5a324bf4e
Compile all the defined shaders and programs at startup Catch every errors and provide some restarts after properly cleaning up half-way compiled stuffs
145 lines
6.2 KiB
Common Lisp
145 lines
6.2 KiB
Common Lisp
#|
|
|
This file is a part of stoe project.
|
|
Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
|
|
|#
|
|
|
|
(in-package :cl-user)
|
|
(defpackage stoe.shader
|
|
(:nicknames :shader)
|
|
(:use :cl :utils)
|
|
(:export :defshader
|
|
:defprogram
|
|
:compile-all-shaders
|
|
:destroy-all-shaders))
|
|
(in-package :stoe.shader)
|
|
|
|
(defpackage %stoe.shaders
|
|
(:documentation "Package used to hold the symbols for the shader programs defined by defprogram."))
|
|
|
|
(defstruct program
|
|
(name "" :read-only t)
|
|
(stages nil :read-only t)
|
|
attribs
|
|
uniforms
|
|
gl-program)
|
|
|
|
(defvar *shader-db* (make-hash-table :test 'eq)
|
|
"The database containing all the shaders defined with `defshader'.")
|
|
|
|
(defun %defshader (name args body)
|
|
(setf (gethash name *shader-db*) (glsl-compiler:make-shader name args body)))
|
|
|
|
(defmacro defshader (name args &body body)
|
|
"Define a new shader in common-lisp style.
|
|
The shader will be compiled in shader language and added to the pool."
|
|
`(stoe.shader::%defshader ',name ',args ',body))
|
|
|
|
(defun %defprogram (name args body)
|
|
(declare (ignore args))
|
|
(let ((components (mapcar #'(lambda (comp)
|
|
(cons (first comp) (gethash (second comp) *shader-db*)))
|
|
(group body 2))))
|
|
(make-program :name (symbol-name name) :stages components)))
|
|
|
|
(defmacro defprogram (name args &body body)
|
|
"Define a new program comprised of all the specified shaders."
|
|
(let ((symbol (intern (symbol-name name) :%stoe.shaders)))
|
|
`(progn
|
|
(set ',symbol (stoe.shader::%defprogram ',symbol ',args ',body))
|
|
',symbol)))
|
|
|
|
(defun compile-shader (type shader)
|
|
"Compile the shader into opengl."
|
|
(let ((shader-obj (gl-utils:gl-assert (gl:create-shader type))))
|
|
(when (= shader-obj 0)
|
|
(error "Couldn't create shader object."))
|
|
(handler-case
|
|
(progn
|
|
(gl-utils:gl-assert (gl:shader-source shader-obj (glsl-compiler::shader-code shader))) ; Not great…
|
|
(gl-utils:gl-assert (gl:compile-shader shader-obj))
|
|
(unless (gl:get-shader shader-obj :compile-status)
|
|
(error "Compile failure in ~(~s~) shader:~%~2i~a~%" type (gl:get-shader-info-log shader-obj)))
|
|
shader-obj)
|
|
(error (condition)
|
|
(gl:delete-shader shader-obj)
|
|
(error condition)))))
|
|
|
|
(defun initialize-program (program)
|
|
"Initialize the program.
|
|
Retrieve the attributes and uniform locations."
|
|
(let* ((shader (cdr (first (program-stages program))))
|
|
(inputs (glsl-compiler::shader-inputs shader))
|
|
(uniforms (glsl-compiler::shader-uniforms shader)))
|
|
(labels ((get-var-with-location (var fun)
|
|
(list (glsl-compiler::sh-variable-name var)
|
|
(glsl-compiler::sh-variable-type var)
|
|
(glsl-compiler::sh-variable-array var)
|
|
(aif (glsl-compiler::sh-variable-location var)
|
|
it
|
|
(apply fun (program-gl-program program) (list (glsl-compiler::fix-name-convention
|
|
(glsl-compiler::sh-variable-name var)))))))
|
|
(get-attrib (var)
|
|
(get-var-with-location var #'gl:get-attrib-location))
|
|
(get-uniforms (var)
|
|
(get-var-with-location var #'gl:get-uniform-location)))
|
|
(setf (program-attribs program) (mapcar #'get-attrib inputs))
|
|
(setf (program-uniforms program) (mapcar #'get-uniforms uniforms)))))
|
|
|
|
(defun compile-program (program-symbol)
|
|
"Compile and link the program."
|
|
(loop
|
|
(restart-case
|
|
(return
|
|
(let ((program (symbol-value program-symbol)))
|
|
(unless program
|
|
(error "The program ~s is undefined." program-symbol))
|
|
(let (compiled-shaders)
|
|
(unwind-protect
|
|
(progn
|
|
(loop for shader in (program-stages program)
|
|
do (push (compile-shader (car shader) (cdr shader)) compiled-shaders))
|
|
(let ((program-obj (gl-utils:gl-assert (gl:create-program))))
|
|
(when (= program-obj 0)
|
|
(error "Couldn't create program object."))
|
|
(unwind-protect
|
|
(progn
|
|
(mapc (lambda (shader) (gl-utils:gl-assert (gl:attach-shader program-obj shader)))
|
|
compiled-shaders)
|
|
(gl-utils:gl-assert (gl:link-program program-obj))
|
|
(unless (gl:get-program program-obj :link-status)
|
|
(error "Link failure in shader program ~s:~%~2i~a~%" program-symbol
|
|
(gl:get-program-info-log program-obj)))
|
|
(setf (program-gl-program program) program-obj)
|
|
(initialize-program program))
|
|
(mapc (lambda (shader) (gl:detach-shader program-obj shader))
|
|
(gl:get-attached-shaders program-obj)))))
|
|
(mapc (lambda (shader) (gl:delete-shader shader)) compiled-shaders)))))
|
|
(retry () :report (lambda (stream) (format stream "Retry compiling the shader program ~S." program-symbol))))))
|
|
|
|
(defun delete-program (program-symbol)
|
|
"Delete the program bound to PROGRAM-SYMBOL."
|
|
(let ((program (symbol-value program-symbol)))
|
|
(when (program-gl-program program)
|
|
(gl:delete-program (program-gl-program program)))))
|
|
|
|
(defun compile-all-shaders ()
|
|
"Compile and link all the shaders into opengl."
|
|
(let ((cmp-message "Compiling shaders")
|
|
;; Count the columns used by the progress message
|
|
;; if it goes on for more than max-columns, continue on the next line
|
|
(max-columns 80))
|
|
(format t cmp-message)
|
|
(loop for i upfrom (length cmp-message)
|
|
for program-symbol being the symbol in :%stoe.shaders
|
|
do (progn
|
|
(when (> i max-columns)
|
|
(format t "~%")
|
|
(setf i 0))
|
|
(format t ".")
|
|
(compile-program program-symbol)))))
|
|
|
|
(defun destroy-all-shaders ()
|
|
"Destroy the programs registered in opengl."
|
|
(format t "Deleting shaders")
|
|
(loop for program-symbol being the symbol in :%stoe.shaders
|
|
do (delete-program program-symbol)))
|