Allow binding a callback to configure worker environments

Author: ruricolist

test/task-runner.lisp

@@ -91,3 +91,30 @@
     ;; Ensure correct results are returned by multi-threaded task-map
     ;; (in any order).
     (mapc (lambda (result) (is (member result results))) '(2 3 4))))
+
+(defvar *in-worker*)
+
+(deftest test-worker-env ()
+  "Using `*worker-funcall*' should change the environment of tasks
+launched directly as well as tasks launched from the task thread."
+  (is (not (boundp '*in-worker*)))
+  (let* ((thread-count 4)
+         (worker-fn
+           (lambda (fn)
+             (let ((*in-worker* t))
+               (funcall fn))))
+         (*worker-funcall* worker-fn)
+         boundp)
+    (task-map thread-count
+              (lambda (x)
+                (declare (ignore x))
+                (synchronized ('boundp)
+                  (push (boundp '*in-worker*) boundp))
+                (task-map thread-count
+                          (lambda (x)
+                            (declare (ignore x))
+                            (synchronized ('boundp)
+                              (push (boundp '*in-worker*) boundp)))
+                          (make-list thread-count)))
+              (make-list thread-count))
+    (is (every (eqls t) boundp))))

utility/task.lisp

@@ -114,6 +114,7 @@
   (:export
    :task-runner
    :*task-runner*
+   :*worker-funcall*
    :task-runner-jobs
    :task-runner-workers
    :task-runner-workers-count
@@ -164,6 +165,11 @@
 (defparameter *task-runner* nil
   "Bind *TASK-RUNNER* for worker threads")
 
+(defparameter *worker-funcall* #'funcall
+  "Function that invokes worker loop to run.
+When this value is bound when starting a task, the value is propagated
+through to any further tasks launched from the first task, and so on.")
+
 (defclass task ()
   ((object :initarg :object :accessor task-object))
   (:documentation "Base class for all task classes."))
@@ -274,10 +280,13 @@
   (defun task-runner-create-worker (runner)
     "Create a new worker thread."
     (let ((*default-special-bindings*
-           (acons '*task-runner* runner
-                  *default-special-bindings*)))
+            (list* (cons '*task-runner* runner)
+                   (cons '*worker-funcall* *worker-funcall*)
+                   *default-special-bindings*)))
       (with-lock-held ((task-runner-workers-lock runner))
-        (push (make-thread 'start-worker
+        (push (make-thread
+               (lambda ()
+                 (funcall *worker-funcall* #'start-worker))
                 :name (format nil "~A-~D" "software-mutator"
                               (incf worker-id)))
               (task-runner-workers runner))))))