Merge pull request #2182 from unisonweb/fix/value-loading

Fix bad calling convention for `Value.load`

parser-typechecker/src/Unison/Runtime/Foreign.hs

@@ -33,7 +33,7 @@ import qualified Crypto.Hash as Hash
 import Unsafe.Coerce
 
 data Foreign where
-  Wrap :: Reference -> e -> Foreign
+  Wrap :: Reference -> !e -> Foreign
 
 promote :: (a -> a -> r) -> b -> c -> r
 promote (~~) x y = unsafeCoerce x ~~ unsafeCoerce y

parser-typechecker/src/Unison/Runtime/Foreign/Function.hs

@@ -16,6 +16,7 @@ import GHC.IO.Exception (IOException(..), IOErrorType(..))
 import Control.Concurrent (ThreadId)
 import Control.Concurrent.MVar (MVar)
 import Control.Concurrent.STM (TVar)
+import Control.Exception (evaluate)
 import qualified Data.Char as Char
 import Data.Foldable (toList)
 import Data.Text (Text, pack, unpack)
@@ -95,7 +96,7 @@ instance ForeignConvention Closure where
   readForeign _  [    ] _ _    = foreignCCError "Closure"
   writeForeign ustk bstk c = do
     bstk <- bump bstk
-    (ustk, bstk) <$ poke bstk c
+    (ustk, bstk) <$ (poke bstk =<< evaluate c)
 
 instance ForeignConvention Text where
   readForeign = readForeignBuiltin

parser-typechecker/src/Unison/Runtime/Machine.hs

@@ -219,7 +219,8 @@ exec !env !denv !ustk !bstk !k (BPrim1 LOAD i) = do
   reifyValue env v >>= \case
     Left miss -> do
       poke ustk 0
-      pokeS bstk $ Sq.fromList $ Foreign . Wrap Rf.termLinkRef <$> miss
+      pokeS bstk
+        $ Sq.fromList $ Foreign . Wrap Rf.termLinkRef . Ref <$> miss
     Right x -> do
       poke ustk 1
       poke bstk x

unison-src/transcripts-using-base/codeops.md

@@ -137,6 +137,23 @@ tests =
    , identicality "ident bool" false
    , identicality "ident bytes" [fSer, Bytes.empty]
    ]
+
+badLoad : '{IO} [Result]
+badLoad _ =
+  payload = Bytes.fromList[0,0,0,1,0,1,64,175,174,29,188,217,78,209,175,255,137,165,135,165,1,20,151,182,215,54,21,196,43,159,247,106,175,177,213,20,111,178,134,214,188,207,243,196,240,187,111,44,245,111,219,223,98,88,183,163,97,22,18,153,104,185,125,175,157,36,209,151,166,168,102,0,1,0,0,0,0,0,2,0,0,0,0]
+  go _ =
+    match Value.deserialize payload with
+      Left t -> Fail "deserialize exception"
+      Right a -> match Value.load a with
+        Left terms -> 
+            bs = Value.serialize (Value.value terms)
+            s = size bs
+            Ok ("serialized" ++ toText s)
+        Right _ ->
+            Ok "actually loaded"
+  match toEither go with
+    Right v -> [v]
+    Left _ -> [Fail "Exception"]
 ```
 
 This simply runs some functions to make sure there isn't a crash. Once
@@ -147,4 +164,5 @@ to actual show that the serialization works.
 .> add
 .> display fDeps
 .> io.test tests
+.> io.test badLoad
 ```

unison-src/transcripts-using-base/codeops.output.md

@@ -185,6 +185,23 @@ tests =
    , identicality "ident bool" false
    , identicality "ident bytes" [fSer, Bytes.empty]
    ]
+
+badLoad : '{IO} [Result]
+badLoad _ =
+  payload = Bytes.fromList[0,0,0,1,0,1,64,175,174,29,188,217,78,209,175,255,137,165,135,165,1,20,151,182,215,54,21,196,43,159,247,106,175,177,213,20,111,178,134,214,188,207,243,196,240,187,111,44,245,111,219,223,98,88,183,163,97,22,18,153,104,185,125,175,157,36,209,151,166,168,102,0,1,0,0,0,0,0,2,0,0,0,0]
+  go _ =
+    match Value.deserialize payload with
+      Left t -> Fail "deserialize exception"
+      Right a -> match Value.load a with
+        Left terms -> 
+            bs = Value.serialize (Value.value terms)
+            s = size bs
+            Ok ("serialized" ++ toText s)
+        Right _ ->
+            Ok "actually loaded"
+  match toEither go with
+    Right v -> [v]
+    Left _ -> [Fail "Exception"]
 ```
 
 ```ucm
@@ -196,14 +213,15 @@ tests =
     ⍟ These new definitions are ok to `add`:
     
       ability Zap
-      f      : Nat ->{Zap} Nat
-      fDeps  : [Link.Term]
-      fSer   : Bytes
-      fVal   : Value
-      h      : Three Nat Nat Nat -> Nat -> Nat
-      rotate : Three Nat Nat Nat -> Three Nat Nat Nat
-      tests  : '{IO} [Result]
-      zapper : Three Nat Nat Nat -> Request {Zap} r -> r
+      badLoad : '{IO} [Result]
+      f       : Nat ->{Zap} Nat
+      fDeps   : [Link.Term]
+      fSer    : Bytes
+      fVal    : Value
+      h       : Three Nat Nat Nat -> Nat -> Nat
+      rotate  : Three Nat Nat Nat -> Three Nat Nat Nat
+      tests   : '{IO} [Result]
+      zapper  : Three Nat Nat Nat -> Request {Zap} r -> r
 
 ```
 This simply runs some functions to make sure there isn't a crash. Once
@@ -216,14 +234,15 @@ to actual show that the serialization works.
   ⍟ I've added these definitions:
   
     ability Zap
-    f      : Nat ->{Zap} Nat
-    fDeps  : [Link.Term]
-    fSer   : Bytes
-    fVal   : Value
-    h      : Three Nat Nat Nat -> Nat -> Nat
-    rotate : Three Nat Nat Nat -> Three Nat Nat Nat
-    tests  : '{IO} [Result]
-    zapper : Three Nat Nat Nat -> Request {Zap} r -> r
+    badLoad : '{IO} [Result]
+    f       : Nat ->{Zap} Nat
+    fDeps   : [Link.Term]
+    fSer    : Bytes
+    fVal    : Value
+    h       : Three Nat Nat Nat -> Nat -> Nat
+    rotate  : Three Nat Nat Nat -> Three Nat Nat Nat
+    tests   : '{IO} [Result]
+    zapper  : Three Nat Nat Nat -> Request {Zap} r -> r
 
 .> display fDeps
 
@@ -251,4 +270,14 @@ to actual show that the serialization works.
   
   Tip: Use view tests to view the source of a test.
 
+.> io.test badLoad
+
+    New test results:
+  
+  ◉ badLoad   serialized78
+  
+  ✅ 1 test(s) passing
+  
+  Tip: Use view badLoad to view the source of a test.
+
 ```