-
-
Notifications
You must be signed in to change notification settings - Fork 42
/
shader-program.lisp
114 lines (104 loc) · 4.75 KB
/
shader-program.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
#|
This file is a part of trial
(c) 2017 Shirakumo http://tymoon.eu (shinmera@tymoon.eu)
Author: Nicolas Hafner <shinmera@tymoon.eu>
|#
(in-package #:org.shirakumo.fraf.trial)
(defclass shader-program (gl-resource)
((uniform-map :initform (make-hash-table :test 'equal) :accessor uniform-map)
(shaders :initarg :shaders :accessor shaders))
(:default-initargs
:shaders (error "SHADERS required.")))
(defun check-shader-compatibility (shaders)
(loop with table = (make-hash-table :test 'eql)
for shader in shaders
do (if (gethash (shader-type shader) table)
(error "Cannot compile two shaders of the same type into a single program~% ~a~% ~a"
(gethash (shader-type shader) table) shader)
(setf (gethash (shader-type shader) table) shader))
finally (return shaders)))
(defmethod destructor ((program shader-program))
(let ((prog (gl-name program)))
(lambda () (gl:delete-program prog))))
(defmethod dependencies ((program shader-program))
(copy-list (shaders program)))
(defmethod allocate ((program shader-program))
(let ((shaders (shaders program)))
(check-shader-compatibility shaders)
(let ((prog (gl:create-program)))
(with-cleanup-on-failure (gl:delete-program prog)
(dolist (shader shaders)
(check-allocated shader)
(gl:attach-shader prog (gl-name shader)))
(gl:link-program prog)
(dolist (shader shaders)
(gl:detach-shader prog (gl-name shader)))
(unless (gl:get-program prog :link-status)
(error "Failed to link ~a: ~%~a"
program (gl:get-program-info-log prog)))
(v:debug :trial.asset "Linked ~a with ~a." program shaders)
(setf (data-pointer program) prog)))))
(defmethod deallocate :after ((program shader-program))
(clrhash (uniform-map program)))
(declaim (inline %set-uniform))
(defun %set-uniform (location data)
(declare (optimize speed))
(declare (type (signed-byte 32) location))
(etypecase data
(vec4 (%gl:uniform-4f location (vx data) (vy data) (vz data) (vw data)))
(vec3 (%gl:uniform-3f location (vx data) (vy data) (vz data)))
(vec2 (%gl:uniform-2f location (vx data) (vy data)))
(mat4 #+sbcl
(let ((data (marr4 data)))
(sb-sys:with-pinned-objects (data)
(%gl:uniform-matrix-4fv location 1 T (sb-sys:vector-sap data))))
#-sbcl
(gl:uniform-matrix-4fv location (marr4 data)))
(mat3 #+sbcl
(let ((data (marr3 data)))
(sb-sys:with-pinned-objects (data)
(%gl:uniform-matrix-3fv location 1 T (sb-sys:vector-sap data))))
#-sbcl
(gl:uniform-matrix-3fv location (marr3 data)))
(mat2 #+sbcl
(let ((data (marr2 data)))
(sb-sys:with-pinned-objects (data)
(%gl:uniform-matrix-2fv location 1 T (sb-sys:vector-sap data))))
#-sbcl
(gl:uniform-matrix-2fv location (marr2 data)))
(single-float (%gl:uniform-1f location data))
(double-float (%gl:uniform-1d location data))
(fixnum (%gl:uniform-1i location data))
(matn (ecase (mrows data)
(2 (ecase (mcols data)
(3 (gl:uniform-matrix-2x3-fv location (marrn data)))
(4 (gl:uniform-matrix-2x4-fv location (marrn data)))))
(3 (ecase (mcols data)
(2 (gl:uniform-matrix-3x2-fv location (marrn data)))
(4 (gl:uniform-matrix-3x4-fv location (marrn data)))))
(4 (ecase (mcols data)
(2 (gl:uniform-matrix-4x2-fv location (marrn data)))
(3 (gl:uniform-matrix-4x3-fv location (marrn data)))))))))
(defun (setf uniform) (data asset name)
(declare (optimize speed))
(let* ((name (etypecase name
(string name)
(symbol (symbol->c-name name))))
(location (or (gethash name (uniform-map asset))
(setf (gethash name (uniform-map asset))
(gl:get-uniform-location (gl-name asset) name)))))
(%set-uniform location data)))
(define-compiler-macro (setf uniform) (&whole whole &environment env data asset name)
(cond ((constantp name env)
(let ((nameg (gensym "NAME")) (assetg (gensym "ASSET")))
`(let ((,nameg (load-time-value
(etypecase ,name
(string ,name)
(symbol (symbol->c-name ,name)))))
(,assetg ,asset))
(%set-uniform (or (gethash ,nameg (uniform-map ,assetg))
(setf (gethash ,nameg (uniform-map ,assetg))
(gl:get-uniform-location (gl-name ,assetg) ,nameg)))
,data))))
(T
whole)))