module/ice-9/futures.scm

   1 ;;; -*- mode: scheme; coding: utf-8; -*-
   2 ;;;
   3 ;;; Copyright (C) 2010 Free Software Foundation, Inc.
   4 ;;;
   5 ;;; This library is free software; you can redistribute it and/or
   6 ;;; modify it under the terms of the GNU Lesser General Public
   7 ;;; License as published by the Free Software Foundation; either
   8 ;;; version 3 of the License, or (at your option) any later version.
   9 ;;;
  10 ;;; This library is distributed in the hope that it will be useful,
  11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;; Lesser General Public License for more details.
  14 ;;;
  15 ;;; You should have received a copy of the GNU Lesser General Public
  16 ;;; License along with this library; if not, write to the Free Software
  17 ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 (define-module (ice-9 futures)
  20   #:use-module (srfi srfi-1)
  21   #:use-module (srfi srfi-9)
  22   #:use-module (ice-9 q)
  23   #:export (future make-future future? touch))
  24
  25 ;;; Author: Ludovic Courtès <ludo@gnu.org>
  26 ;;;
  27 ;;; Commentary:
  28 ;;;
  29 ;;; This module provides an implementation of futures, a mechanism for
  30 ;;; fine-grain parallelism.  Futures were first described by Henry Baker
  31 ;;; in ``The Incremental Garbage Collection of Processes'', 1977, and
  32 ;;; then implemented in MultiLisp (an implicit variant thereof, i.e.,
  33 ;;; without `touch'.)
  34 ;;;
  35 ;;; This modules uses a fixed thread pool, normally one per CPU core.
  36 ;;; Futures are off-loaded to these threads, when they are idle.
  37 ;;;
  38 ;;; Code:
  39
  40 \f
  41 ;;;
  42 ;;; Futures.
  43 ;;;
  44
  45 (define-record-type <future>
  46   (%make-future thunk done? mutex)
  47   future?
  48   (thunk     future-thunk)
  49   (done?     future-done?  set-future-done?!)
  50   (result    future-result set-future-result!)
  51   (mutex     future-mutex))
  52
  53 (define (make-future thunk)
  54   "Return a new future for THUNK.  Execution may start at any point
  55 concurrently, or it can start at the time when the returned future is
  56 touched."
  57   (let ((future (%make-future thunk #f (make-mutex))))
  58     (register-future! future)
  59     future))
  60
  61 \f
  62 ;;;
  63 ;;; Future queues.
  64 ;;;
  65
  66 (define %futures (make-q))
  67 (define %futures-mutex (make-mutex))
  68 (define %futures-available (make-condition-variable))
  69
  70 (define (register-future! future)
  71   ;; Register FUTURE as being processable.
  72   (lock-mutex %futures-mutex)
  73   (enq! %futures future)
  74   (signal-condition-variable %futures-available)
  75   (unlock-mutex %futures-mutex))
  76
  77 (define (process-future! future)
  78   ;; Process FUTURE, assuming its mutex is already taken.
  79   (set-future-result! future
  80                       (catch #t
  81                         (lambda ()
  82                           (call-with-values (future-thunk future)
  83                             (lambda results
  84                               (lambda ()
  85                                 (apply values results)))))
  86                         (lambda args
  87                           (lambda ()
  88                             (apply throw args)))))
  89   (set-future-done?! future #t))
  90
  91 (define (process-futures)
  92   ;; Wait for futures to be available and process them.
  93   (lock-mutex %futures-mutex)
  94   (let loop ()
  95     (wait-condition-variable %futures-available
  96                              %futures-mutex)
  97     (or (q-empty? %futures)
  98         (let ((future (deq! %futures)))
  99           (lock-mutex (future-mutex future))
 100           (or (and (future-done? future)
 101                    (unlock-mutex (future-mutex future)))
 102               (begin
 103                 ;; Do the actual work.
 104
 105                 ;; We want to release %FUTURES-MUTEX so that other workers
 106                 ;; can progress.  However, to avoid deadlocks, we have to
 107                 ;; unlock FUTURE as well, to preserve lock ordering.
 108                 (unlock-mutex (future-mutex future))
 109                 (unlock-mutex %futures-mutex)
 110
 111                 (lock-mutex (future-mutex future))
 112                 (or (future-done? future)            ; lost the race?
 113                     (process-future! future))
 114                 (unlock-mutex (future-mutex future))
 115
 116                 (lock-mutex %futures-mutex)))))
 117     (loop)))
 118
 119 (define (touch future)
 120   "Return the result of FUTURE, computing it if not already done."
 121   (lock-mutex (future-mutex future))
 122   (or (future-done? future)
 123       (begin
 124         ;; Do the actual work.  Unlock FUTURE first to preserve lock
 125         ;; ordering.
 126         (unlock-mutex (future-mutex future))
 127
 128         (lock-mutex %futures-mutex)
 129         (q-remove! %futures future)
 130         (unlock-mutex %futures-mutex)
 131
 132         (lock-mutex (future-mutex future))
 133         (or (future-done? future)            ; lost the race?
 134             (process-future! future))))
 135   (unlock-mutex (future-mutex future))
 136   ((future-result future)))
 137
 138 \f
 139 ;;;
 140 ;;; Workers.
 141 ;;;
 142
 143 (define %worker-count
 144   (if (provided? 'threads)
 145       (- (current-processor-count) 1)
 146       0))
 147
 148 (define %workers
 149   ;; A dock of workers that stay here forever.
 150
 151   ;; TODO
 152   ;; 1. Allocate lazily.
 153   ;; 2. Allow the pool to be shrunk, as in libgomp (though that we'd
 154   ;;    need semaphores, which aren't yet in libguile!).
 155   ;; 3. Provide a `worker-count' fluid.
 156   (unfold (lambda (i) (>= i %worker-count))
 157           (lambda (i)
 158             (call-with-new-thread process-futures))
 159           1+
 160           0))
 161
 162 \f
 163 ;;;
 164 ;;; Syntax.
 165 ;;;
 166
 167 (define-syntax future
 168   (syntax-rules ()
 169     "Return a new future for BODY."
 170     ((_ body)
 171      (make-future (lambda () body)))))