wip implement SizeOf in terms of MonadEval

Author: imalsogreg

bench/Bench.hs

@@ -0,0 +1,106 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GeneralisedNewtypeDeriving #-}
+-- | Tests for the sizes of various values.
+
+module Pact.Core.Test.SizeOfTests where
+
+import Data.Default
+import Control.Monad.IO.Class
+import qualified Data.Map as Map
+import Data.Text
+import GHC.Generics (Generic)
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit
+
+import Pact.Core.Builtin
+import Pact.Core.Persistence.MockPersistence
+import Pact.Core.Names
+import Pact.Core.SizeOf
+    ( constructorCost,
+      wordSize,
+      SizeOf(..),
+      SizeOfVersion(SizeOfV0, SizeOfV1, SizeOfV2) )
+import Pact.Core.Errors
+import Pact.Core.Environment.Types
+import Pact.Core.PactValue
+import Pact.Core.Serialise
+import Pact.Core.IR.Eval.Runtime.Types (runEvalM)
+
+tests :: TestTree
+tests = testGroup "SizeOfTests" $
+  [ testCase "int" $ do
+      Right size <- getSize SizeOfV0 (1 :: Int)
+      assertEqual "size should be 1" 16 size
+  , testCase "string" $ do
+      Right size <- getSize SizeOfV0 ("a" :: Text)
+      assertEqual "size should be 3" 50 size
+  , testCase "FieldKey" $ do
+      Right size <- getSize SizeOfV0 (Field "a")
+      assertEqual "size should be 50" 50 size
+  , testCase "PactValue1" $ do
+      Right size <- getSize SizeOfV0 (PInteger 1)
+      assertEqual "size should be 32" 32 size
+  , sizeOfSmallObject SizeOfV0 146
+  , sizeOfSmallObject SizeOfV1 154
+  , sizeOfGenericsTest SizeOfV0
+  , sizeOfGenericsTest SizeOfV1
+  , sizeOfGenericsTest SizeOfV2
+  ]
+
+getSize :: SizeOf a => SizeOfVersion -> a -> IO (Either PactErrorI Bytes)
+getSize version value = do
+  pdb <- mockPactDb serialisePact_repl_spaninfo
+  ee <- defaultEvalEnv pdb replCoreBuiltinMap
+  let es = def
+  (v, _state) <- liftIO $ runEvalM ee es (sizeOf version value)
+  return v
+
+sizeOfSmallObject :: SizeOfVersion -> Bytes -> TestTree
+sizeOfSmallObject version expectation = testCase ("pactvalue-smallobject-" ++ show version) $ do
+    Right size <- getSize version smallObject
+    assertEqual "size should match expectation" expectation size
+  where
+    smallObject :: PactValue
+    smallObject = PObject $ Map.fromList [(Field "a", PInteger 1)]
+
+-- Testing whether derived instance for empty constructors is 1 word
+data A = A1 | A2 deriving (Eq, Show, Generic)
+data B = B1 Int | B2 Int Bool | B3 Int Bool A deriving (Eq, Show, Generic)
+data C a = C a deriving (Eq, Show, Generic)
+
+instance SizeOf A
+instance SizeOf B
+instance SizeOf a => SizeOf (C a)
+
+newtype D = D Int
+  deriving (Eq, Show, Generic)
+
+instance SizeOf D
+
+newtype F = F Int
+  deriving (Eq, Show, SizeOf)
+
+sizeOfGenericsTest :: SizeOfVersion -> TestTree
+sizeOfGenericsTest szVer =
+  testCase ("SizeOf " <> show szVer <> " generics conform to specification") $ do
+    Right a1Size <- getSize szVer A1
+    Right a2Size <- getSize szVer A2
+    assertEqual "A1 wordSize" wordSize a1Size
+    assertEqual "A2 wordSize" wordSize a2Size
+
+    Right b1Size <- getSize szVer (B1 0)
+    Right b2Size <- getSize szVer (B2 0 True)
+    Right b3Size <- getSize szVer (B3 0 True A1)
+    Right intSize <- getSize szVer (0::Int)
+    Right boolSize <- getSize szVer True
+    assertEqual "B1 size" (intSize + constructorCost 1) b1Size
+    assertEqual "B2 size" (intSize + boolSize + constructorCost 2) b2Size
+    assertEqual "B3 size" (intSize + boolSize + a1Size + constructorCost 3) b3Size
+
+    Right cSize <- getSize szVer (C (B1 0))
+    Right dSize <- getSize szVer (D 1)
+    assertEqual "C size" (b1Size + constructorCost 1) cSize
+    assertEqual "D size" (intSize + constructorCost 1) dSize
+
+    Right fSize <- getSize szVer (F 1)
+    assertEqual "F size" intSize fSize

