From 0acf5d8958fae9ef959b9bae4917c656081189ef Mon Sep 17 00:00:00 2001
From: Thomas White <taw@physics.org>
Date: Mon, 10 May 2021 20:52:59 +0200
Subject: Make state objects' hash tables immutable with atomic updates

States often get updated while they're being scanned out.  The obvious
case is when manually setting values in the programmer-state, but the
more pernicious one is when running a cue.  This means that the updates
have to be atomic.
---
 guile/starlet/state.scm | 42 ++++++++++++++++++++++++++++++------------
 1 file changed, 30 insertions(+), 12 deletions(-)

(limited to 'guile')

diff --git a/guile/starlet/state.scm b/guile/starlet/state.scm
index e6c3af4..13888e8 100644
--- a/guile/starlet/state.scm
+++ b/guile/starlet/state.scm
@@ -51,12 +51,15 @@
             value->number))
 
 
-;; A "state" is just a thin wrapper around a hash table
-;; of (fixture . attribute)  -->  value
+;; A "state" is an atomically-updating container for an immutable
+;; hash table mapping (fixture-object . attribute-symbol) pairs to values
+;; which can be numbers, symbols, colours, boolean values and more
+;; depending on the type of attribute.  Values can also be
+;; functions which provide the value.
 (define-class <starlet-state> (<object>)
-  (hash-table
-    #:init-form (make-hash-table)
-    #:getter get-state-hash-table)
+  (hash-table-box
+    #:init-form (make-atomic-box (make-hash-table))
+    #:getter get-ht-box)
   (name
     #:init-value #f
     #:init-keyword #:name
@@ -139,9 +142,17 @@
                               (fix <fixture>)
                               (attr <symbol>)
                               value)
-  (hash-set! (get-state-hash-table state)
-             (cons fix attr)
-             value))
+  (let* ((old-ht (atomic-box-ref (get-ht-box state)))
+         (new-ht (copy-hash-table old-ht)))
+    (hash-set! new-ht
+               (cons fix attr)
+               value)
+    (unless (eq? (atomic-box-compare-and-swap!
+                   (get-ht-box state)
+                   old-ht
+                   new-ht)
+                 old-ht)
+      (set-in-state! state fix attr))))  ;; Try again
 
 
 (define (blackout state)
@@ -180,13 +191,13 @@
                    (func (car key)
                          (cdr key)
                          value))
-                 (get-state-hash-table state)))
+                 (atomic-box-ref (get-ht-box state))))
 
 
 (define-method (state-find (fix <fixture>)
                            (attr <symbol>)
                            (state <starlet-state>))
-  (hash-ref (get-state-hash-table state)
+  (hash-ref (atomic-box-ref (get-ht-box state))
             (cons fix attr)
             'no-value))
 
@@ -205,7 +216,7 @@
                     (func (car key)
                           (cdr key)
                           value))
-                  (get-state-hash-table state)))
+                  (atomic-box-ref (get-ht-box state))))
 
 
 (define (apply-state state)
@@ -253,7 +264,14 @@ pre-existing contents."
 
 
 (define (clear-state! state)
-  (hash-clear! (get-state-hash-table state)))
+  (let* ((old-ht (atomic-box-ref (get-ht-box state)))
+         (new-ht (make-hash-table)))
+    (unless (eq? (atomic-box-compare-and-swap!
+                   (get-ht-box state)
+                   old-ht
+                   new-ht)
+                 old-ht)
+      (clear-state! state))))  ;; Try again
 
 
 (define (partition3 pred1 pred2 input)
-- 
cgit v1.2.3