Skip to content

Commit

Permalink
Concurrency overhaul
Browse files Browse the repository at this point in the history 
Data flow instead of continuations.
  • Loading branch information
@borodust
borodust committed Jan 2, 2017
1 parent 864bc12 commit 0164b1a
Show file tree
Hide file tree
Showing 18 changed files with 235 additions and 1,023 deletions.
49 changes: 24 additions & 25 deletions cl-bodge.asd
View file
Original file line number Diff line number Diff line change
Expand Up @@ -43,11 +43,10 @@
(:module concurrency
:serial t
:components ((:file "dispatch")
(:file "transform-dispatch")
(:file "dispatched-defun")
(:file "execution")
(:file "job-queue")
(:file "instance-lock")))
(:file "instance-lock")
(:file "async")))
(:file "properties")
(:file "engine")
(:file "generic-system")
Expand Down Expand Up @@ -232,27 +231,6 @@
:components ((:file "text")))))


(defsystem cl-bodge/resources
:description "Bodacious Game Engine .BRF resource handling"
:version "0.3.0"
:author "Pavel Korolev"
:mailto "dev@borodust.org"
:license "MIT"
:depends-on (cl-bodge/engine cl-bodge/utils cl-bodge/assets cl-bodge/graphics
cl-bodge/animation flexi-streams log4cl cl-fad
bodge-sndfile opticl)
:pathname "resources"
:serial t
:components ((:file "packages")
(:file "audio")
(:file "resource-loader")
(:file "basic-chunks")
(:file "simple-model-chunk")
(:file "image")
(:file "font")
(:file "converters")))


(defsystem cl-bodge/scenegraph
:description "Bodacious Game Engine scenegraph implementation"
:version "0.3.0"
Expand All @@ -261,7 +239,7 @@
:license "MIT"
:depends-on (cl-bodge/engine cl-bodge/utils cl-bodge/graphics cl-bodge/physics
cl-bodge/host cl-muth cl-bodge/animation cl-bodge/assets
cl-bodge/audio cl-bodge/resources)
cl-bodge/audio)
:pathname "scene"
:serial t
:components ((:file "packages")
Expand All @@ -274,6 +252,27 @@
(:file "model")))


(defsystem cl-bodge/resources
:description "Bodacious Game Engine .BRF resource handling"
:version "0.3.0"
:author "Pavel Korolev"
:mailto "dev@borodust.org"
:license "MIT"
:depends-on (cl-bodge/engine cl-bodge/utils cl-bodge/assets cl-bodge/graphics
cl-bodge/animation cl-bodge/scenegraph flexi-streams log4cl
cl-fad bodge-sndfile opticl)
:pathname "resources"
:serial t
:components ((:file "packages")
(:file "audio")
(:file "resource-loader")
(:file "basic-chunks")
(:file "simple-model-chunk")
(:file "image")
(:file "font")
(:file "converters")))


(defsystem cl-bodge/distribution
:description "Bodacious Game Engine distribution helpers"
:version "0.3.0"
Expand Down
95 changes: 95 additions & 0 deletions engine/concurrency/async.lisp
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,95 @@
(in-package :cl-bodge.concurrency)


(defmacro *> (invariant-n-opts condition-var &body body)
(declare (ignore invariant-n-opts condition-var body))
(error "*> cannot be used outside of flow operator"))


(defun nop (result error-p)
(declare (ignore result error-p)))


(declaim (ftype (function (* (or function null) * list function list) *) invariant-dispatch))
(defun invariant-dispatch (dispatcher result-callback invariant opts fn args)
(labels ((return-error (e)
(funcall result-callback (list e) t))
(dispatched ()
(handler-bind ((simple-error #'return-error))
(funcall result-callback
(multiple-value-list (apply fn args)) nil))))
(apply #'dispatch dispatcher #'dispatched :invariant invariant opts)))


(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)))))))


