Merge pull request #5414 from unisonweb/cp/serialization-roundtrip-tests

Add ANF and MCode serialization property tests

.github/workflows/ci.yaml

@@ -38,7 +38,6 @@ jobs:
     steps:
       - uses: actions/checkout@v4
       - name: Get changed files
-        id: changed-files
         uses: tj-actions/changed-files@v44
         with:
           # globs copied from default settings for run-ormolu

unison-runtime/package.yaml

@@ -89,20 +89,26 @@ tests:
         other-modules: Paths_unison_parser_typechecker
     dependencies:
       - base
+      - bytes
+      - cereal
       - code-page
       - containers
       - cryptonite
       - directory
       - easytest
+      - hedgehog
       - filemanip
       - filepath
       - hex-text
       - lens
       - megaparsec
       - mtl
+      - primitive
       - stm
       - text
       - unison-core1
+      - unison-hash
+      - unison-util-bytes
       - unison-parser-typechecker
       - unison-prelude
       - unison-pretty-printer

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

@@ -1540,7 +1540,7 @@ type ANFM v =
 type ANFD v = Compose (ANFM v) (Directed ())
 
 data GroupRef = GR Reference Word64
-  deriving (Show)
+  deriving (Show, Eq)
 
 -- | A value which is either unboxed or boxed.
 type UBValue = Either Word64 Value
@@ -1554,7 +1554,7 @@ data Value
   | Data Reference Word64 ValList
   | Cont ValList Cont
   | BLit BLit
-  deriving (Show)
+  deriving (Show, Eq)
 
 -- Since we can now track cacheability of supergroups, this type
 -- pairs the two together. This is the type that should be used
@@ -1594,7 +1594,7 @@ data Cont
       Word64 -- Pending args
       GroupRef
       Cont
-  deriving (Show)
+  deriving (Show, Eq)
 
 data BLit
   = Text Util.Text.Text
@@ -1610,7 +1610,7 @@ data BLit
   | Char Char
   | Float Double
   | Arr (PA.Array Value)
-  deriving (Show)
+  deriving (Show, Eq)
 
 groupVars :: ANFM v (Set v)
 groupVars = ask

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

@@ -36,6 +36,7 @@ import Prelude hiding (getChar, putChar)
 -- code/values to be restored later. Hash means we're just getting
 -- bytes for hashing, so we don't need perfect information.
 data Version = Transfer Word32 | Hash Word32
+  deriving (Show)
 
 data TmTag
   = VarT

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

@@ -13,10 +13,17 @@ module Unison.Runtime.Interface
     startNativeRuntime,
     standalone,
     runStandalone,
-    StoredCache,
+    StoredCache
+      ( -- Exported for tests
+        SCache
+      ),
     decodeStandalone,
     RuntimeHost (..),
     Runtime (..),
+
+    -- * Exported for tests
+    getStoredCache,
+    putStoredCache,
   )
 where
 
@@ -473,25 +480,25 @@ checkCacheability cl ctx (r, sg) =
   getTermType codebaseRef >>= \case
     -- A term's result is cacheable iff it has no arrows in its type,
     -- this is sufficient since top-level definitions can't have effects without a delay.
-    Just typ | not (Rec.cata hasArrows typ) ->
-      pure (r, CodeRep sg Cacheable)
+    Just typ
+      | not (Rec.cata hasArrows typ) ->
+          pure (r, CodeRep sg Cacheable)
     _ -> pure (r, CodeRep sg Uncacheable)
   where
-  codebaseRef = backmapRef ctx r
-  getTermType :: CodebaseReference -> IO (Maybe (Type Symbol))
-  getTermType = \case
-    (RF.DerivedId i) ->
-      getTypeOfTerm cl i >>= \case
-        Just t -> pure $ Just t
-        Nothing -> pure Nothing
-    RF.Builtin {} -> pure $ Nothing
-  hasArrows :: Type.TypeF v a Bool -> Bool
-  hasArrows abt = case ABT.out' abt of
-    (ABT.Tm f) -> case f of
-      Type.Arrow _ _ -> True
-      other -> or other
-    t -> or t
-
+    codebaseRef = backmapRef ctx r
+    getTermType :: CodebaseReference -> IO (Maybe (Type Symbol))
+    getTermType = \case
+      (RF.DerivedId i) ->
+        getTypeOfTerm cl i >>= \case
+          Just t -> pure $ Just t
+          Nothing -> pure Nothing
+      RF.Builtin {} -> pure $ Nothing
+    hasArrows :: Type.TypeF v a Bool -> Bool
+    hasArrows abt = case ABT.out' abt of
+      (ABT.Tm f) -> case f of
+        Type.Arrow _ _ -> True
+        other -> or other
+      t -> or t
 
 compileValue :: Reference -> [(Reference, Code)] -> Value
 compileValue base =