pact-tests/Pact/Core/Test/SizeOfTests.hs

@@ -12,6 +12,7 @@ import qualified Pact.Core.Test.StaticErrorTests as StaticErrorTests
 import qualified Pact.Core.Test.ZkTests as ZkTests
 import qualified Pact.Core.Test.PoseidonTests as PoseidonTests
 import qualified Pact.Core.Test.LanguageServer as LanguageServer
+import qualified Pact.Core.Test.SizeOfTests as SizeOfTests
 
 main :: IO ()
 main = do
@@ -27,4 +28,5 @@ main = do
     , PoseidonTests.tests
     , PersistenceTests.tests
     , LanguageServer.tests
+    , SizeOfTests.tests
     ]

pact-tests/PactCoreTests.hs

@@ -265,6 +265,21 @@ executable pact
   -- beware of the autogen modules. Remember to `cabal clean`!
   other-modules: PackageInfo_pact_tng
 
+benchmark bench
+  type: exitcode-stdio-1.0
+  main-is: Bench.hs
+  build-depends:
+      base
+    , containers
+    , criterion
+    , data-default
+    , filepath
+    , mtl
+    , pact-tng
+    , text
+  ghc-options: -WAll -threaded -rtsopts "-with-rtsopts=-N" 
+  hs-source-dirs: bench
+  default-language: Haskell2010
 
 test-suite core-tests
   main-is:          PactCoreTests.hs
@@ -326,6 +341,7 @@ test-suite core-tests
     , Pact.Core.Test.SerialiseTests
     , Pact.Core.Test.LegacySerialiseTests
     , Pact.Core.Gen.Serialise
+    , Pact.Core.Test.SizeOfTests
     , Pact.Core.Test.StaticErrorTests
     , Pact.Core.Test.TestPrisms
     , Pact.Core.Test.ZkTests

pact-tng.cabal

@@ -214,7 +214,8 @@ evalTopLevel bEnv tlFinal deps = do
         CapGov _ -> pure ()
       let deps' = M.filterWithKey (\k _ -> S.member (_fqModule k) deps) (_loAllLoaded lo0)
           mdata = ModuleData m deps'
-      chargeGasArgs (_mInfo m) (GModuleMemory (sizeOf SizeOfV0 m))
+      mSize <- sizeOf SizeOfV0 m
+      chargeGasArgs (_mInfo m) (GModuleMemory mSize)
       _ <- liftDbFunction2 (_mInfo m) $ writeModule pdb Write (view mName m) mdata
       let fqDeps = toFqDep (_mName m) (_mHash m) <$> _mDefs m
           newLoaded = M.fromList fqDeps
@@ -229,7 +230,8 @@ evalTopLevel bEnv tlFinal deps = do
     TLInterface iface -> do
       let deps' = M.filterWithKey (\k _ -> S.member (_fqModule k) deps) (_loAllLoaded lo0)
           mdata = InterfaceData iface deps'
-      chargeGasArgs (_ifInfo iface) (GModuleMemory (sizeOf SizeOfV0 iface))
+      ifaceSize <- sizeOf SizeOfV0 iface
+      chargeGasArgs (_ifInfo iface) (GModuleMemory ifaceSize)
       _ <- liftDbFunction2 (_ifInfo iface) $ writeModule pdb Write (view ifName iface) mdata
       let fqDeps = toFqDep (_ifName iface) (_ifHash iface)
                   <$> mapMaybe ifDefToDef (_ifDefns iface)

pact/Pact/Core/Compile.hs

@@ -45,6 +45,9 @@ module Pact.Core.Environment.Types
  , MonadEvalState(..)
  , MonadEval
  , defaultEvalEnv
+ , GasLogEntry(..)
+ , Bytes
+ , SizeOfByteLimit(..)
  ) where
 
 
@@ -56,6 +59,7 @@ import Data.Text(Text)
 import Data.Map.Strict(Map)
 import Data.IORef
 import Data.Default
+import Data.Word (Word64)
 
 import Control.DeepSeq
 import GHC.Generics
@@ -65,6 +69,7 @@ import qualified Data.Text as T
 import qualified Data.Map.Strict as M
 
 import Pact.Core.Persistence
