Make Ref.read Ref.write instructions

unison-runtime/src/Unison/Runtime/ANF.hs

@@ -1416,6 +1416,9 @@ data POp
   | TFRC -- try force
   | SDBL -- sandbox link list
   | SDBV -- sandbox check for Values
+  -- Refs
+  | RREF -- Ref.read
+  | WREF -- Ref.write
   deriving (Show, Eq, Ord, Enum, Bounded)
 
 type ANormal = ABTN.Term ANormalF

unison-runtime/src/Unison/Runtime/ANF/Serialize.hs

@@ -656,6 +656,8 @@ pOpCode op = case op of
   COMI -> 128
   DRPN -> 129
   TRNC -> 130
+  RREF -> 131
+  WREF -> 132
 
 pOpAssoc :: [(POp, Word16)]
 pOpAssoc = map (\op -> (op, pOpCode op)) [minBound .. maxBound]

unison-runtime/src/Unison/Runtime/Builtin.hs

@@ -52,8 +52,6 @@ import Data.Digest.Murmur64 (asWord64, hash64)
 import Data.IORef as SYS
   ( IORef,
     newIORef,
-    readIORef,
-    writeIORef,
   )
 import Data.IP (IP)
 import Data.Map qualified as Map
@@ -996,6 +994,16 @@ any'extract =
       TMatch v $
         MatchData Ty.anyRef (mapSingleton 0 $ ([BX], TAbs v1 (TVar v1))) Nothing
 
+-- Refs
+
+ref'read :: SuperNormal Symbol
+ref'read =
+  unop0 0 $ \[ref] -> (TPrm RREF [ref])
+
+ref'write :: SuperNormal Symbol
+ref'write =
+  binop0 0 $ \[ref, val] -> (TPrm WREF [ref, val])
+
 seek'handle :: ForeignOp
 seek'handle instr =
   ([BX, BX, BX],)
