Initial commit

knots/promise.scm

@@ -0,0 +1,78 @@
+;;; 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 atomic)
+  #:use-module (fibers)
+  #:use-module (fibers conditions)
+  #:export (fibers-delay
+            fibers-force
+            fibers-promise-reset))
+
+(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))
+
+(define (fibers-delay thunk)
+  (make-fibers-promise
+   thunk
+   (make-atomic-box #f)
+   (make-condition)))
+
+(define (fibers-force fp)
+  (let ((res (atomic-box-compare-and-swap!
+              (fibers-promise-values-box fp)
+              #f
+              'started)))
+    (if (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))
+                (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)))
+        (if (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))))
+            (if (exception? res)
+                (raise-exception res)
+                (apply values res))))))
+
+(define (fibers-promise-reset fp)
+  (atomic-box-set! (fibers-promise-values-box fp)
+                   #f))