@@ -1265,7 +1272,7 @@ data StoredCache
       (Map Reference Word64)
       (Map Reference Word64)
       (Map Reference (Set Reference))
-  deriving (Show)
+  deriving (Show, Eq)
 
 putStoredCache :: (MonadPut m) => StoredCache -> m ()
 putStoredCache (SCache cs crs cacheableCombs trs ftm fty int rtm rty sbs) = do

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

@@ -319,7 +319,7 @@ data UPrim1
   | FLOR -- intToFloat,natToFloat,ceiling,floor
   | TRNF
   | RNDF -- truncate,round
-  deriving (Show, Eq, Ord)
+  deriving (Show, Eq, Ord, Enum, Bounded)
 
 data UPrim2
   = -- integral
@@ -352,7 +352,7 @@ data UPrim2
   | LOGB
   | MAXF
   | MINF -- pow,low,max,min
-  deriving (Show, Eq, Ord)
+  deriving (Show, Eq, Ord, Enum, Bounded)
 
 data BPrim1
   = -- text
@@ -386,7 +386,7 @@ data BPrim1
   -- debug
   | DBTX -- debug text
   | SDBL -- sandbox link list
-  deriving (Show, Eq, Ord)
+  deriving (Show, Eq, Ord, Enum, Bounded)
 
 data BPrim2
   = -- universal
@@ -421,7 +421,7 @@ data BPrim2
   -- code
   | SDBX -- sandbox
   | SDBV -- sandbox Value
-  deriving (Show, Eq, Ord)
+  deriving (Show, Eq, Ord, Enum, Bounded)
 
 data MLit
   = MI !Int

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