+import Pact.Core.Pretty
 import Pact.Core.Capabilities
 import Pact.Core.Guards
 import Pact.Core.PactValue
@@ -75,7 +80,6 @@ import Pact.Core.ChainData
 import Pact.Core.Errors
 import Pact.Core.Gas
 import Pact.Core.Namespace
-import Pact.Core.SizeOf
 import Pact.Core.Builtin (IsBuiltin)
 
 -- | Execution flags specify behavior of the runtime environment,
@@ -174,12 +178,13 @@ data EvalState b i
   , _esDefPactExec :: !(Maybe DefPactExec)
   , _esGasLog :: Maybe [(Text, MilliGas)]
     -- ^ Sequence of gas expendature events.
+  , _countBytesCounter :: Int
   } deriving (Show, Generic)
 
 instance (NFData b, NFData i) => NFData (EvalState b i)
 
 instance Default (EvalState b i) where
-  def = EvalState def [] [] mempty Nothing Nothing
+  def = EvalState def [] [] mempty Nothing Nothing 0
 
 makeClassy ''EvalState
 
@@ -204,8 +209,6 @@ type MonadEval b i m =
   , Exceptions.MonadCatch m
   , Default i
   , Show i
-  , SizeOf b
-  , SizeOf i
   , IsBuiltin b
   , Show b)
 
@@ -228,3 +231,12 @@ defaultEvalEnv pdb m = do
     , _eeGasRef = gasRef
     , _eeGasModel = freeGasModel
     }
+
+type Bytes = Word64
+
+newtype SizeOfByteLimit 
+  = SizeOfByteLimit Bytes
+  deriving Show
+
+instance Pretty SizeOfByteLimit where
+  pretty = pretty . show

pact/Pact/Core/Environment/Types.hs

@@ -158,11 +158,13 @@ data GasArgs
   | GComparison !ComparisonType
   -- ^ Gas costs for comparisons
   | GPoseidonHashHackAChain !Int
-  -- ^ poseidon-hash-hack-a-chain costs
+  -- ^ poseidon-hash-hack-a-chain costs.
   | GModuleMemory !Word64
+  | GCountBytes
+  -- ^ Cost of computing SizeOf for N bytes.
   | GPassthrough MilliGas
   -- ^ Charge precise gas -- TODO: TEMPORARY
-  deriving (Show)
+  deriving (Show, Generic, NFData)
 
 instance Pretty GasArgs where
   pretty = pretty . show

pact/Pact/Core/Gas.hs

@@ -208,6 +208,9 @@ runTableModel = \case
   GModuleMemory bytes -> moduleMemoryCost bytes
   GPassthrough milligas -> milligas
 
+  -- Running CountBytes costs 0.9 MilliGas, according to the analysis in bench/Bench.hs
+  GCountBytes -> MilliGas 1 
+
 basicWorkGas :: Word64
 basicWorkGas = 25
 

pact/Pact/Core/Gas/TableGasModel.hs

@@ -25,6 +25,8 @@ module Pact.Core.IR.Desugar
  , runDesugarReplTopLevel
  , DesugarOutput(..)
  , DesugarBuiltin(..)
+
+ , runDesugarModule
  ) where
 
 import Control.Applicative((<|>))

pact/Pact/Core/IR/Desugar.hs

@@ -1356,8 +1356,8 @@ applyContToValue (BuiltinC env info frame cont) handler cv = do
         let check' = if wt == Update then checkPartialSchema else checkSchema
         if check' rv (_tvSchema tv) then do
           let rdata = RowData rv
-          chargeGasArgs info (GWrite (sizeOf SizeOfV0 rv))
-          let serializationGasser = chargeGasArgs info . GPassthrough
+          rvSize <- sizeOf SizeOfV2 rv
+          chargeGasArgs info (GWrite rvSize)
           _ <- liftDbFunction2 info $ _pdbWrite pdb serializationGasser wt (tvToDomain tv) rk rdata
           returnCEKValue cont handler (VString "Write succeeded")
         else returnCEK cont handler (VError "object does not match schema" info)
@@ -1420,15 +1420,16 @@ applyContToValue (BuiltinC env info frame cont) handler cv = do
         enforceMeta Unmanaged = throwExecutionError info (InvalidEventCap fqn)
         enforceMeta _ = pure ()
       DefineKeysetC ksn newKs -> do
