/examples/futures.lisp

 1;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
 2;;;;
 3;;;; ChanL example implementation of doing concurrency using futures instead of channels.
 4;;;;
 5;;;; Copyright © 2009 Kat Marchan, Adlai Chandrasekhar
 6;;;;
 7;;;; This file is derived from 'Eager Future'; see the file COPYRIGHT, in the top directory,
 8;;;; for the license information for that project.
 9;;;;
10;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
11(in-package :chanl.examples)
12
13;;; This example is similar to Eager Future's API.
14;;; It demonstrates the value of channels as concurrency primitives.
15
16(defstruct (future (:print-object (lambda (f s) (print-unreadable-object (f s :type t :identity t)))))
17  (channel (make-instance 'buffered-channel :size 1) :read-only t))
18
19(define-condition execution-error (error)
20  ((cause :initarg :cause :reader execution-error-cause)
21   (future :initarg :future :reader execution-error-future))
22  (:report (lambda (condition stream)
23             (format stream "~A errored during execution.~%Cause: ~A"
24                     (execution-error-future condition)
25                     (execution-error-cause condition)))))
26
27(let ((sentinel (make-symbol (format nil "The future has performed an illegal ~
28                                          operation and will have to be shut down"))))
29  (defun yield (future)
30    "Yield the values returned by FUTURE. If FUTURE isn't ready to yield yet, block until it is."
31    (let ((yielded-values (recv (future-channel future))))
32      (send (future-channel future) yielded-values)
33      (if (eq sentinel (car yielded-values))
34          (error (cdr yielded-values))
35          (values-list yielded-values))))
36
37  (defun future-call (function &key (initial-bindings *default-special-bindings*)
38                      (name "Anonymous FUTURE"))
39    "Executes FUNCTION in parallel and returns a future that will yield the return value of
40that function. INITIAL-BINDINGS may be provided to create dynamic bindings inside the thread."
41    (let ((future (make-future)))
42      (pcall (lambda ()
43               (send (future-channel future)
44                     (handler-case
45                         (multiple-value-list (funcall function))
46                       (condition (cause)
47                         (cons sentinel (make-condition 'execution-error
48                                                        :cause cause :future future))))))
49             :initial-bindings initial-bindings
50             :name name)
51      future))
52  ) ; End sentinel closure
53
54(defmacro future-exec ((&key initial-bindings name) &body body)
55  "Convenience macro that makes the lambda for you."
56  `(future-call (lambda () ,@body)
57                ,@(when initial-bindings `(:initial-bindings ,initial-bindings))
58                ,@(when name `(:name ,name))))
59
60(defun future-select (&rest futures)
61  "Blocks until one of the futures in FUTURES (a sequence) is ready to yield,
62then returns that future."
63  ;; This is an improvement. However, we should try to find some way of not "thrashing". - Adlai
64  (setf futures (sort futures (lambda (a b) a b (zerop (random 2)))))
65  ;; This is incorrect. SEND/RECV-BLOCKS-P should not be used outside of the internals. - syko
66  (loop for future = (find-if 'send-blocks-p futures :key 'future-channel)
67     when future return future))
68
69(defmacro future-let ((&rest bindings) &body body)
70  (loop for (symbol . forms) in bindings
71     for future = (make-symbol (string symbol))
72     collect `(,future (future-exec (:name "FUTURE-LET Worker") ,@forms)) into futures
73     collect `(,symbol (yield ,future)) into variables
74     finally (return `(let ,futures (symbol-macrolet ,variables ,@body)))))
75
76;; EXAMPLES> (defparameter *future* (future-exec () 'success))
77;; *FUTURE*
78;; EXAMPLES> (yield *future*)
79;; SUCCESS
80;; EXAMPLES> (yield (future-select (future-exec () (sleep 10) 'long)
81;;                                 (future-exec () (sleep 2) 'short)))
82;; SHORT
83;; EXAMPLES> (defparameter *future* (future-exec () (error "OHNOES")))
84;; *FUTURE*
85;; EXAMPLES> (yield *future*)
86;; ...
87;; #<FUTURE #x14FFE71E> errored during execution.
88;; Cause: OHNOES
89;;    [Condition of type EXECUTION-ERROR]
90;; ...
91;; Invoking restart: Return to SLIME's top level.
92;; ; Evaluation aborted.