Permalink
Find file
Fetching contributors…
Cannot retrieve contributors at this time
93 lines (83 sloc) 4.16 KB
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;;
;;;; ChanL example implementation of doing concurrency using futures instead of channels.
;;;;
;;;; Copyright © 2009 Kat Marchan, Adlai Chandrasekhar
;;;;
;;;; This file is derived from 'Eager Future'; see the file COPYRIGHT, in the top directory,
;;;; for the license information for that project.
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(in-package :chanl.examples)
;;; This example is similar to Eager Future's API.
;;; It demonstrates the value of channels as concurrency primitives.
(defstruct (future (:print-object (lambda (f s) (print-unreadable-object (f s :type t :identity t)))))
(channel (make-instance 'buffered-channel :size 1) :read-only t))
(define-condition execution-error (error)
((cause :initarg :cause :reader execution-error-cause)
(future :initarg :future :reader execution-error-future))
(:report (lambda (condition stream)
(format stream "~A errored during execution.~%Cause: ~A"
(execution-error-future condition)
(execution-error-cause condition)))))
(let ((sentinel (make-symbol (format nil "The future has performed an illegal ~
operation and will have to be shut down"))))
(defun yield (future)
"Yield the values returned by FUTURE. If FUTURE isn't ready to yield yet, block until it is."
(let ((yielded-values (recv (future-channel future))))
(send (future-channel future) yielded-values)
(if (eq sentinel (car yielded-values))
(error (cdr yielded-values))
(values-list yielded-values))))
(defun future-call (function &key (initial-bindings *default-special-bindings*)
(name "Anonymous FUTURE"))
"Executes FUNCTION in parallel and returns a future that will yield the return value of
that function. INITIAL-BINDINGS may be provided to create dynamic bindings inside the thread."
(let ((future (make-future)))
(pcall (lambda ()
(send (future-channel future)
(handler-case
(multiple-value-list (funcall function))
(condition (cause)
(cons sentinel (make-condition 'execution-error
:cause cause :future future))))))
:initial-bindings initial-bindings
:name name)
future))
) ; End sentinel closure
(defmacro future-exec ((&key initial-bindings name) &body body)
"Convenience macro that makes the lambda for you."
`(future-call (lambda () ,@body)
,@(when initial-bindings `(:initial-bindings ,initial-bindings))
,@(when name `(:name ,name))))
(defun future-select (&rest futures)
"Blocks until one of the futures in FUTURES (a sequence) is ready to yield,
then returns that future."
;; This is an improvement. However, we should try to find some way of not "thrashing". - Adlai
(setf futures (sort futures (lambda (a b) a b (zerop (random 2)))))
;; This is incorrect. SEND/RECV-BLOCKS-P should not be used outside of the internals. - syko
(loop for future = (find-if 'send-blocks-p futures :key 'future-channel)
when future return future))
(defmacro future-let ((&rest bindings) &body body)
(loop for (symbol . forms) in bindings
for future = (make-symbol (string symbol))
collect `(,future (future-exec (:name "FUTURE-LET Worker") ,@forms)) into futures
collect `(,symbol (yield ,future)) into variables
finally (return `(let ,futures (symbol-macrolet ,variables ,@body)))))
;; EXAMPLES> (defparameter *future* (future-exec () 'success))
;; *FUTURE*
;; EXAMPLES> (yield *future*)
;; SUCCESS
;; EXAMPLES> (yield (future-select (future-exec () (sleep 10) 'long)
;; (future-exec () (sleep 2) 'short)))
;; SHORT
;; EXAMPLES> (defparameter *future* (future-exec () (error "OHNOES")))
;; *FUTURE*
;; EXAMPLES> (yield *future*)
;; ...
;; #<FUTURE #x14FFE71E> errored during execution.
;; Cause: OHNOES
;; [Condition of type EXECUTION-ERROR]
;; ...
;; Invoking restart: Return to SLIME's top level.
;; ; Evaluation aborted.