-        chargeGasArgs info (GWrite (sizeOf SizeOfV0 newKs))
+        newKsSize <- sizeOf SizeOfV2 newKs
+        chargeGasArgs info (GWrite newKsSize)
         liftDbFunction2 info $ writeKeySet pdb Write ksn newKs
         returnCEKValue cont handler (VString "Keyset write success")
       DefineNamespaceC ns -> case v of
         PBool allow ->
           if allow then do
             let nsn = _nsName ns
-            chargeGasArgs info (GWrite (sizeOf SizeOfV0 ns))
-            let serializationGasser = chargeGasArgs info . GPassthrough
+            nsSize <- sizeOf SizeOfV2 ns
+            chargeGasArgs info (GWrite nsSize)
             liftDbFunction2 info $ _pdbWrite pdb serializationGasser Write DNamespaces nsn ns
             returnCEKValue cont handler $ VString $ "Namespace defined: " <> (_namespaceName nsn)
           else throwExecutionError info $ DefineNamespaceError "Namespace definition not permitted"

pact/Pact/Core/IR/Eval/CEK.hs

@@ -654,15 +654,19 @@ createEnumerateList
   -- ^ Step
   -> m (Vector Integer)
 createEnumerateList info from to inc
-  | from == to = chargeGasArgs info (GMakeList 1 (sizeOf SizeOfV0 from)) *>  pure (V.singleton from)
+  | from == to = do
+    fromSize <- sizeOf SizeOfV0 from
+    chargeGasArgs info (GMakeList 1 fromSize)
+    pure (V.singleton from)
   | inc == 0 = pure mempty -- note: covered by the flat cost
   | from < to, from + inc < from =
     throwExecutionError info (EnumerationError "enumerate: increment diverges below from interval bounds.")
   | from > to, from + inc > from =
     throwExecutionError info (EnumerationError "enumerate: increment diverges above from interval bounds.")
   | otherwise = do
     let len = succ (abs (from - to) `div` abs inc)
-    chargeGasArgs info (GMakeList len (sizeOf SizeOfV0 (max (abs from) (abs to))))
+    listSize <- sizeOf SizeOfV0 (max (abs from) (abs to))
+    chargeGasArgs info (GMakeList len listSize)
     pure $ V.enumFromStepN from inc (fromIntegral len)
 
 coreEnumerateStepN :: (CEKEval step b i m, MonadEval b i m) => NativeFunction step b i m
@@ -675,7 +679,8 @@ coreEnumerateStepN info b cont handler _env = \case
 makeList :: (CEKEval step b i m, MonadEval b i m) => NativeFunction step b i m
 makeList info b cont handler _env = \case
   [VLiteral (LInteger i), VPactValue v] -> do
-    chargeGasArgs info (GMakeList (fromIntegral i) (sizeOf SizeOfV0 v))
+    vSize <- sizeOf SizeOfV0 v
+    chargeGasArgs info (GMakeList (fromIntegral i) vSize)
     returnCEKValue cont handler (VList (V.fromList (replicate (fromIntegral i) v)))
   args -> argsError info b args
 
@@ -1104,7 +1109,8 @@ defineKeySet' info cont handler env ksname newKs  = do
     Left {} -> returnCEK cont handler (VError "incorrect keyset name format" info)
     Right ksn -> do
       let writeKs = do
-            chargeGasArgs info (GWrite (sizeOf SizeOfV0 newKs))
+            newKsSize <- sizeOf SizeOfV0 newKs
+            chargeGasArgs info (GWrite newKsSize)
             liftDbFunction2 info $ writeKeySet pdb Write ksn newKs
             returnCEKValue cont handler (VString "Keyset write success")
       liftDbFunction info (readKeySet pdb ksn) >>= \case
@@ -1625,8 +1631,8 @@ coreDefineNamespace info b cont handler env = \case
         enforceGuard info cont' handler env laoG
       Nothing -> viewEvalEnv eeNamespacePolicy >>= \case
         SimpleNamespacePolicy -> do
-          chargeGasArgs info (GWrite (sizeOf SizeOfV0 ns))
-          let serializationGasser = chargeGasArgs info . GPassthrough
+          nsSize <- sizeOf SizeOfV0 ns
+          chargeGasArgs info (GWrite nsSize)
           liftDbFunction2 info $ _pdbWrite pdb serializationGasser Write DNamespaces nsn ns
           returnCEKValue cont handler $ VString $ "Namespace defined: " <> n
         SmartNamespacePolicy _ fun -> getModuleMember info pdb fun >>= \case