CAPI Cookbook - Multi-Process Dolist

Multi-Process Dolist

LispWorks Version 6 introduced several routines to make it easier to make Lisp programs take advantage of multiple processors, or multiple cores, on recent computers. This macro provides a dolist function which can be used to perform time consuming parts of a Lisp application in parallel. In addition, it provides a progress indicator to give feedback about the progress of the calculation:

Complete listing

Example

To use the macro simply replace a dolist form with mp-dolist:

(defun demo1 (n)
  (mp-dolist (x *numbers* :title "Largest factor" :processes n)
      (setf (car x) (divisor (car x)))))

This example modifies the list *numbers* to replace each number with its smallest factor. The parameter n specifies how many processes we want to use. We test it with a list of large numbers to factorize:

(defparameter
    *numbers*
  '((1000252000747) (1000264007623) (1000250007881) (1000250008229) (1000280016119)
    (1000304021879) (1000292019107) (1000304022743) (1000304022143) (1000310024009)))

and this simple-minded routine to find the smallest prime factor of a number:

(defun divisor (n)
  (let ((test 2))
    (loop
     (when (> (* test test) n) (return nil))
     (when (zerop (rem n test)) (return test))
     (incf test))))

When called with:

(time (demo 1))

the routine runs in a single process and gives the result:

Timing the evaluation of (DEMO1 1)
Elapsed time =        4.943

Running it with:

(time (demo1 2))

runs it in two processes and gives the following result:

Timing the evaluation of (DEMO1 2)
Elapsed time =        3.355

The definition

First we define the progress bar class:

(defclass progress-bar (capi:interface)
  ((bar :initarg :bar :accessor bar)))

The routine make-bar displays the progress bar, and provides a :destroy-callback function to cancel all the running processes if you click the Cancel button:

(defun make-bar (end semaphore &optional (title "Progress"))
  (let ((bar (make-instance 'capi:progress-bar
                            :x 11 :y 40 :external-min-width 200
                            :external-min-height 12 :start 0 :end end))
        (cancel (make-instance 'capi:push-button :text "Cancel"
                               :callback-type :interface :callback #'capi:destroy)))
    (capi:display
     (make-instance 
      'progress-bar 
      :bar bar :title title :owner (capi:convert-to-screen nil)
      :destroy-callback
      #'(lambda (interface)
          (declare (ignore interface))
          (let ((w (mp:semaphore-wait-count semaphore)))
            (when (and w (plusp w))
              (mp:semaphore-release semaphore :count w))))
      :layout (make-instance 'capi:row-layout :adjust :center
                             :description (list bar cancel))))))

The routine update-bar is called to move the progress-bar slug:

(defun update-bar (progress value)
  (setf (capi:range-slug-start (bar progress)) value))

Finally here's the definition of mp-dolist:

(defmacro mp-dolist ((x list &key title (processes 1)) &body body)
  "Executes the body with x equal to each item in list,
   using 4 processes and with a progress bar."
  (let ((l (gensym)) (n (gensym)) (p (gensym)))
    `(let* ((,l ,list)
            (semaphore (mp:make-semaphore))
            (max (length ,l))
            (completed (list -1))
            (jump (ceiling max (* *progress-bar-length* 4)))
            (bar (make-bar max semaphore ,title))
            processes)
       (unwind-protect
           (progn
             (dotimes (,p ,processes)
               (push
                (mp:process-run-function 
                 "Dolist-mp" nil
                 #'(lambda (completed semaphore)
                     (loop
                      (let ((,n (sys:atomic-incf (car completed))))
                        (when (>= ,n max) (return))
                        (let ((,x (nth ,n ,l)))
                          (when (zerop (rem ,n jump)) (update-bar bar ,n))
                          ,@body)))
                     (mp:semaphore-release semaphore))
                 completed semaphore)
                processes))
             (mp:semaphore-acquire semaphore :count (1+ ,processes)))
         (map nil #'mp:process-kill processes)
         (capi:destroy bar)))))

Using mp-dolist

As with the standard dolist macro, the body of a call to the mp-dolist macro:

(mp-dolist (x lst :title title :processes n)
  body)

is executed once with x bound to each element in the list lst. However, because the body is executed by different processes, we have to take care when accessing a shared resource.

The simplest approach is to lock accesses to a shared resource. For example, here's a version of the demo that pushes the results onto a list result, rather than modifying the original list of numbers, using a lock to prevent two processes from trying to update the list simultaneously:

(defun demo2 (n)
  (let ((lock (mp:make-lock))
        result)
    (mp-dolist (x *numbers* :title "Largest factor" :processes n)
      (let ((d (divisor (car x)))) 
        (mp:with-lock (lock) (push d result))))
    (nreverse result)))

Alternatively, we could use atomic instructions, but note that the atomic macros like atomic-incf don't work with lexical variables, so we have to make result a pointer to a list:

(defun demo3 (n)
  (let ((result (list nil)))
    (mp-dolist (x *numbers* :title "Largest factor" :processes n)
      (sys:atomic-push (divisor (car x)) (car result)))
    (nreverse (car result))))