stoe/shader/compiler.lisp

#|
  This file is a part of stoe project.
  Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
|#

(uiop:define-package :stoe/shader/compiler
    (:use :cl
          :stoe/core/utils
          :stoe/engine/gl-utils
          :stoe/engine/viewport
          :stoe/shader/shader
          :stoe/shader/glsl)
  (:export #:defshader
           #:defprogram
           #:compile-all-shaders
           #:destroy-all-shaders))
(in-package :stoe/shader/compiler)

(defvar *shaders-table* (make-hash-table))
(defvar *programs-table* (make-hash-table))

(defun %defshader (lambda-list body)
  (glsl-compile lambda-list body))

(defmacro defshader (name lambda-list &body body)
  "Define a shader defining function.
The newly created shader will be put in a special package: `%stoe.shaders'."
  `(progn
     (defparameter ,name (%defshader ',lambda-list ',body))
     (when (not (null (glsl-version)))
       (mapc (lambda (program)
               (delete-program program)
               (compile-program program)) (gethash ',name *shaders-table*)))))

(defun %defprogram (lambda-list body)
  (make-program lambda-list body))

(defun clean-dep (name shader-list)
  (loop for shader in (cdr shader-list) by #'cddr
        do (setf (gethash shader *shaders-table*)
                 (delete name (gethash shader *shaders-table*)))))

(defun add-dep (name shader-list)
  (loop for shader in (cdr shader-list) by #'cddr
        do (pushnew name (gethash shader *shaders-table*))))

(defmacro defprogram (name lambda-list &body body)
  "Define a new program comprised of all the specified shaders."
  `(progn
     (when (gethash ',name *programs-table*)
       (clean-dep ',name (gethash ',name *programs-table*)))
     (defparameter ,name (%defprogram ',lambda-list ',body))
     (setf (gethash ',name *programs-table*) ',body)
     (add-dep ',name ',body)
     (when (not (null (glsl-version)))
       (compile-program ',name))))

(defun compile-shader (type shader)
  "Compile the shader into opengl."
  (let ((shader-obj (gl-assert (gl:create-shader type))))
    (when (= shader-obj 0)
      (error "Couldn't create shader object."))
    (handler-case
        (progn
          (gl-assert (gl:shader-source shader-obj (glsl-print shader))
                     (gl:compile-shader shader-obj))
          (unless (gl:get-shader shader-obj :compile-status)
            (error "Compile failure in ~(~s~) shader:~%~a~%~2i~a~%" type
                   (glsl-print shader) (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."
  (flet ((retrieve-location (var)
           (unless (member :location (var-qualifiers var))
             (let ((target (var-target var)))
               (setf (var-qualifiers var)
                     (append (var-qualifiers var)
                             (list :location (funcall (cond
                                                        ((eq target :in) #'gl:get-attrib-location)
                                                        ((eq target :uniform) #'gl:get-uniform-location))
                                                      (program-id program)
                                                      (var-name var)))))))))
    (mapc #'retrieve-location (program-vars program))))

(defun compile-program (symbol)
  "Compile and link the program."
  (loop
     while (restart-case
               (let ((program (symbol-value symbol))
                     compiled-shaders)
                 (unless program
                   (error "The program ~s is undefined." symbol))
                 (unwind-protect
                      (progn
                        (loop for type in (program-stages program) by #'cddr
                           for shader in (cdr (program-stages program)) by #'cddr
                              do (push (compile-shader type (symbol-value shader)) compiled-shaders))
                        (let ((prog-id (gl-assert (gl:create-program))))
                          (when (= prog-id 0)
                            (error "Couldn't create program object."))
                          (unwind-protect
                               (progn
                                 (mapc (lambda (shader) (gl-assert (gl:attach-shader prog-id shader)))
                                       compiled-shaders)
                                 (gl-assert (gl:link-program prog-id))
                                 (unless (gl:get-program prog-id :link-status)
                                   (error "Link failure in shader program ~s:~%~2i~a~%" symbol
                                          (gl:get-program-info-log prog-id)))
                                 (setf (program-id program) prog-id)
                                 (initialize-program program))
                            (mapc (lambda (shader) (gl:detach-shader prog-id shader))
                                  (gl:get-attached-shaders prog-id)))))
                   (mapc (lambda (shader) (gl:delete-shader shader)) compiled-shaders))
                 nil)
             (retry ()
               :report (lambda (stream) (format stream "Retry compiling the shader program ~a."
                                                        symbol))
               t)
             (give-up ()
               :report (lambda (stream) (format stream "Give up on the shader program ~a."
                                                symbol))
               nil))))

(defun delete-program (symbol)
  "Delete the program."
  (let ((program (symbol-value symbol)))
    (when (program-id program)
      (gl:delete-program (program-id program))
      (setf (program-id program) nil))))

(defun compile-all-shaders ()
  "Compile and link all the shaders into opengl."
  (loop-with-progress "Compiling shaders"
     for symbol being the hash-key in *programs-table*
     do (progn
          (compile-program symbol)
          progress-step)))

(defun destroy-all-shaders ()
  "Destroy the programs registered in opengl."
  (loop-with-progress "Deleting shaders"
     for symbol being the hash-key in *programs-table*
     do (progn
          (delete-program symbol)
          progress-step)))