Make Effect.Ref thread-safe (#3)

purescm · Feb 14, 2024 · 9937583 · 9937583
1 parent d4cf4e9
commit 9937583
Show file tree

Hide file tree

Showing 2 changed files with 14 additions and 10 deletions.
diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml
@@ -38,6 +38,7 @@ jobs:
           purescm run --main Test.Array.Main
           purescm run --main Test.Console.Main
           purescm run --main Test.Control.Main
+          purescm run --main Test.Effect.Ref.Main
           purescm run --main Test.Foldable.Main
           purescm run --main Test.Int.Main
           purescm run --main Test.Lazy.Main

diff --git a/refs/src/Effect/Ref.ss b/refs/src/Effect/Ref.ss
@@ -6,38 +6,41 @@
           read
           modifyImpl
           write)
-  (import (prefix (chezscheme) scm:))
+  (import (prefix (chezscheme) scm:)
+          (prefix (purs runtime) rt:))
 
   (scm:define _new
     (scm:lambda (v)
       (scm:lambda ()
-        (scm:box v))))
+        (scm:cons (scm:box v) (scm:make-mutex)))))
 
   (scm:define newWithSelf
     (scm:lambda (f)
       (scm:lambda ()
-        (scm:let ([ref (scm:box (scm:quote ()))])
-          (scm:set-box! ref (f ref))
+        (scm:let ([ref (scm:cons (scm:box (scm:quote ())) (scm:make-mutex))])
+          (scm:set-box! (scm:car ref) (f ref))
           ref))))
 
   (scm:define read
     (scm:lambda (ref)
       (scm:lambda ()
-        (scm:unbox ref))))
+        (scm:unbox (scm:car ref)))))
 
   (scm:define modifyImpl
     (scm:lambda (f)
       (scm:lambda (ref)
         (scm:lambda ()
-          (scm:let* ([t (f (scm:unbox ref))]
-                     [v (scm:hashtable-ref t "state" (scm:quote Effect.Ref:modifyImpl-CANT-GET-STATE))])
-            (scm:set-box! ref v)
-            v)))))
+          (scm:with-mutex (scm:cdr ref)
+            (scm:let* ([t (f (scm:unbox (scm:car ref)))]
+                       [v (rt:record-ref t (scm:quote state))])
+              (scm:set-box! (scm:car ref) v)
+              v))))))
 
   (scm:define write
     (scm:lambda (val)
       (scm:lambda (ref)
         (scm:lambda ()
-          (scm:set-box! ref val)))))
+          (scm:with-mutex (scm:cdr ref)
+            (scm:set-box! (scm:car ref) val))))))
 
 )