encode/decode inconsistency (probably)

[schernichkin]

Got an error when trying to benchmark flat against my library. Sorry, but can't investigate further right now. Probably I'm doing something wrong. Feel free to close this issue if it was my fault.

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Lev.Bench where

import Control.DeepSeq (NFData)
import Criterion (Benchmark, bench, bgroup, env, nf, nfIO)
import Criterion.Main (defaultMain)
import qualified Data.ByteString as BS
import Data.Int (Int32, Int64)
import Data.Store (Store)
import qualified Data.Store as Store
import qualified Data.Store.TH as Store
import Data.Typeable (Typeable, typeOf)
import Data.Word (Word8)
import Flat (Flat)
import qualified Flat
import GHC.Generics (Generic)
import GHC.TypeLits (KnownNat)
import Lev.Fixed
  ( Serialize,
    SerializeConstraint,
    SizeOf,
  )
import qualified Lev.Fixed as Lev
import UnliftIO ()

data SmallProductG = SmallProductG Int32 Int32 Int32 Int32
  deriving (Generic, Show, Typeable, NFData, Store, Serialize m o, Flat)

-- Actually Flat does not have TH. Flat instance added for uniformity but it will use generic instances.
data SmallProductTH = SmallProductTH Int32 Int32 Int32 Int32
  deriving (Generic, Show, Typeable, NFData, Flat)

Store.makeStore ''SmallProductTH

Lev.makeSerialize ''SmallProductTH

data SomeData = SomeData !Int64 !Word8 !Double
  deriving (Generic, Show, Typeable, NFData, Store, Serialize m o, Flat)

type Ctx a = (NFData a, Store a, Serialize IO 0 a, Typeable a, SerializeConstraint IO 0 a, KnownNat (SizeOf a), Flat a)

benchEncode :: Ctx a => a -> Benchmark
benchEncode = benchEncode' ""

benchEncode' :: Ctx a => String -> a -> Benchmark
benchEncode' msg x0 =
  env (return x0) $ \x ->
    let label = msg ++ " (" ++ show (typeOf x0) ++ ")"
        benchStore name = bench name (nf Store.encode x)
        benchLev name = bench name (nfIO $ Lev.encode x)
        benchFlat name = bench name (nf Flat.flat x)
     in bgroup
          label
          [ benchLev "lev",
            benchStore "store",
            benchFlat "flat"
          ]

benchDecode :: Ctx a => a -> Benchmark
benchDecode = benchDecode' ""

benchDecode' :: forall a. Ctx a => String -> a -> Benchmark
benchDecode' prefix x0 =
  bgroup
    label
    [ env (Lev.encode x0) $ \x -> bench "lev" (nfIO (Lev.decode x :: IO a)),
      env (return (Store.encode x0)) $ \x -> bench "store" (nf (Store.decodeEx :: BS.ByteString -> a) x),
      env (return (Flat.flat x0)) $ \x -> bench "flat" (nf (ensureRight . Flat.unflat :: BS.ByteString -> Either String a) x)
    ]
  where
    label = prefix ++ " (" ++ show (typeOf x0) ++ ")"
    ensureRight (Left e) = error $ "left!: " ++ show e
    ensureRight (Right x) = x

mainBench :: IO ()
mainBench =
  let is = 0 :: Int
      sds = SomeData 1 1 1
      smallprodsG = SmallProductG 0 1 2 3
      smallprodsTH = SmallProductTH 0 1 2 3
   in defaultMain
        [ bgroup
            "encode"
            [ benchEncode is,
              benchEncode sds,
              benchEncode smallprodsG,
              benchEncode smallprodsTH
            ],
          bgroup
            "decode"
            [ benchDecode is,
              benchDecode sds,
              benchDecode smallprodsG,
              benchDecode smallprodsTH
            ]
        ]

Remove all code related to the "lev" - this is my reseach library not available yet. You may also remeve all the "store" related code.

The error is:

benchmarking decode/ (SomeData)/flat
lev-bench.exe: left!: TooMuchSpace (0x00007ef4fde1335b,S {currPtr = 0x00007ef4fde13350, usedBits = 7})
CallStack (from HasCallStack):
  error, called at src\Lev\Bench.hs:84:28 in lev-0.1.0.0-2ScE1b3SNTtEDRH92onQhN:Lev.Bench
Benchmark lev-bench: ERROR
Completed 2 action(s).

--  While building package lev-0.1.0.0 (scroll up to its section to see the error) using:
      C:\Users\schernichkin\AppData\Roaming\stack\setup-exe-cache\x86_64-windows\Cabal-simple_Z6RU0evB_3.4.1.0_ghc-9.0.2.exe --builddir=.stack-work\dist\d53b6a14 bench lev-bench "--benchmark-options=--regress allocated:iters --regress numGcs:iters --output bench.html +RTS -T"
    Process exited with code: ExitFailure 1

Sorry once again for not doing a proper investigation. Reporting just in case. lts-19.31.

[tittoassini]

Thanks, I will look into that.

By the way, as you are interested in benchmarking serialisation library, you might want to add your library tests to this: https://github.com/haskell-perf/serialization

It hasn't been updated in a while but is still, as far as I know, the most comprehensive cross test in this sector.

[tittoassini]

Cannot reproduce this, but there was an issue with ints in previous versions, could you retest with flat-0.6 ?

[schernichkin]

It was my mistake, I've provided wrong type to unflat.