guile-knots/knots/promise.scm

;;; Guile Knots
;;; Copyright © 2020 Christopher Baines <mail@cbaines.net>
;;;
;;; This file is part of Guile Knots.
;;;
;;; The Guile Knots is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;; published by the Free Software Foundation; either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; The Guile Knots is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with the guix-data-service.  If not, see
;;; <http://www.gnu.org/licenses/>.

(define-module (knots promise)
  #:use-module (srfi srfi-9)
  #:use-module (ice-9 match)
  #:use-module (ice-9 atomic)
  #:use-module (ice-9 exceptions)
  #:use-module (fibers)
  #:use-module (fibers conditions)
  #:use-module (knots)
  #:export (fibers-promise?

            fibers-delay
            fibers-delay/eager
            fibers-force
            fibers-promise-reset
            fibers-promise-result-available?))

(define-record-type <fibers-promise>
  (make-fibers-promise thunk values-box evaluated-condition)
  fibers-promise?
  (thunk                fibers-promise-thunk)
  (values-box           fibers-promise-values-box)
  (evaluated-condition  fibers-promise-evaluated-condition))
(set-procedure-property!
 (macro-transformer (module-ref (current-module) 'fibers-promise?))
 'documentation
 "Return @code{#t} if OBJ is a @code{<fibers-promise>}.")

(define (fibers-delay thunk)
  "Return a new fiber-aware promise that will evaluate THUNK when
first forced.  THUNK is not called until @code{fibers-force} is
called on the promise."
  (make-fibers-promise
   thunk
   (make-atomic-box #f)
   (make-condition)))

(define (fibers-force fp)
  "Force the fiber-aware promise FP, returning its values.

The first call evaluates the promise's thunk.  Concurrent callers
block on a condition variable until evaluation finishes, then receive
the same result.  If the thunk raises an exception, the exception is
stored and re-raised for all callers."
  (unless (fibers-promise? fp)
    (raise-exception
     (make-exception
      (make-exception-with-message "fibers-force: not a fibers promise")
      (make-exception-with-irritants fp))))

  (let ((res (atomic-box-compare-and-swap!
              (fibers-promise-values-box fp)
              #f
              'started)))
    (cond
     ((eq? #f res)
      (call-with-values
          (lambda ()
            (with-exception-handler
                (lambda (exn)
                  (atomic-box-set! (fibers-promise-values-box fp)
                                   exn)
                  (signal-condition!
                   (fibers-promise-evaluated-condition fp))
                  (raise-exception exn))
              (lambda ()
                (with-exception-handler
                    (lambda (exn)
                      (let ((stack
                             (match (fluid-ref %stacks)
                               ((stack-tag . prompt-tag)
                                (make-stack #t
                                            0 prompt-tag
                                            0 (and prompt-tag 1)))
                               (_
                                (make-stack #t)))))
                        (raise-exception
                         (make-exception
                          exn
                          (make-knots-exception stack)))))
                  (lambda ()
                    (start-stack
                     #t
                     ((fibers-promise-thunk fp))))))
              #:unwind? #t))
        (lambda vals
          (atomic-box-set! (fibers-promise-values-box fp)
                           vals)
          (signal-condition!
           (fibers-promise-evaluated-condition fp))
          (apply values vals))))
      ((eq? res 'started)
       (begin
         (wait (fibers-promise-evaluated-condition fp))
         (let ((result (atomic-box-ref (fibers-promise-values-box fp))))
           (if (exception? result)
               (raise-exception result)
               (apply values result)))))
      (else
       (if (exception? res)
           (raise-exception res)
           (apply values res))))))


(define (fibers-delay/eager thunk)
  "Return a new fiber-aware promise and immediately begin evaluating
THUNK in a new fiber.  Exceptions during eager evaluation are silently
discarded; they will be re-raised when @code{fibers-force} is called."
  (let ((promise (fibers-delay thunk)))
    (spawn-fiber
     (lambda ()
       (with-exception-handler
           (lambda _
             ;; Silently handle this exception
             #f)
         (lambda ()
           (fibers-force promise))
         #:unwind? #t)))
    promise))

(define (fibers-promise-reset fp)
  "Reset the fiber-aware promise FP so that the next call to
@code{fibers-force} re-evaluates its thunk."
  (atomic-box-set! (fibers-promise-values-box fp)
                   #f))

(define (fibers-promise-result-available? fp)
  "Return @code{#t} if the fiber-aware promise FP has been evaluated
(successfully or with an exception) and @code{#f} if evaluation has
not yet started or is still in progress."
  (let ((val (atomic-box-ref (fibers-promise-values-box fp))))
    (not (or (eq? val #f)
             (eq? val 'started)))))