Loosely match dataflow function's arguments

borodust · Jan 2, 2017 · 4e3a7e3 · 4e3a7e3
1 parent d5d3948
commit 4e3a7e3
Show file tree

Hide file tree

Showing 5 changed files with 46 additions and 15 deletions.
diff --git a/assets/registry.lisp b/assets/registry.lisp
@@ -30,8 +30,8 @@
          do (release-asset (gethash name asset-table) name)))))
 
 
-(defun get-asset (registry name)
-  (with-instance-lock-held (registry)
-    (with-slots (asset-table) registry
-      (when-let ((entry (gethash name asset-table)))
-        (load-asset entry name)))))
+(define-flow get-asset (registry name)
+  (with-slots (asset-table) registry
+    (if-let ((loader (gethash name asset-table)))
+      (-> loader () (load-asset loader name))
+      (null-flow))))
diff --git a/engine/concurrency/async.lisp b/engine/concurrency/async.lisp
@@ -21,15 +21,33 @@
     (apply #'dispatch dispatcher #'dispatched :invariant invariant opts)))
 
 
+(defun insert-rest-arg (lambda-list name)
+  (multiple-value-bind (required optional rest key)
+      (parse-ordinary-lambda-list lambda-list)
+    (if rest
+        (values lambda-list nil)
+        (values (append required
+                        (when optional
+                          (append (list '&optional) optional))
+                        (list '&rest name)
+                        (when key
+                          (append (list '&key) key)))
+                t))))
+
+
 (defmacro -> (invariant-n-opts lambda-list &body body)
   (destructuring-bind (invariant &rest opts) (ensure-list invariant-n-opts)
-    (with-gensyms (dispatcher body-fn args result-callback)
-      `(lambda (,dispatcher ,result-callback &rest ,args)
-         (declare (ignorable ,args))
-         (flet ((,body-fn ,lambda-list
-                  ,@body))
-           (invariant-dispatch ,dispatcher (or ,result-callback #'nop) ,invariant (list ,@opts)
-                               #',body-fn ,(when (not (null lambda-list)) args)))))))
+    (with-gensyms (dispatcher body-fn args result-callback rest-arg)
+      (multiple-value-bind (new-lambda-list new-rest-p) (insert-rest-arg lambda-list rest-arg)
+        `(lambda (,dispatcher ,result-callback &rest ,args)
+           (declare (ignorable ,args))
+           (flet ((,body-fn ,new-lambda-list
+                    ,@(when new-rest-p
+                        `((declare (ignore ,rest-arg))))
+                    ,@body))
+                    (invariant-dispatch ,dispatcher (or ,result-callback #'nop)
+                                        ,invariant (list ,@opts)
+                                        #',body-fn ,(when (not (null lambda-list)) args))))))))
 
 
 (defun dispatch-list-flow (list dispatcher result-callback args)

diff --git a/engine/engine.lisp b/engine/engine.lisp
@@ -177,14 +177,22 @@
 
 
 (defmethod dispatch ((this bodge-engine) (task function) &rest keys &key (priority :medium)
-                                                                      invariant)
+                                                                      invariant same-thread-p)
   (with-slots (shared-pool) this
     (etypecase invariant
-      ((or null symbol) (execute shared-pool task :priority priority))
+      (null (execute shared-pool task :priority priority))
+      (symbol (ecase invariant
+                (:generic (if same-thread-p
+                              (funcall task)
+                              (execute shared-pool task :priority priority)))))
       (dispatcher (apply #'dispatch invariant task keys)))
     t))
 
 
+(define-flow null-flow ()
+  (-> (:generic :same-thread-p t) ()))
+
+
 (defun run (fn)
   (funcall fn (engine) nil))
 

diff --git a/engine/packages.lisp b/engine/packages.lisp
@@ -120,6 +120,7 @@
 
            dispatcher
            run
+           null-flow
 
            system-object
            system-of

diff --git a/graphics/shader-loader.lisp b/graphics/shader-loader.lisp
@@ -1,7 +1,7 @@
 (in-package :cl-bodge.graphics)
 
 
-(defclass shader-loader ()
+(defclass shader-loader (dispatcher)
   ((assets :initform (make-hash-table :test 'equal))))
 
 
@@ -14,6 +14,10 @@
                 prog))))
 
 
+(defmethod dispatch ((this shader-loader) (task function) &rest keys &key)
+  (apply #'dispatch (graphics) task keys))
+
+
 (defmethod asset-names ((this shader-loader))
   (loop for key being the hash-key of (slot-value this 'assets)
        collecting key))