@@ -1872,7 +1880,9 @@ builtinLookup =
         ("validateSandboxed", (Untracked, check'sandbox)),
         ("Value.validateSandboxed", (Tracked, value'sandbox)),
         ("sandboxLinks", (Tracked, sandbox'links)),
-        ("IO.tryEval", (Tracked, try'eval))
+        ("IO.tryEval", (Tracked, try'eval)),
+        ("Ref.read", (Tracked, ref'read)),
+        ("Ref.write", (Tracked, ref'write))
       ]
       ++ foreignWrappers
 
@@ -2380,19 +2390,6 @@ declareForeigns = do
     . mkForeign
     $ \(c :: Val) -> evaluate c >>= newIORef
 
-  -- The docs for IORef state that IORef operations can be observed
-  -- out of order ([1]) but actually GHC does emit the appropriate
-  -- load and store barriers nowadays ([2], [3]).
-  --
-  -- [1] https://hackage.haskell.org/package/base-4.17.0.0/docs/Data-IORef.html#g:2
-  -- [2] https://github.com/ghc/ghc/blob/master/compiler/GHC/StgToCmm/Prim.hs#L286
-  -- [3] https://github.com/ghc/ghc/blob/master/compiler/GHC/StgToCmm/Prim.hs#L298
-  declareForeign Untracked "Ref.read" (argNDirect 1) . mkForeign $
-    \(r :: IORef Val) -> readIORef r
-
-  declareForeign Untracked "Ref.write" arg2To0 . mkForeign $
-    \(r :: IORef Val, c :: Val) -> evaluate c >>= writeIORef r
-
   declareForeign Tracked "Ref.readForCas" (argNDirect 1) . mkForeign $
     \(r :: IORef Val) -> readForCAS r
 

unison-runtime/src/Unison/Runtime/MCode.hs

@@ -402,6 +402,8 @@ data BPrim1
   -- debug
   | DBTX -- debug text
   | SDBL -- sandbox link list
+  | -- Refs
+    RREF -- Ref.read
   deriving (Show, Eq, Ord, Enum, Bounded)
 
 data BPrim2
@@ -437,6 +439,8 @@ data BPrim2
   -- code
   | SDBX -- sandbox
   | SDBV -- sandbox Value
+  -- Refs
+  | WREF -- Ref.write
   deriving (Show, Eq, Ord, Enum, Bounded)
 
 data MLit
@@ -1327,6 +1331,9 @@ emitPOp ANF.SDBV = emitBP2 SDBV
 emitPOp ANF.EROR = emitBP2 THRO
 emitPOp ANF.TRCE = emitBP2 TRCE
 emitPOp ANF.DBTX = emitBP1 DBTX
+-- Refs
+emitPOp ANF.RREF = emitBP1 RREF
+emitPOp ANF.WREF = emitBP2 WREF
 -- non-prim translations
 emitPOp ANF.BLDS = Seq
 emitPOp ANF.FORK = \case

unison-runtime/src/Unison/Runtime/Machine.hs

@@ -10,6 +10,8 @@ import Control.Exception
 import Control.Lens
 import Data.Bits
 import Data.Functor.Classes (Eq1 (..), Ord1 (..))
+import Data.IORef (IORef)
+import Data.IORef qualified as IORef
 import Data.Map.Strict qualified as M
 import Data.Ord (comparing)
 import Data.Sequence qualified as Sq
@@ -60,7 +62,6 @@ import Unison.Util.EnumContainers as EC
 import Unison.Util.Monoid qualified as Monoid
 import Unison.Util.Pretty (toPlainUnbroken)
 import Unison.Util.Text qualified as Util.Text
-import UnliftIO (IORef)
 import UnliftIO qualified
 import UnliftIO.Concurrent qualified as UnliftIO
 
@@ -1614,6 +1615,21 @@ bprim1 !stk FLTB i = do
   stk <- bump stk
   pokeBi stk $ By.flatten b
   pure stk
+
+-- The docs for IORef state that IORef operations can be observed
+-- out of order ([1]) but actually GHC does emit the appropriate
+-- load and store barriers nowadays ([2], [3]).
+--
+-- [1] https://hackage.haskell.org/package/base-4.17.0.0/docs/Data-IORef.html#g:2
+-- [2] https://github.com/ghc/ghc/blob/master/compiler/GHC/StgToCmm/Prim.hs#L286
+-- [3] https://github.com/ghc/ghc/blob/master/compiler/GHC/StgToCmm/Prim.hs#L298
+bprim1 !stk RREF i = do
+  (ref :: IORef Val) <- peekOffBi stk i
+  v <- IORef.readIORef ref
+  stk <- bump stk
+  poke stk v
+  pure stk
+
 -- impossible
 bprim1 !stk MISS _ = pure stk
 bprim1 !stk CACH _ = pure stk
@@ -1818,6 +1834,13 @@ bprim2 !stk CATB i j = do
   stk <- bump stk
   pokeBi stk (l <> r :: By.Bytes)
   pure stk
+bprim2 !stk WREF i j = do
+  (ref :: IORef Val) <- peekOffBi stk i
+  v <- peekOff stk j
+  IORef.writeIORef ref v
+  stk <- bump stk
+  bpoke stk unitValue
+  pure stk
 bprim2 !stk THRO _ _ = pure stk -- impossible
 bprim2 !stk TRCE _ _ = pure stk -- impossible
 bprim2 !stk EQLU _ _ = pure stk -- impossible

unison-runtime/src/Unison/Runtime/Serialize.hs

@@ -476,6 +476,7 @@ instance Tag BPrim1 where
   tag2word TLTT = 24
   tag2word DBTX = 25
   tag2word SDBL = 26
+  tag2word RREF = 27
 
   word2tag 0 = pure SIZT
   word2tag 1 = pure USNC
@@ -504,6 +505,7 @@ instance Tag BPrim1 where
   word2tag 24 = pure TLTT
   word2tag 25 = pure DBTX
   word2tag 26 = pure SDBL
+  word2tag 27 = pure RREF
   word2tag n = unknownTag "BPrim1" n
 
 instance Tag BPrim2 where
@@ -533,6 +535,7 @@ instance Tag BPrim2 where
   tag2word IXOT = 23
   tag2word IXOB = 24
   tag2word SDBV = 25
+  tag2word WREF = 26
 
   word2tag 0 = pure EQLU
   word2tag 1 = pure CMPU
@@ -560,4 +563,5 @@ instance Tag BPrim2 where
   word2tag 23 = pure IXOT
   word2tag 24 = pure IXOB
   word2tag 25 = pure SDBV
+  word2tag 26 = pure WREF
   word2tag n = unknownTag "BPrim2" n

unison-runtime/src/Unison/Runtime/Stack.hs

@@ -127,9 +127,11 @@ where
 
 import Control.Monad.Primitive
 import Data.Char qualified as Char
+import Data.IORef (IORef)
 import Data.Kind (Constraint)
 import Data.Primitive (sizeOf)
 import Data.Primitive.ByteArray qualified as BA
+import Data.Tagged (Tagged (..))
 import Data.Word
 import GHC.Exts as L (IsList (..))
 import Unison.Prelude
@@ -610,6 +612,8 @@ data Val = Val {getUnboxedVal :: !UVal, getBoxedVal :: !BVal}
   -- See universalEq.
   deriving (Show)
 
+instance BuiltinForeign (IORef Val) where foreignRef = Tagged Ty.refRef
+
 -- | A nulled out value you can use when filling empty arrays, etc.
 emptyVal :: Val
 emptyVal = Val (-1) BlackHole