(defun dispatch-list-flow (list dispatcher result-callback args)
(labels ((dispatch-list (fn-list args)
(flet ((dispatch-next (result error-p)
(if error-p
(log:error "Error during serial flow dispatch: ~A" result)
(dispatch-list (rest fn-list) result))))
(if (null fn-list)
(funcall result-callback args nil)
(let ((flow-element (first fn-list)))
(if (listp flow-element)
(dispatch-list-flow flow-element dispatcher #'dispatch-next args)
(apply flow-element dispatcher #'dispatch-next args)))))))
(dispatch-list list args)))


(defun dispatch-parallel-flow (list dispatcher result-callback args)
(let ((n 0)
(lock (make-recursive-lock "~>"))
(flow-result (copy-tree list)))
(labels ((count-elements (root)
(if (listp root)
(loop for node in root summing (count-elements node))
1))
(resolve (callback-list)
(unless (null callback-list)
(let* ((element (car callback-list)))
(if (listp element)
(resolve element)
(flet ((%cons-result-callback (result error-p)
(when error-p
(log:error "Error during parralel flow dispatch: ~A"
result))
(setf (car callback-list) result)
(with-recursive-lock-held (lock) (decf n))
(when (= n 0)
(funcall result-callback flow-result nil))))
(resolve (cdr callback-list))
(apply element dispatcher #'%cons-result-callback args)))))))
(setf n (count-elements list))
(resolve flow-result))))


(defmacro >> (&body flow)
(with-gensyms (dispatcher result-callback args flow-tree)
`(lambda (,dispatcher ,result-callback &rest ,args)
(declare (type (or null (function (list t) *)) ,result-callback))
(let ((,flow-tree (list ,@flow)))
(dispatch-list-flow ,flow-tree ,dispatcher (or ,result-callback #'nop) ,args)))))


(defmacro define-flow (name (&rest lambda-list) &body body)
`(defun ,name ,lambda-list
(>> ,@body)))


(defmacro ~> (&body body)
(with-gensyms (dispatcher args result-callback flow)
`(lambda (,dispatcher ,result-callback &rest ,args)
(declare (type (or (function (list t) *) null) ,result-callback))
(let ((,flow (list ,@body)))
(dispatch-parallel-flow ,flow ,dispatcher (or ,result-callback #'nop) ,args)))))
66 changes: 1 addition & 65 deletions engine/concurrency/dispatch.lisp
View file
Original file line number Diff line number Diff line change
@@ -1,11 +1,6 @@
(in-package :cl-bodge.concurrency)


(declaim (special *active-dispatcher*
*active-callback-name*
*env*))


(defgeneric dispatch (dispatcher task &key &allow-other-keys)
(:method (dispatcher task &key &allow-other-keys)
nil))
Expand All @@ -25,6 +20,7 @@
,@body))
:name ,(format nil "~a" thread-name)))


(defmacro in-new-thread-waiting (thread-name &body body)
(with-gensyms (latch)
`(wait-with-latch (,latch)
Expand All @@ -35,63 +31,3 @@
,@body)
(open-latch ,latch))))
:name ,(format nil "~a" thread-name))))


(defun wait-for (&rest dispatching-forms)
(declare (ignore dispatching-forms))
(error "'wait-for' can be used inside dispatchable environment only"))


(defun wait-for* (&rest dispatching-forms)
(declare (ignore dispatching-forms))
(error "'wait-for*' can be used inside dispatchable environment only"))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defclass continuation () ())

(defgeneric generate-calling-code (continuation result)
(:method ((cont null) result) nil))


(defclass code-generator ()
((form :initarg :form :reader form-of)))

(defgeneric generate-code (generator parent-cont))

(defun codegen-p (o)
(subtypep (class-of o) 'code-generator))


(defgeneric traverse-form (type form))


(defun traverse-dispatch-body (body env &optional cont)
(let ((*env* env))
(declare (special *env*))
(let ((form (traverse-form (car body) body)))
(if (codegen-p form)
(generate-code form cont)
form))))


(defun make-funame/d (name &optional (prefix ""))
(format-symbol :ge.mt.gen "~a_~a_~a/D" prefix
(package-name (symbol-package name)) name))


(defmacro -> (&environment env (dispatcher &rest keys) &body body)
(with-gensyms (fn r)
(let ((transformed (traverse-dispatch-body `(progn ,@body) env)))
`(flet ((,fn ()
,(if-bound *active-callback-name*
(if *active-callback-name*
`(let (,r)
(unwind-protect
(setf ,r ,transformed)
(funcall #',*active-callback-name* ,r)))
transformed)
transformed)))
(dispatch ,dispatcher #',fn ,@keys)))))
30 changes: 0 additions & 30 deletions engine/concurrency/dispatched-defun.lisp
View file

This file was deleted.

2 changes: 2 additions & 0 deletions engine/concurrency/execution.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -32,6 +32,8 @@
(return-from interruptible))) ; leave loop
(t (lambda (e)
(log:error "Uncaught error during task execution: ~a" e)
(when-debugging
(break))
(return-from continued)))) ; continue looping
(funcall (pop-from (task-queue-of executor))))))))

Expand Down
Loading

0 comments on commit 0164b1a

Please sign in to comment.