-
-
Notifications
You must be signed in to change notification settings - Fork 46
/
pipeline.lisp
322 lines (300 loc) · 15.1 KB
/
pipeline.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
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
(in-package #:org.shirakumo.fraf.trial)
(defclass pipeline ()
((nodes :initform NIL :accessor nodes)
(passes :initform #() :accessor passes)
(textures :initform #() :accessor textures)
(texspecs :initform #() :accessor texspecs)))
(defmethod finalize ((pipeline pipeline))
(clear pipeline))
(defmethod flow:sever ((pipeline pipeline))
(loop for pass across (passes pipeline)
do (flow:sever pass))
(setf (nodes pipeline) NIL))
(defmethod enter ((pass shader-pass) (pipeline pipeline))
(pushnew pass (nodes pipeline)))
(defmethod leave ((pass shader-pass) (pipeline pipeline))
(setf (nodes pipeline) (delete pass (nodes pipeline))))
(defmethod clear-pipeline ((pipeline pipeline))
(loop for tex across (textures pipeline)
do (finalize tex))
(loop for pass across (passes pipeline)
do (when (framebuffer pass)
(finalize (framebuffer pass))
(setf (framebuffer pass) NIL))
(flow:sever pass)
(remove-listener pass pipeline))
(setf (nodes pipeline) ())
(setf (passes pipeline) #())
(setf (textures pipeline) #())
(setf (texspecs pipeline) #()))
(defmethod connect ((source flow:port) (target flow:port) (pipeline pipeline))
(flet ((enter-if-new (node)
(unless (find node (nodes pipeline))
(if (eq pipeline (container node))
(pushnew node (nodes pipeline))
(enter node pipeline)))))
(enter-if-new (flow:node source))
(enter-if-new (flow:node target)))
(flow:connect source target 'flow:directed-connection)
pipeline)
(defmacro connect* (pipeline &body parts)
(let ((data (loop for data in parts
collect (list* (gensym "PASS") (enlist data))))
(pipeg (gensym "PIPELINE")))
`(let ((,pipeg ,pipeline)
,@(loop for (gens val) in data collect `(,gens ,val)))
,@(if (rest data)
(loop for ((a a_ ai_ ao) (b b_ bi bo_)) on data
while b
collect `(connect (port ,a ',(or ao 'color)) (port ,b ',(or bi 'previous-pass)) ,pipeg))
`((enter ,(caar data) ,pipeg)))
,pipeg)))
(defmacro construct-pipeline (pipeline passes &body connections)
(let ((pipelineg (gensym "PIPELINE")))
(labels ((process-connection (connection)
(case (car connection)
(:if
(destructuring-bind (test then else) (rest connection)
`(cond (,test
,@(process-connections then))
(T
,@(process-connections else)))))
(:case
(destructuring-bind (test . cases) (rest connection)
`(case ,test
,@(loop for (case . then) in cases
collect `(,case ,@(process-connections then))))))
(:when
(destructuring-bind (test . then) (rest connection)
`(when ,test
,@(process-connections then))))
(:unless
(destructuring-bind (test . then) (rest connection)
`(unless ,test
,@(process-connections then))))
(T
(let* ((sequence (loop for a in connection until (keywordp a) collect a))
(kargs (loop for a = (car connection) until (keywordp a) while connection do (pop connection)))
(body (loop for a in sequence
for b in (rest sequence)
for (a-pass a_ a-port) = (enlist a NIL 'color)
for (b-pass b-port b_) = (enlist b 'previous-pass NIL)
collect `(connect (port ,a-pass ',a-port) (port ,b-pass ',b-port) ,pipelineg))))
(if (getf kargs :when)
`(when ,(getf kargs :when) ,@body)
`(progn ,@body))))))
(process-connections (connections)
(loop for connection in connections
collect (process-connection connection))))
`(let* ((,pipelineg ,pipeline)
,@(loop for pass in passes
for (type . args) = (enlist pass)
for name = (or (unquote (getf args :name)) type)
collect `(,name (ensure-instance (node ',name ,pipelineg) ,(if (listp type) type `',type)
:name ',name ,@args))))
(flow:sever ,pipelineg)
,@(process-connections connections)))))
(defmethod check-consistent ((pipeline pipeline))
(dolist (node (nodes pipeline))
(check-consistent node)))
(defun texspec-real-size (texspec width height)
(flet ((eval-size (size)
(eval `(let ((width (* ,width))
(height (* ,height)))
(declare (ignorable width height))
,size))))
(values (ceiling (eval-size (getf texspec :width)))
(ceiling (eval-size (getf texspec :height))))))
(defmethod resize ((pipeline pipeline) width height)
(let ((width (max 1 width))
(height (max 1 height)))
(loop for texture across (textures pipeline)
for texspec across (texspecs pipeline)
do (multiple-value-bind (width height) (texspec-real-size texspec width height)
(resize texture width height)))
(loop for pass across (passes pipeline)
for binding = (when (framebuffer pass) (first (attachments (framebuffer pass))))
when binding ;; We have to do it like this to prevent updating FBOs with
;; texspecs that are not window-size.
do (setf (width (framebuffer pass)) (width (second binding)))
(setf (height (framebuffer pass)) (height (second binding))))))
(defmethod normalized-texspec ((texspec list))
(assert (= 0 (getf texspec :level 0)))
(assert (eql :dynamic (getf texspec :storage :dynamic)))
(let ((texspec (copy-list texspec)))
(unless (getf texspec :width)
(setf (getf texspec :width) 'width))
(unless (getf texspec :height)
(setf (getf texspec :height) 'height))
(unless (getf texspec :target)
(setf (getf texspec :target) :texture-2d))
texspec))
(defmethod normalized-texspec ((port texture-port))
(normalized-texspec (texspec port)))
(defmethod normalized-texspec ((port output))
(normalized-texspec
(append (texspec port)
;; Default internal format for attachments
(case (attachment port)
(:depth-attachment
(list :internal-format :depth-component
:min-filter :nearest
:mag-filter :nearest))
(:stencil-attachment
(list :internal-format :stencil-index
:min-filter :nearest
:mag-filter :nearest))
(:depth-stencil-attachment
(list :internal-format :depth-stencil
:min-filter :nearest
:mag-filter :nearest))
(T
(list :internal-format :rgba
:min-filter :linear
:mag-filter :linear))))))
(defun texture-texspec-matches-p (texture texspec width height)
(and (eq (internal-format texture) (getf texspec :internal-format))
(eq (target texture) (getf texspec :target))
(multiple-value-bind (w h) (texspec-real-size texspec width height)
(and (= w (width texture))
(= h (height texture))))
(eq (min-filter texture) (getf texspec :min-filter))
(eq (mag-filter texture) (getf texspec :mag-filter))))
(defun allocate-textures (passes textures texspec)
(flet ((kind (port)
;; FIXME: This is really dumb and inefficient. If we could remember which port belongs
;; to which joined texspec instead it could be much better and wouldn't need to
;; recompute everything all the time.
(and (and (typep port 'flow:out-port))
(join-texspec texspec (normalized-texspec port)))))
(flow:allocate-ports passes :sort NIL :test #'kind :attribute :texid)
(let* ((texture-count (loop for pass in passes
when (flow:ports pass)
maximize (loop for port in (flow:ports pass)
when (and (flow:attribute port :texid)
(kind port))
maximize (1+ (flow:attribute port :texid)))))
(offset (length textures)))
(adjust-array textures (+ offset texture-count) :initial-element NIL)
(dolist (pass passes textures)
(dolist (port (flow:ports pass))
(when (kind port)
;; FIXME: Recompute the minimal upgraded texspec across all shared
;; ports, as the partitioning done by the allocation mechanism
;; might have broken up texspecs that were initially grouped.
(let* ((texid (+ offset (flow:attribute port :texid)))
(texture (or (aref textures texid)
(apply #'make-instance 'texture texspec))))
(setf (aref textures texid) texture)
(setf (texture port) texture)
(dolist (connection (flow:connections port))
(setf (texture (flow:right connection)) texture)))))))))
(defmethod pack-pipeline ((pass shader-pass) width height)
;; Allocate port textures
(dolist (port (flow:ports pass))
(when (typep port '(and (or static-input flow:out-port) texture-port))
(let ((texture (apply #'make-instance 'texture (normalized-texspec port))))
(multiple-value-bind (width height) (texspec-real-size (texture-texspec texture) width height)
(setf (width texture) width)
(setf (height texture) height))
(setf (texture port) texture)
(dolist (connection (flow:connections port))
(setf (texture (flow:right connection)) texture)))))
(setf (framebuffer pass) (make-pass-framebuffer pass))
pass)
(defmethod pack-pipeline ((pipeline pipeline) width height)
(check-consistent pipeline)
(v:info :trial.pipeline "~a packing for ~ax~a" pipeline width height)
(let* ((passes (flow:topological-sort (nodes pipeline)))
(existing-textures (textures pipeline))
(textures (make-array 0 :initial-element NIL :fill-pointer 0 :adjustable T))
(texspecs (make-array 0 :initial-element NIL :fill-pointer 0 :adjustable T)))
;; KLUDGE: We need to do the intersection here to ensure that we remove passes
;; that are not part of this pipeline, but still connected to one of the
;; passes that *is* part of the pipeline.
(flet ((node-p (node) (find node (nodes pipeline))))
(setf passes (remove-if-not #'node-p passes)))
;; Compute minimised texture set
;; (let ((texspecs (loop for port in (mapcan #'flow:ports passes)
;; when (and (typep port 'flow:out-port)
;; (typep port 'texture-port))
;; collect (normalized-texspec port))))
;; (dolist (texspec (join-texspecs texspecs))
;; (allocate-textures passes textures texspec)))
;; Compute full texture set
(dolist (port (mapcan #'flow:ports passes))
(when (typep port '(and (or static-input flow:out-port) texture-port))
(let* ((texspec (normalized-texspec port))
(texture (loop for texture across existing-textures
do (when (and (not (find texture textures))
(texture-texspec-matches-p texture texspec width height))
(return texture))
finally (return (apply #'make-instance 'texture texspec)))))
(multiple-value-bind (width height) (texspec-real-size texspec width height)
(setf (width texture) width)
(setf (height texture) height))
(dolist (connection (flow:connections port))
(setf (texture (flow:right connection)) texture))
;; If we're dynamically updating then setting the texture now
;; will require it to be allocated to be bound...
(when (and (framebuffer (flow:node port))
(allocated-p (framebuffer (flow:node port)))
(not (allocated-p texture)))
(allocate texture))
(setf (slot-value port 'texture) texture)
(vector-push-extend texture textures)
(vector-push-extend texspec texspecs))))
;; Compute frame buffers
(dolist (pass passes)
(when (typep pipeline 'event-loop)
(add-listener pass pipeline))
(let ((fbo (make-pass-framebuffer pass)))
(cond ((not (framebuffer pass))
(setf (framebuffer pass) fbo))
((not (allocated-p (framebuffer pass)))
(setf (attachments (framebuffer pass)) (attachments fbo)))
(T
(dolist (attachment (attachments fbo))
(unless (allocated-p (second attachment))
(allocate (second attachment))))
(setf (width (framebuffer pass)) NIL)
(setf (height (framebuffer pass)) NIL)
(setf (attachments (framebuffer pass)) (attachments fbo))))))
;; Now re-set the activation to short-modify the pipeline as necessary.
(dolist (pass passes)
(setf (active-p pass) (active-p pass)))
;; All done.
(v:debug :trial.pipeline "~a pass order: ~a" pipeline passes)
(v:debug :trial.pipeline "~a texture count: ~a" pipeline (length textures))
(v:info :trial.pipeline "~a texture allocation: ~:{~%~a~:{~% ~a: ~a~}~}" pipeline
(loop for pass in passes
collect (list pass (loop for port in (flow:ports pass)
collect (list (flow:name port) (texture port))))))
(loop for pass across (passes pipeline)
do (unless (find pass passes)
(leave pass pipeline)
(flow:sever pass)
(finalize pass)))
(loop for texture across (textures pipeline)
do (unless (find texture textures)
(finalize texture)))
(setf (nodes pipeline) NIL)
(setf (passes pipeline) (coerce passes 'vector))
(setf (textures pipeline) textures)
(setf (texspecs pipeline) texspecs)))
(defmethod render ((pipeline pipeline) target)
(loop for pass across (passes pipeline)
do (when (active-p pass)
(render pass target))))
(defmethod blit-to-screen ((pipeline pipeline))
(let ((passes (passes pipeline)))
(loop for i downfrom (1- (length passes)) to 0
for pass = (aref passes i)
do (when (and (active-p pass) (framebuffer pass))
(blit-to-screen pass)
(return)))))
(defmethod stage ((pipeline pipeline) (area staging-area))
(loop for texture across (textures pipeline)
do (stage texture area))
(loop for pass across (passes pipeline)
do (stage pass area)))