@@ -863,7 +863,6 @@ repush !env !activeThreads !stk = go
     go !_ (CB _) !_ = die "repush: impossible"
 {-# INLINE repush #-}
 
--- TODO: Double-check this one
 moveArgs ::
   Stack ->
   Args ->

unison-runtime/tests/Suite.hs

@@ -8,15 +8,19 @@ import System.Environment (getArgs)
 import System.IO
 import System.IO.CodePage (withCP65001)
 import Unison.Test.Runtime.ANF qualified as ANF
+import Unison.Test.Runtime.ANF.Serialization qualified as ANF.Serialization
 import Unison.Test.Runtime.Crypto.Rsa qualified as Rsa
 import Unison.Test.Runtime.MCode qualified as MCode
+import Unison.Test.Runtime.MCode.Serialization qualified as MCode.Serialization
 import Unison.Test.UnisonSources qualified as UnisonSources
 
 test :: Test ()
 test =
   tests
     [ ANF.test,
+      ANF.Serialization.test,
       MCode.test,
+      MCode.Serialization.test,
       Rsa.test,
       UnisonSources.test
     ]

unison-runtime/tests/Unison/Test/Gen.hs

@@ -0,0 +1,51 @@
+-- | Hedgehog generators for common unison types.
+module Unison.Test.Gen where
+
+import Data.Text qualified as Text
+import Hedgehog hiding (Rec, Test, test)
+import Hedgehog.Gen qualified as Gen
+import Hedgehog.Range qualified as Range
+import Unison.ConstructorReference
+import Unison.ConstructorType qualified as CT
+import Unison.Hash (Hash)
+import Unison.Hash qualified as Hash
+import Unison.Prelude
+import Unison.Reference qualified as Reference
+import Unison.Referent qualified as Referent
+import Unison.Util.Text qualified as Unison.Text
+
+genSmallWord64 :: Gen Word64
+genSmallWord64 = Gen.word64 (Range.linear 0 100)
+
+genSmallInt :: Gen Int
+genSmallInt = Gen.int (Range.linear 0 100)
+
+genReference :: Gen Reference.Reference
+genReference =
+  Gen.choice
+    [ Reference.ReferenceBuiltin <$> genSmallText,
+      Reference.ReferenceDerived <$> genRefId
+    ]
+  where
+    genRefId :: Gen (Reference.Id' Hash)
+    genRefId = Reference.Id <$> genHash <*> genSmallWord64
+
+-- This can generate invalid hashes, but that's not really an issue for testing serialization.
+genHash :: Gen Hash
+genHash = Hash.fromByteString <$> Gen.bytes (Range.singleton 32)
+
+genReferent :: Gen Referent.Referent
+genReferent =
+  Gen.choice
+    [ Referent.Ref <$> genReference,
+      Referent.Con <$> genConstructorReference <*> genConstructorType
+    ]
+  where
+    genConstructorType = Gen.choice [pure CT.Data, pure CT.Effect]
+    genConstructorReference = ConstructorReference <$> genReference <*> genSmallWord64
+
+genSmallText :: Gen Text
+genSmallText = Gen.text (Range.linear 2 4) Gen.alphaNum
+
+genUText :: Gen Unison.Text.Text
+genUText = Unison.Text.pack . Text.unpack <$> genSmallText

unison-runtime/tests/Unison/Test/Runtime/ANF/Serialization.hs

@@ -0,0 +1,118 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Round trip tests for ANF serialization.
+module Unison.Test.Runtime.ANF.Serialization (Unison.Test.Runtime.ANF.Serialization.test) where
+
+import Data.Bytes.Get (runGetS)
+import Data.Bytes.Put (runPutS)
+import Data.Primitive.Array (Array)
+import Data.Primitive.Array qualified as Array
+import Data.Primitive.ByteArray (ByteArray)
+import Data.Primitive.ByteArray qualified as ByteArray
+import Data.Primitive.Types (Prim)
+import Data.Serialize.Get (Get)
+import Data.Serialize.Put (Put)
+import EasyTest qualified as EasyTest
+import Hedgehog hiding (Rec, Test, test)
+import Hedgehog.Gen qualified as Gen
+import Hedgehog.Range qualified as Range
+import Unison.Prelude
+import Unison.Runtime.ANF
+import Unison.Runtime.ANF.Serialize
+import Unison.Test.Gen
+import Unison.Util.Bytes qualified as Util.Bytes
+
+test :: EasyTest.Test ()
+test =
+  void . EasyTest.scope "anf.serialization" $ do
+    success <-
+      EasyTest.io $
+        checkParallel $
+          Group
+            "roundtrip"
+            [ ("value", valueRoundtrip)
+            ]
+    EasyTest.expect success
+
+genUBytes :: Gen Util.Bytes.Bytes
+genUBytes = Util.Bytes.fromByteString <$> Gen.bytes (Range.linear 0 4)
+
+genGroupRef :: Gen GroupRef
+genGroupRef = GR <$> genReference <*> genSmallWord64
+
+genUBValue :: Gen UBValue
+genUBValue =
+  Gen.choice
+    [ -- Unboxed values are no longer valid in ANF serialization.
+      -- Left <$> genSmallWord64,
+      Right <$> genValue
+    ]
+
+genValList :: Gen ValList
+genValList = Gen.list (Range.linear 0 4) genUBValue
+
+genCont :: Gen Cont
+genCont = do
+  Gen.choice
+    [ pure KE,
+      Mark <$> genSmallWord64 <*> Gen.list (Range.linear 0 4) genReference <*> Gen.map (Range.linear 0 4) ((,) <$> genReference <*> genValue) <*> genCont,
+      Push <$> genSmallWord64 <*> genSmallWord64 <*> genGroupRef <*> genCont
+    ]
+
+genArray :: Range Int -> Gen a -> Gen (Array a)
+genArray range gen =
+  Array.arrayFromList <$> Gen.list range gen
+
+genByteArray :: (Prim p) => Gen p -> Gen ByteArray
+genByteArray genP = do
+  ByteArray.byteArrayFromList <$> Gen.list (Range.linear 0 20) genP
+
+genBLit :: Gen BLit
+genBLit =
+  Gen.choice
+    [ Text <$> genUText,
+      List <$> Gen.seq (Range.linear 0 4) genValue,
+      TmLink <$> genReferent,
+      TyLink <$> genReference,
+      Bytes <$> genUBytes,
+      Quote <$> genValue,
+      -- Code is not yet included, generating valid ANF terms is complex.
+      -- , Code <$> genCode
+      BArr <$> genByteArray genSmallWord64,
+      Pos <$> genSmallWord64,
+      Neg <$> genSmallWord64,
+      Char <$> Gen.unicode,
+      Float <$> Gen.double (Range.linearFrac 0 100),
+      Arr <$> genArray (Range.linear 0 4) genValue
+    ]
+
+genValue :: Gen Value
+genValue = Gen.sized \n -> do
+  -- Limit amount of recursion to avoid infinitely deep values
+  let gValList
+        | n > 1 = Gen.small genValList
+        | otherwise = pure []
+  Gen.choice
+    [ Partial <$> genGroupRef <*> gValList,
+      Data <$> genReference <*> genSmallWord64 <*> gValList,
+      Cont <$> gValList <*> genCont,
+      BLit <$> genBLit
+    ]
+
+valueRoundtrip :: Property
+valueRoundtrip =
+  getPutRoundtrip getValue putValue genValue
+
+getPutRoundtrip :: (Eq a, Show a) => (Version -> Get a) -> (Version -> a -> Put) -> Gen a -> Property
+getPutRoundtrip get put builder =
+  property $ do
+    v <- forAll builder
+    version <- forAll versionToTest
+    let bytes = runPutS (put version v)
+    runGetS (get version) bytes === Right v
+  where
+    versionToTest = do
+      Gen.choice
+        [ Transfer <$> Gen.enum 4 valueVersion,
+          Hash <$> Gen.enum 4 valueVersion
+        ]