From f2ddb472a29b339b26d8d75d4ffd74cecd6ab734 Mon Sep 17 00:00:00 2001 From: jmcardon Date: Sun, 13 Oct 2024 20:49:08 -0400 Subject: [PATCH] Make SizeOf incremental, add GasCostConfig --- pact-tests/Pact/Core/Test/SizeOfTests.hs | 11 +- pact-tests/gas-goldens/builtinGas.golden | 90 +-- pact-tests/pact-tests/coin-v5.repl | 4 +- pact-tng.cabal | 1 + pact/Pact/Core/Gas/TableGasModel.hs | 345 ++++----- pact/Pact/Core/Gas/Types.hs | 136 +++- pact/Pact/Core/Gas/Utils.hs | 2 +- pact/Pact/Core/IR/Eval/CEK/CoreBuiltin.hs | 8 +- pact/Pact/Core/IR/Eval/CEK/Evaluator.hs | 12 +- pact/Pact/Core/IR/Eval/CEK/Utils.hs | 5 +- pact/Pact/Core/IR/Eval/Direct/CoreBuiltin.hs | 8 +- pact/Pact/Core/IR/Eval/Direct/Evaluator.hs | 6 +- pact/Pact/Core/IR/Eval/Runtime/Utils.hs | 31 +- pact/Pact/Core/Serialise/CBOR_V1.hs | 105 +-- pact/Pact/Core/SizeOf.hs | 773 +++++-------------- pact/Pact/Core/SizeOf/Deriving.hs | 113 +++ 16 files changed, 669 insertions(+), 981 deletions(-) create mode 100644 pact/Pact/Core/SizeOf/Deriving.hs diff --git a/pact-tests/Pact/Core/Test/SizeOfTests.hs b/pact-tests/Pact/Core/Test/SizeOfTests.hs index 17c21ca47..cb34b7600 100644 --- a/pact-tests/Pact/Core/Test/SizeOfTests.hs +++ b/pact-tests/Pact/Core/Test/SizeOfTests.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} -- | Tests for the sizes of various values. module Pact.Core.Test.SizeOfTests where @@ -35,10 +36,12 @@ tests = testGroup "SizeOfTests" $ assertEqual "size should be 5" 5 size , testCase "PactValue1" $ do Right size <- getSize SizeOfV0 (PInteger 1) - -- The size of the integer (at least 8 bytes) + the tag overhead of PLiteral (1 byte) - -- + tag overhead of PInteger (1 byte) - assertEqual "size should be 40" 10 size - , sizeOfSmallObject SizeOfV0 22 + -- The size of a PLiteral (LInteger 1) should be + -- 2 bytes for the ADT of PactValue (header + tag) + -- 2 bytes for the ADT of Literal (header + tag) + -- The size of the integer (at least 8 bytes + assertEqual "size should be 40" 12 size + , sizeOfSmallObject SizeOfV0 25 ] getSize :: SizeOf a => SizeOfVersion -> a -> IO (Either PactErrorI Bytes) diff --git a/pact-tests/gas-goldens/builtinGas.golden b/pact-tests/gas-goldens/builtinGas.golden index 0fb625053..82ec2b3bd 100644 --- a/pact-tests/gas-goldens/builtinGas.golden +++ b/pact-tests/gas-goldens/builtinGas.golden @@ -11,7 +11,7 @@ >=: 464 ^: 536 abs: 200 -acquire-module-admin: 291508 +acquire-module-admin: 297894 add-time: 750 and?: 1128 at: 906 @@ -20,38 +20,38 @@ base64-encode: 311 bind: 677 ceiling: 400 chain-data: 500 -compose-capability: 514515 +compose-capability: 514500 compose: 4460 concat: 920 cond: 1202 contains: 605 -continue: 444331 -create-capability-guard: 229145 -create-capability-pact-guard: 249303 -create-module-guard: 188183 -create-pact-guard: 211141 -create-principal: 2102 -create-table: 466487 +continue: 441650 +create-capability-guard: 227850 +create-capability-pact-guard: 246800 +create-module-guard: 188300 +create-pact-guard: 210050 +create-principal: 2302 +create-table: 466600 days: 278 dec: 200 -define-keyset: 8406 -define-namespace: 43419 -describe-keyset: 108406 -describe-module: 264673 -describe-namespace: 149136 -describe-table: 566487 +define-keyset: 8404 +define-namespace: 44212 +describe-keyset: 108404 +describe-module: 262700 +describe-namespace: 150124 +describe-table: 566600 diff-time: 1414 distinct: 3176 drop: 1400 -emit-event: 264965 -enforce-guard: 3366 -enforce-keyset: 3366 +emit-event: 263650 +enforce-guard: 3566 +enforce-keyset: 3566 enforce-verifier: 10150 -enumerate: 827 +enumerate: 824 exp: 10000 filter: 4460 floor: 400 -fold-db: 40524992 +fold-db: 40525850 fold: 1490 format-time: 1041 format: 2000 @@ -61,47 +61,47 @@ hyperlane-decode-token-message: 2175 hyperlane-encode-token-message: 2475 hyperlane-message-id: 2743 identity: 200 -insert: 524792 -install-capability: 667102 +insert: 525650 +install-capability: 670489 int-to-str: 1000 is-charset: 1788 is-principal: 797 -keys: 40524792 -keyset-ref-guard: 10427 +keys: 40525650 +keyset-ref-guard: 10425 length: 1101 list-modules: 100000 ln: 12000 log: 6000 -make-list: 216 +make-list: 225 map: 1715 minutes: 276 mod: 200 -namespace: 43431 +namespace: 44224 negate: 200 not: 664 not?: 664 or?: 664 -pact-id: 227047 -pairing-check: 11807943 +pact-id: 225950 +pairing-check: 12009033 parse-time: 602 point-add: 5600 poseidon-hash-hack-a-chain: 6393700 -read-decimal: 303 -read-integer: 303 -read-keyset: 8610 -read-msg: 303 -read-string: 303 -read: 533297 +read-decimal: 503 +read-integer: 503 +read-keyset: 8808 +read-msg: 503 +read-string: 503 +read: 534550 remove: 460 -require-capability: 403423 -resume: 507573 +require-capability: 402750 +resume: 515531 reverse: 800 round: 400 scalar-mult: 360400 -select: 40524942 +select: 40525800 shift: 1070 -show: 1201 -sort: 1403 +show: 1400 +sort: 1400 sqrt: 12000 str-to-int: 708 str-to-list: 751 @@ -110,14 +110,14 @@ time: 500 tx-hash: 200 typeof-principal: 997 typeof: 200 -update: 633197 -validate-principal: 4140 +update: 634750 +validate-principal: 4540 where: 2340 -with-default-read: 538763 -with-read: 533580 -write: 524792 +with-default-read: 540016 +with-read: 534833 +write: 525650 xor: 500 -yield: 328698 +yield: 328150 zip: 4920 |: 500 ~: 250 \ No newline at end of file diff --git a/pact-tests/pact-tests/coin-v5.repl b/pact-tests/pact-tests/coin-v5.repl index 906376da3..5b844dc0b 100644 --- a/pact-tests/pact-tests/coin-v5.repl +++ b/pact-tests/pact-tests/coin-v5.repl @@ -8,7 +8,7 @@ (env-gaslog) (expect "Gas cost of loading fungible contract" - 958 (env-gas)) + 918 (env-gas)) (commit-tx) (env-gasmodel "table") @@ -18,7 +18,7 @@ (env-gaslog) (expect "Gas cost of loading fungible-xchain contract" - 389 (env-gas)) + 371 (env-gas)) (commit-tx) (begin-tx) (env-gas 0) diff --git a/pact-tng.cabal b/pact-tng.cabal index c32c50afd..96c4c1bfe 100644 --- a/pact-tng.cabal +++ b/pact-tng.cabal @@ -263,6 +263,7 @@ library Pact.Core.SPV Pact.Core.Repl Pact.Core.SizeOf + Pact.Core.SizeOf.Deriving Pact.Core.StackFrame Pact.Core.Legacy.LegacyCodec Pact.Core.Verifiers diff --git a/pact/Pact/Core/Gas/TableGasModel.hs b/pact/Pact/Core/Gas/TableGasModel.hs index 817a4e20d..2bde66570 100644 --- a/pact/Pact/Core/Gas/TableGasModel.hs +++ b/pact/Pact/Core/Gas/TableGasModel.hs @@ -1,6 +1,7 @@ {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE RecordWildCards #-} module Pact.Core.Gas.TableGasModel ( tableGasModel @@ -10,10 +11,9 @@ module Pact.Core.Gas.TableGasModel , pointAddGas , scalarMulGas , pairingGas - , serializationCosts - , constantWorkNodeGas - , tryNodeGas - , unconsWorkNodeGas +-- , constantWorkNodeGas +-- , tryNodeGas +-- , unconsWorkNodeGas ) where @@ -25,14 +25,38 @@ import Pact.Core.Gas.Types import Data.Decimal import GHC.Base + +tableGasCostConfig :: GasCostConfig +tableGasCostConfig = GasCostConfig + { _gcNativeBasicWork = 200 + , _gcFunctionArgumentCost = 25 + , _gcMachineTickCost = 25 + , _gcUnconsWork = 100 + , _gcReadPenalty = 4_500 + , _gcWritePenalty = 50_000 + , _gcMetadataTxPenalty = 100_000 + , _gcSelectPenalty = 40_000_000 + , _gcConcatFactor = 100 + , _gcPerByteWriteCost = 200 + , _gcPerByteReadCost = 100 + , _gcSortBytePenaltyReduction = 1000 + , _gcPoseidonQuadraticGasFactor = 50_000 + , _gcPoseidonLinearGasFactor = 38_000 + , _gcModuleLoadSlope = 200 + , _gcModuleLoadIntercept = 10 + , _gcDesugarBytePenalty = 500 + , _gcSizeOfBytePenalty = 5 + } + + tableGasModel :: MilliGasLimit -> GasModel CoreBuiltin tableGasModel gl = GasModel { _gmName = "table" , _gmGasLimit = Just gl , _gmDesc = "table-based cost model" - , _gmNativeTable = coreBuiltinGasCost - , _gmSerialize = serializationCosts + , _gmNativeTable = coreBuiltinGasCost tableGasCostConfig + , _gmGasCostConfig = tableGasCostConfig } replTableGasModel :: Maybe MilliGasLimit -> GasModel ReplCoreBuiltin @@ -42,7 +66,7 @@ replTableGasModel gl = , _gmGasLimit = gl , _gmDesc = "table-based cost model" , _gmNativeTable = replNativeGasTable - , _gmSerialize = serializationCosts + , _gmGasCostConfig = tableGasCostConfig } ------------------------------------------------ @@ -243,8 +267,8 @@ intPowCost !base !power = MilliGas total !total = totalMults * k_const * ceiling (fromIntegral operandSizeAverage ** alpha) -runTableModel :: (b -> MilliGas) -> GasArgs b -> MilliGas -runTableModel nativeTable = \case +runTableModel :: (b -> MilliGas) -> GasCostConfig -> GasArgs b -> MilliGas +runTableModel nativeTable GasCostConfig{..} = \case GNative b -> nativeTable b GAConstant !c -> c GIntegerOpCost !primOp lop rop -> case primOp of @@ -258,18 +282,17 @@ runTableModel nativeTable = \case -- Todo: get actual metrics on list cat / text cat GConcat c -> case c of TextConcat (GasTextLength totalLen) -> - MilliGas (fromIntegral totalLen * 100) + MilliGas (fromIntegral totalLen * _gcConcatFactor) TextListConcat (GasTextLength totalCharSize) (GasListLength nElems) -> MilliGas $ - fromIntegral totalCharSize * stringLenCost + fromIntegral nElems * listLenCost + fromIntegral totalCharSize * _gcConcatFactor + fromIntegral nElems * listLenCost where - stringLenCost,listLenCost :: SatWord - stringLenCost = 100 + listLenCost :: SatWord listLenCost = 40 ListConcat (GasListLength totalLen) -> - MilliGas (fromIntegral totalLen * 100) + MilliGas (fromIntegral totalLen * _gcConcatFactor) ObjConcat totalLen -> - MilliGas (fromIntegral totalLen * 100) - GAApplyLam _ !i -> MilliGas $ fromIntegral i * applyLamCostPerArg + 50 + MilliGas (fromIntegral totalLen * _gcConcatFactor) + GAApplyLam _ !i -> MilliGas $ fromIntegral i * _gcFunctionArgumentCost + 50 GAZKArgs zka -> case zka of PointAdd g -> pointAddGas g ScalarMult g -> scalarMulGas g @@ -278,62 +301,54 @@ runTableModel nativeTable = \case -- So we add a bit of a higher penalty to this, since this -- costs us gas as well GWrite bytes -> - let mgPerByte = 200 - in MilliGas $ fromIntegral $ bytes * mgPerByte + MilliGas $ bytes * _gcPerByteWriteCost GRead bytes -> - let mgPerByte = 100 - in MilliGas $ fromIntegral $ bytes * mgPerByte + MilliGas $ bytes * _gcPerByteReadCost -- a string of 10⁶ chars (which is 2×10⁶ sizeof bytes) takes a little less than 2×10⁶ to write GMakeList len sz -> MilliGas $ fromIntegral len * fromIntegral sz GComparison cmpty -> case cmpty of TextComparison str -> - MilliGas $ textCompareCost str + basicWorkGas + MilliGas $ textCompareCost str + _gcNativeBasicWork IntComparison l r -> - MilliGas $ fromIntegral (max (integerBits l) (integerBits r)) + basicWorkGas + MilliGas $ fromIntegral (max (integerBits l) (integerBits r)) + _gcNativeBasicWork -- See [Decimal comparisons] DecimalComparison l r -> let !lmantissa = decimalMantissa l !rmantissa = decimalMantissa r in - intDivCost lmantissa rmantissa <> MilliGas (fromIntegral (max (integerBits lmantissa) (integerBits rmantissa)) + basicWorkGas) + intDivCost lmantissa rmantissa <> MilliGas (fromIntegral (max (integerBits lmantissa) (integerBits rmantissa)) + _gcNativeBasicWork) ListComparison maxSz -> - MilliGas $ fromIntegral maxSz * basicWorkGas + MilliGas $ fromIntegral maxSz * _gcNativeBasicWork ObjComparison i -> - MilliGas $ fromIntegral i * basicWorkGas + MilliGas $ fromIntegral i * _gcNativeBasicWork -- For sorting, what we do is essentially take the `sizeOf` number of bytes that we are comparing. -- Take that, have a cost of comparison proportional to the number of bytes, -- and charge for the _worst case_ O(n^2) number of comparisons. SortComparisons size len -> let !lenW = fromIntegral len - !bytePenaltyReduction = 1000 -- Comparisons is 1 mg per byte, so we simply take the length^2 * size - in MilliGas $ (fromIntegral size * lenW * lenW) `div` bytePenaltyReduction + in MilliGas $ (fromIntegral size * lenW * lenW) `div` _gcSortBytePenaltyReduction GSearch sty -> case sty of - SubstringSearch needle hay -> MilliGas $ fromIntegral (T.length needle + T.length hay) + basicWorkGas - FieldSearch cnt -> MilliGas $ fromIntegral cnt + basicWorkGas + SubstringSearch needle hay -> MilliGas $ fromIntegral (T.length needle + T.length hay) + _gcNativeBasicWork + FieldSearch cnt -> MilliGas $ fromIntegral cnt + _gcNativeBasicWork GPoseidonHashHackAChain len -> - MilliGas $ fromIntegral (len * len) * quadraticGasFactor + fromIntegral len * linearGasFactor - where - quadraticGasFactor, linearGasFactor :: SatWord - quadraticGasFactor = 50_000 - linearGasFactor = 38_000 + MilliGas $ fromIntegral (len * len) * _gcPoseidonQuadraticGasFactor + fromIntegral len * _gcPoseidonLinearGasFactor GModuleOp op -> case op of MOpLoadModule byteSize -> -- After some benchmarking, we can essentially say that the byte size of linear in -- the size of the module. -- We can cost module loads at approximately -- y=0.005x+10 - let !szCost = fromIntegral (byteSize `div` 200) + 10 + let !szCost = (fromIntegral byteSize `div` _gcModuleLoadSlope) + _gcModuleLoadIntercept in MilliGas szCost MOpMergeDeps i i' -> -- We can cost this quadratically, at 10mg per element merged MilliGas $ fromIntegral (i * i') * 10 MOpDesugarModule sz -> -- This is a pretty expensive traversal, so we will charge a bit more of a hefty price for it - let bytePenalty = 500 - in MilliGas (fromIntegral sz * bytePenalty) + MilliGas (fromIntegral sz * _gcDesugarBytePenalty) GStrOp op -> case op of StrOpLength len -> let charsPerMg = 100 @@ -369,7 +384,6 @@ runTableModel nativeTable = \case CapOpRequire cnt -> let mgPerCap = 100 in MilliGas $ fromIntegral $ cnt * mgPerCap - GCountBytes -> MilliGas 1 GHyperlaneMessageId m -> MilliGas $ fromIntegral m GHyperlaneEncodeDecodeTokenMessage m -> MilliGas $ fromIntegral m where @@ -378,39 +392,35 @@ runTableModel nativeTable = \case -- This is the minimum amount of gas we mean to charge to simply use the gas table. -- 25 milliGas = 62.5 nanoseconds, which is a negligible amount -basicWorkGas :: SatWord -basicWorkGas = 200 - -applyLamCostPerArg :: SatWord -applyLamCostPerArg = 25 - +-- _gcNativeBasicWork :: SatWord +-- _gcNativeBasicWork = 200 -- | Our internal gas table for constant costs on natives -coreBuiltinGasCost :: CoreBuiltin -> MilliGas -coreBuiltinGasCost = MilliGas . \case +coreBuiltinGasCost :: GasCostConfig -> CoreBuiltin -> MilliGas +coreBuiltinGasCost GasCostConfig{..} = MilliGas . \case -- Basic arithmetic -- note: add, sub, mul, div are special and are covered by -- special functions - CoreAdd -> basicWorkGas - CoreSub -> basicWorkGas - CoreMultiply -> basicWorkGas - CoreDivide -> basicWorkGas + CoreAdd -> _gcNativeBasicWork + CoreSub -> _gcNativeBasicWork + CoreMultiply -> _gcNativeBasicWork + CoreDivide -> _gcNativeBasicWork -- - CoreNegate -> basicWorkGas + CoreNegate -> _gcNativeBasicWork -- - CoreAbs -> basicWorkGas + CoreAbs -> _gcNativeBasicWork -- Pow is also a special case of recursive multiplication, gas table is not enough. - CorePow -> basicWorkGas + CorePow -> _gcNativeBasicWork -- - CoreNot -> basicWorkGas + CoreNot -> _gcNativeBasicWork -- ValEqGassed handles EQ and NEQ - CoreEq -> basicWorkGas - CoreNeq -> basicWorkGas + CoreEq -> _gcNativeBasicWork + CoreNeq -> _gcNativeBasicWork -- Note: `litCmpGassed` - CoreGT -> basicWorkGas - CoreGEQ -> basicWorkGas - CoreLT -> basicWorkGas - CoreLEQ -> basicWorkGas + CoreGT -> _gcNativeBasicWork + CoreGEQ -> _gcNativeBasicWork + CoreLT -> _gcNativeBasicWork + CoreLEQ -> _gcNativeBasicWork -- All of the bitwise functions are quite fast, regardless of the size of the integer -- constant time gas is fine here CoreBitwiseAnd -> 250 @@ -419,14 +429,14 @@ coreBuiltinGasCost = MilliGas . \case CoreBitwiseFlip -> 250 -- Shift requires special handling -- given it can actually grow the number - CoreBitShift -> basicWorkGas + CoreBitShift -> _gcNativeBasicWork -- Todo: rounding likely needs benchmarks, but - CoreRound -> basicWorkGas - CoreCeiling -> basicWorkGas - CoreFloor -> basicWorkGas - CoreRoundPrec -> basicWorkGas - CoreCeilingPrec -> basicWorkGas - CoreFloorPrec -> basicWorkGas + CoreRound -> _gcNativeBasicWork + CoreCeiling -> _gcNativeBasicWork + CoreFloor -> _gcNativeBasicWork + CoreRoundPrec -> _gcNativeBasicWork + CoreCeilingPrec -> _gcNativeBasicWork + CoreFloorPrec -> _gcNativeBasicWork -- Todo: transcendental functions are definitely over_gassed CoreExp -> 5_000 CoreLn -> 6_000 @@ -434,63 +444,62 @@ coreBuiltinGasCost = MilliGas . \case CoreLogBase -> 3_000 -- note: length, take and drop are constant time -- for vector and string, but variable for maps - -- Todo: gas take/drop on objects - CoreLength -> basicWorkGas - CoreTake -> basicWorkGas - CoreDrop -> basicWorkGas - -- concat - CoreConcat -> basicWorkGas - -- Todo: reverse gas based on `n` elements - CoreReverse -> basicWorkGas + CoreLength -> _gcNativeBasicWork + -- Note: take and drop are gassed at their callsites + CoreTake -> _gcNativeBasicWork + CoreDrop -> _gcNativeBasicWork + -- concat is gassed at its callsite + CoreConcat -> _gcNativeBasicWork + -- Note: reverse is gassed based on the number of elements + CoreReverse -> _gcNativeBasicWork -- note: contains needs to be gassed based on the -- specific data structure, so flat gas won't do - CoreContains -> basicWorkGas + CoreContains -> _gcNativeBasicWork -- Note: Sorting gas is handling in sort - CoreSort -> basicWorkGas - CoreSortObject -> basicWorkGas - -- Todo: Delete is O(log n) - CoreRemove -> basicWorkGas + CoreSort -> _gcNativeBasicWork + CoreSortObject -> _gcNativeBasicWork + -- Note: remove is gassed as its callsite + CoreRemove -> _gcNativeBasicWork -- Modulo has the time time complexity as division - CoreMod -> basicWorkGas + CoreMod -> _gcNativeBasicWork -- Map, filter, zip complexity only requires a list reverse, so the only cost -- we will charge is the cost of reverse CoreMap -> - basicWorkGas - CoreFilter -> basicWorkGas - CoreZip -> basicWorkGas + _gcNativeBasicWork + CoreFilter -> _gcNativeBasicWork + CoreZip -> _gcNativeBasicWork -- The time complexity of fold is the time complexity of the uncons operation - CoreFold -> basicWorkGas - -- Todo: complexity of these - CoreIntToStr -> basicWorkGas - CoreStrToInt -> basicWorkGas - CoreStrToIntBase -> basicWorkGas - -- Todo: Distinct and format require - -- special gas handling - CoreDistinct -> basicWorkGas - CoreFormat -> basicWorkGas + CoreFold -> _gcNativeBasicWork + -- Note: these following functions are gassed at their callsite + CoreIntToStr -> _gcNativeBasicWork + CoreStrToInt -> _gcNativeBasicWork + CoreStrToIntBase -> _gcNativeBasicWork + -- Note: Distinct has special gas handling + -- at its callsite + CoreDistinct -> _gcNativeBasicWork + CoreFormat -> _gcNativeBasicWork -- EnumerateN functions require more special gas handling as well - CoreEnumerate -> basicWorkGas - CoreEnumerateStepN -> basicWorkGas + CoreEnumerate -> _gcNativeBasicWork + CoreEnumerateStepN -> _gcNativeBasicWork -- Show also requires stringification - CoreShow -> basicWorkGas + CoreShow -> _gcNativeBasicWork -- read-* functions no longer parse their input - -- TODO: is this fine? - CoreReadMsg -> basicWorkGas - CoreReadMsgDefault -> basicWorkGas - CoreReadInteger -> basicWorkGas - CoreReadDecimal -> basicWorkGas - CoreReadString -> basicWorkGas - CoreReadKeyset -> basicWorkGas + CoreReadMsg -> _gcNativeBasicWork * 2 + CoreReadMsgDefault -> _gcNativeBasicWork * 2 + CoreReadInteger -> _gcNativeBasicWork * 2 + CoreReadDecimal -> _gcNativeBasicWork * 2 + CoreReadString -> _gcNativeBasicWork * 2 + CoreReadKeyset -> _gcNativeBasicWork * 2 -- Todo: Enforce functions should have variable gas -- based on the guard type CoreEnforceGuard -> 2_000 CoreEnforceKeyset -> 2_000 CoreKeysetRefGuard -> 2_000 - CoreAt -> basicWorkGas + CoreAt -> _gcNativeBasicWork -- Make-list is essentially replicate, so we just -- need the gas penalty - CoreMakeList -> basicWorkGas + CoreMakeList -> _gcNativeBasicWork -- Note: this is gassed via `StrOpParse` CoreB64Encode -> 250 CoreB64Decode -> 250 @@ -499,14 +508,14 @@ coreBuiltinGasCost = MilliGas . \case -- but should vary based on the length of the string CoreStrToList -> 250 -- Yield is essentially all constant-time ops - CoreYield -> basicWorkGas - CoreYieldToChain -> basicWorkGas + CoreYield -> _gcNativeBasicWork + CoreYieldToChain -> _gcNativeBasicWork -- Resume already will use applyLam gas -- and the rest of the operations are constant time CoreResume -> 500 -- Bind only applies a lambda CoreBind -> - basicWorkGas + _gcNativeBasicWork -- Todo: cap function gas should depend on the work of eval-cap -- and the cap state CoreRequireCapability -> 500 @@ -516,21 +525,21 @@ coreBuiltinGasCost = MilliGas . \case CoreEmitEvent -> 1_000 -- Create-capability-guard is constant time and fast, in core we are cheaper here CoreCreateCapabilityGuard -> - basicWorkGas + _gcNativeBasicWork CoreCreateCapabilityPactGuard -> - basicWorkGas + _gcNativeBasicWork -- create-module-guard is a simple uncons - CoreCreateModuleGuard -> 2 * basicWorkGas + CoreCreateModuleGuard -> 2 * _gcNativeBasicWork -- create-pact-guard is a simple uncons - CoreCreateDefPactGuard -> 2 * basicWorkGas + CoreCreateDefPactGuard -> 2 * _gcNativeBasicWork -- Create-table depends heavily on the implementation, but -- should return within a reasonable time frame. We -- charge a penalty for using within a tx CoreCreateTable -> 250_000 -- The following functions also incur a gas penalty - CoreDescribeKeyset -> dbMetadataTxPenalty - CoreDescribeModule -> dbMetadataTxPenalty - CoreDescribeTable -> dbMetadataTxPenalty + CoreDescribeKeyset -> _gcMetadataTxPenalty + CoreDescribeModule -> _gcMetadataTxPenalty + CoreDescribeTable -> _gcMetadataTxPenalty -- Registry functions -- both are constant-time work, but incur a db tx penalty CoreDefineKeySet -> @@ -539,41 +548,41 @@ coreBuiltinGasCost = MilliGas . \case 5_000 -- fold-db incurs currently a penalty on mainnet CoreFoldDb -> - dbSelectPenalty + _gcSelectPenalty -- Insert db overhead CoreInsert -> - dbWritePenalty + _gcWritePenalty -- Todo: keys gas needs to be revisited. We leave in the current penalty CoreKeys -> - dbSelectPenalty + _gcSelectPenalty -- read depends on bytes as well, 10 gas is a tx penalty CoreRead -> - dbReadPenalty + _gcReadPenalty CoreSelect -> - dbSelectPenalty + _gcSelectPenalty CoreSelectWithFields -> - dbSelectPenalty + _gcSelectPenalty -- Update same gas penalty as write and insert CoreUpdate -> 100_000 -- note: with-default read and read -- should cost the same. CoreWithDefaultRead -> - dbReadPenalty - CoreWithRead -> dbReadPenalty + _gcReadPenalty + CoreWithRead -> _gcReadPenalty -- Write penalty as well - CoreWrite -> dbWritePenalty + CoreWrite -> _gcWritePenalty -- Tx-hash should be constant-time CoreTxHash -> - basicWorkGas + _gcNativeBasicWork -- and? and co. should have essentially no penalty but whatever applyLam costs - CoreAndQ -> basicWorkGas - CoreOrQ -> basicWorkGas - CoreWhere -> basicWorkGas - CoreNotQ -> basicWorkGas + CoreAndQ -> _gcNativeBasicWork + CoreOrQ -> _gcNativeBasicWork + CoreWhere -> _gcNativeBasicWork + CoreNotQ -> _gcNativeBasicWork -- Todo: hashGas depends on input - CoreHash -> basicWorkGas + CoreHash -> _gcNativeBasicWork -- Continue in pact-core currently amounts to `id` - CoreContinue -> basicWorkGas + CoreContinue -> _gcNativeBasicWork -- Time functions complexity -- is handled in the function itself CoreParseTime -> 500 @@ -595,91 +604,51 @@ coreBuiltinGasCost = MilliGas . \case -- Compose is constant time, and just evaluated in pact-core to -- some continuation manipulation CoreCompose -> - basicWorkGas + _gcNativeBasicWork -- Note: create-principal is gassed via the principal creation functions - CoreCreatePrincipal -> basicWorkGas - CoreIsPrincipal -> basicWorkGas - CoreTypeOfPrincipal -> basicWorkGas + CoreCreatePrincipal -> _gcNativeBasicWork + CoreIsPrincipal -> _gcNativeBasicWork + CoreTypeOfPrincipal -> _gcNativeBasicWork -- note: validate-principal is essentially a constant time comparison on fixed-length strings. -- The actual gassing of constructing the principal is done inside of it CoreValidatePrincipal -> 250 -- Namespace function is constant work - CoreNamespace -> basicWorkGas + CoreNamespace -> _gcNativeBasicWork -- define-namespace tx penalty CoreDefineNamespace -> 25_000 - CoreDescribeNamespace -> dbMetadataTxPenalty + CoreDescribeNamespace -> _gcMetadataTxPenalty CoreChainData -> 500 CoreIsCharset -> 500 - CorePactId -> basicWorkGas + CorePactId -> _gcNativeBasicWork -- Note: pairing functions have custom gas - CoreZkPairingCheck -> basicWorkGas - CoreZKScalarMult -> basicWorkGas - CoreZkPointAdd -> basicWorkGas + CoreZkPairingCheck -> _gcNativeBasicWork + CoreZKScalarMult -> _gcNativeBasicWork + CoreZkPointAdd -> _gcNativeBasicWork CorePoseidonHashHackachain -> 124_000 -- Note: type synthesis is constant time and very fast - CoreTypeOf -> basicWorkGas + CoreTypeOf -> _gcNativeBasicWork -- note: Dec requires less gas overall CoreDec -> - basicWorkGas - CoreCond -> basicWorkGas - CoreIdentity -> basicWorkGas + _gcNativeBasicWork + CoreCond -> _gcNativeBasicWork + CoreIdentity -> _gcNativeBasicWork CoreVerifySPV -> 100_000 CoreEnforceVerifier -> 10_000 CoreHyperlaneMessageId -> 2_000 CoreHyperlaneDecodeMessage -> 2_000 CoreHyperlaneEncodeMessage -> 2_000 CoreAcquireModuleAdmin -> 20_000 - CoreReadWithFields -> dbReadPenalty - CoreListModules -> dbMetadataTxPenalty + CoreReadWithFields -> _gcReadPenalty + CoreListModules -> _gcMetadataTxPenalty {-# INLINABLE runTableModel #-} replNativeGasTable :: ReplBuiltin CoreBuiltin -> MilliGas replNativeGasTable = \case - RBuiltinWrap bwrap -> coreBuiltinGasCost bwrap + RBuiltinWrap bwrap -> coreBuiltinGasCost tableGasCostConfig bwrap _ -> mempty - --- Select penalty will be revisited @ a later date -dbSelectPenalty :: SatWord -dbSelectPenalty = 40_000_000 - -dbWritePenalty :: SatWord -dbWritePenalty = 50_000 - -dbReadPenalty :: SatWord -dbReadPenalty = 4_500 - -dbMetadataTxPenalty :: SatWord -dbMetadataTxPenalty = 100_000 - --- | The gas amount for a small constant amount of work -constantWorkNodeGas :: MilliGas -constantWorkNodeGas = (MilliGas 50) - -unconsWorkNodeGas :: MilliGas -unconsWorkNodeGas = (MilliGas 100) - -tryNodeGas :: MilliGas -tryNodeGas = (MilliGas 100) - - --- PactValue serialization costs -serializationCosts :: SerializationCosts -serializationCosts = SerializationCosts - { objectKeyCostMilliGasOffset = 1 - , objectKeyCostMilliGasPer1000Chars = 69 - , boolMilliGasCost = 52 - , unitMilliGasCost = 51 - , integerCostMilliGasPerDigit = 2 - , decimalCostMilliGasOffset = 59 - , decimalCostMilliGasPerDigit = 2 - , timeCostMilliGas = 184 -} - - - -- [Decimal Comparisons] -- The `Ord` instance, and by that measure and comparison on two decimals is done via -- -- Round the two DecimalRaw values to the largest exponent. diff --git a/pact/Pact/Core/Gas/Types.hs b/pact/Pact/Core/Gas/Types.hs index 618a4beb5..75bb0c79e 100644 --- a/pact/Pact/Core/Gas/Types.hs +++ b/pact/Pact/Core/Gas/Types.hs @@ -30,7 +30,6 @@ module Pact.Core.Gas.Types , GasModel(..) , GasArgs(..) - , SerializationCosts(..) , NodeType(..) , ZKGroup(..) @@ -50,10 +49,11 @@ module Pact.Core.Gas.Types , gmGasLimit , gmDesc , gmName - , gmSerialize + , gmGasCostConfig , gmNativeTable , freeGasModel + , GasCostConfig(..) , module Pact.Core.SatWord ) where @@ -62,7 +62,6 @@ import Control.DeepSeq import Control.Lens import Data.Decimal(Decimal) import Data.Monoid -import Data.Word (Word64) import Data.Primitive hiding (sizeOf) import qualified Data.Text as T import Data.Text (Text) @@ -118,6 +117,56 @@ newtype GasPrice makePrisms ''GasPrice +-- | Our gas costs tuned for the pact language's gas model +-- Note: All values are `SatWord`s, which are essentially +-- costs in MilliGas +data GasCostConfig + = GasCostConfig + { _gcNativeBasicWork :: !SatWord + -- ^ The minimal work our machine charges for + -- calling any native + , _gcFunctionArgumentCost :: !SatWord + -- ^ The flat cost per argument for + -- function calls. Note: Typechecking is costed separately + , _gcMachineTickCost :: !SatWord + -- ^ The flat cost for a state transition in our machine + , _gcUnconsWork :: !SatWord + -- ^ Flat cost for list unconsing, particularly for maps and + -- folds in natives + , _gcReadPenalty :: !SatWord + -- ^ Our flat penalty for reading from the database + , _gcWritePenalty :: !SatWord + -- ^ Our flat penalty for writing to the database + , _gcMetadataTxPenalty :: !SatWord + -- ^ Penalty for db metadata functions + , _gcSelectPenalty :: !SatWord + -- ^ Penalty for calling select + , _gcConcatFactor :: !SatWord + -- ^ Cost of element concatenation. Particularly for our + -- concatenation functions (+, concat) + , _gcPerByteWriteCost :: !SatWord + -- ^ The cost per byte on write for + -- entries to the database. This applies to all tables + , _gcPerByteReadCost :: !SatWord + -- ^ The cost per byte of reading from the database + , _gcSortBytePenaltyReduction :: !SatWord + -- ^ The sort penalty reduction + , _gcPoseidonQuadraticGasFactor :: !SatWord + -- ^ Poseidon hashing quadratic gas factor + , _gcPoseidonLinearGasFactor :: !SatWord + -- ^ Poseidon hashing linear gas factor + , _gcModuleLoadSlope :: !SatWord + -- ^ Module load cost function slope + , _gcModuleLoadIntercept :: !SatWord + -- ^ Module load cost function Intercept + , _gcDesugarBytePenalty :: !SatWord + -- ^ Module load desugaring byte penalty + , _gcSizeOfBytePenalty :: !SatWord + -- ^ Our `SizeOf` limit penalty + } deriving (Eq, Show, Generic) + +instance NFData GasCostConfig + milliGasPerGas :: SatWord milliGasPerGas = 1000 @@ -232,13 +281,13 @@ data GasArgs b -- ^ The cost of concatenating two elements -- TODO: We actually reuse this cost for construction as well for objects/lists. Should we -- instead consider renaming the objcat and listcat constructors to be ListCatOrConstruction - | GMakeList !Integer !Word64 + | GMakeList !Integer !SatWord -- ^ Cost of creating a list of `n` elements + some memory overhead per elem | GAZKArgs !ZKArg -- ^ Cost of ZK function - | GWrite !Word64 + | GWrite !SatWord -- ^ Cost of writes, per bytes, roughly based on in-memory cost. - | GRead !Word64 + | GRead !SatWord -- ^ Cost of reads, per bytes, roughly based on in-memory cost. | GComparison !ComparisonType -- ^ Gas costs for comparisons @@ -259,8 +308,6 @@ data GasArgs b | GStrOp !StrOp | GObjOp !ObjOp | GCapOp !CapOp - | GCountBytes - -- ^ Cost of computing SizeOf for N bytes. deriving (Show, Eq, Generic, NFData) data ModuleOp @@ -269,7 +316,7 @@ data ModuleOp -- arguments are: | MOpMergeDeps Int Int -- ^ Cost of adding deps to the symbol table - | MOpDesugarModule !Word64 -- Size of the tree + | MOpDesugarModule !SatWord -- Size of the tree -- ^ the cost of module desugar deriving (Show, Eq, Generic, NFData) @@ -314,7 +361,7 @@ data ComparisonType -- ^ N comparisons constant time overhead | ObjComparison !Int -- ^ Compare objects of at most size `N` - | SortComparisons !Word64 !Int + | SortComparisons !SatWord !Int deriving (Show, Eq, Generic, NFData) data ConcatType @@ -328,39 +375,58 @@ data ConcatType -- ^ Upper bound on max object size deriving (Show, Eq, Generic, NFData) -data SerializationCosts = SerializationCosts - { objectKeyCostMilliGasOffset :: !SatWord - , objectKeyCostMilliGasPer1000Chars :: !SatWord - , boolMilliGasCost :: !SatWord - , unitMilliGasCost :: !SatWord - , integerCostMilliGasPerDigit :: !SatWord - , decimalCostMilliGasOffset :: !SatWord - , decimalCostMilliGasPerDigit :: !SatWord - , timeCostMilliGas :: !SatWord - } - deriving (Show, Generic, NFData) - -freeSerializationCosts :: SerializationCosts -freeSerializationCosts = SerializationCosts - { objectKeyCostMilliGasOffset = 0 - , objectKeyCostMilliGasPer1000Chars = 0 - , boolMilliGasCost = 0 - , unitMilliGasCost = 0 - , integerCostMilliGasPerDigit = 0 - , decimalCostMilliGasOffset = 0 - , decimalCostMilliGasPerDigit = 0 - , timeCostMilliGas = 0 +freeGasCostConfig :: GasCostConfig +freeGasCostConfig = GasCostConfig + { _gcNativeBasicWork = 1 + -- ^ The minimal work our machine charges for + -- calling any native + , _gcFunctionArgumentCost = 1 + -- ^ The flat cost per argument for + -- function calls. Note: Typechecking is costed separately + , _gcMachineTickCost = 1 + -- ^ The flat cost for a state transition in our machine + , _gcUnconsWork = 1 + -- ^ Flat cost for list unconsing, particularly for maps and + -- folds in natives + , _gcReadPenalty = 1 + -- ^ Our flat penalty for reading from the database + , _gcWritePenalty = 1 + -- ^ Our flat penalty for writing to the database + , _gcMetadataTxPenalty = 1 + -- ^ Penalty for db metadata functions + , _gcSelectPenalty = 1 + -- ^ Penalty for calling select + , _gcConcatFactor = 1 + -- ^ Cost of element concatenation. Particularly for our + -- concatenation functions (+, concat) + , _gcPerByteWriteCost = 1 + -- ^ The cost per byte on write for + -- entries to the database. This applies to all tables + , _gcPerByteReadCost = 1 + -- ^ The cost per byte of reading from the database + , _gcSortBytePenaltyReduction = 1 + -- ^ The sort penalty reduction + , _gcPoseidonQuadraticGasFactor = 1 + -- ^ Poseidon hashing quadratic gas factor + , _gcPoseidonLinearGasFactor = 1 + -- ^ Poseidon hashing linear gas factor + , _gcModuleLoadSlope = 1 + -- ^ Module load cost function slope + , _gcModuleLoadIntercept = 1 + -- ^ Module load cost function Intercept + , _gcDesugarBytePenalty = 1 + -- ^ Module load desugaring byte penalty + , _gcSizeOfBytePenalty = 1 } - data GasModel b = GasModel { _gmName :: !Text , _gmDesc :: !Text , _gmNativeTable :: !(b -> MilliGas) , _gmGasLimit :: !(Maybe MilliGasLimit) - , _gmSerialize :: !SerializationCosts + , _gmGasCostConfig :: !GasCostConfig } deriving (Generic, NFData) makeLenses ''GasModel @@ -371,7 +437,7 @@ freeGasModel = GasModel , _gmDesc = "free gas model" , _gmNativeTable = \_ -> mempty , _gmGasLimit = Nothing - , _gmSerialize = freeSerializationCosts + , _gmGasCostConfig = freeGasCostConfig } data GasLogEntry b i = GasLogEntry diff --git a/pact/Pact/Core/Gas/Utils.hs b/pact/Pact/Core/Gas/Utils.hs index 2a8e95f79..b885e096a 100644 --- a/pact/Pact/Core/Gas/Utils.hs +++ b/pact/Pact/Core/Gas/Utils.hs @@ -27,7 +27,7 @@ scalarMulMilliGas (MilliGas mg) i = chargeGasArgsM :: GasEnv b i -> i -> [StackFrame i] -> GasArgs b -> IO (Either (PactError i) ()) chargeGasArgsM GasEnv{..} info stack gasArgs = do - let !milliGasCost = runTableModel (_gmNativeTable _geGasModel) gasArgs + let !milliGasCost = runTableModel (_gmNativeTable _geGasModel) (_gmGasCostConfig _geGasModel) gasArgs case _gmGasLimit _geGasModel of Just mgl@(MilliGasLimit milliGasLimit) -> do newGasTotal <- do diff --git a/pact/Pact/Core/IR/Eval/CEK/CoreBuiltin.hs b/pact/Pact/Core/IR/Eval/CEK/CoreBuiltin.hs index 5a79b816b..9b7b09847 100644 --- a/pact/Pact/Core/IR/Eval/CEK/CoreBuiltin.hs +++ b/pact/Pact/Core/IR/Eval/CEK/CoreBuiltin.hs @@ -611,7 +611,7 @@ zipList info b cont handler _env = \case [VClosure clo, VList l, VList r] -> case (V.toList l, V.toList r) of (x:xs, y:ys) -> do - chargeGasArgs info (GAConstant unconsWorkNodeGas) + chargeUnconsWork info let cont' = BuiltinC _env info (ZipC clo (xs, ys) []) cont applyLam clo [VPactValue x, VPactValue y] cont' handler (_, _) -> returnCEKValue cont handler (VList mempty) @@ -622,7 +622,7 @@ coreMap info b cont handler env = \case [VClosure clo, VList li] -> case V.toList li of x:xs -> do let cont' = BuiltinC env info (MapC clo xs []) cont - chargeGasArgs info (GAConstant unconsWorkNodeGas) + chargeUnconsWork info applyLam clo [VPactValue x] cont' handler [] -> returnCEKValue cont handler (VList mempty) args -> argsError info b args @@ -631,7 +631,7 @@ coreFilter :: (IsBuiltin b) => NativeFunction e b i coreFilter info b cont handler _env = \case [VClosure clo, VList li] -> case V.toList li of x:xs -> do - chargeGasArgs info (GAConstant unconsWorkNodeGas) + chargeUnconsWork info let cont' = CondC _env info (FilterC clo x xs []) cont applyLam clo [VPactValue x] cont' handler [] -> returnCEKValue cont handler (VList mempty) @@ -642,7 +642,7 @@ coreFold info b cont handler _env = \case [VClosure clo, VPactValue initElem, VList li] -> case V.toList li of x:xs -> do - chargeGasArgs info (GAConstant unconsWorkNodeGas) + chargeUnconsWork info let cont' = BuiltinC _env info (FoldC clo xs) cont applyLam clo [VPactValue initElem, VPactValue x] cont' handler [] -> returnCEKValue cont handler (VPactValue initElem) diff --git a/pact/Pact/Core/IR/Eval/CEK/Evaluator.hs b/pact/Pact/Core/IR/Eval/CEK/Evaluator.hs index 62addebcc..26aede3ab 100644 --- a/pact/Pact/Core/IR/Eval/CEK/Evaluator.hs +++ b/pact/Pact/Core/IR/Eval/CEK/Evaluator.hs @@ -253,7 +253,7 @@ evaluateTerm cont handler env (BuiltinForm c info) = case c of -- -- _errState - callstack,granted caps,events,gas CTry catchExpr rest -> do - chargeGasArgs info (GAConstant tryNodeGas) + chargeTryNodeWork info errState <- evalStateToErrorState <$> get let handler' = CEKHandler env catchExpr cont errState handler let env' = readOnlyEnv env @@ -265,7 +265,7 @@ evaluateTerm cont handler env (BuiltinForm c info) = case c of returnCEK cont handler (VError [] (UserEnforceError "internal CEnforceOne error") info) x:xs -> do -- Todo: is this a bit too cheap?? - chargeGasArgs info (GAConstant unconsWorkNodeGas) + chargeUnconsWork info errState <- evalStateToErrorState <$> get let env' = readOnlyEnv env let handler' = CEKEnforceOne env' info str xs cont errState handler @@ -1033,7 +1033,7 @@ applyContToValue (CondC env info frame cont) handler v = do let acc' = if b then elem':acc else acc case rest of x:xs -> do - chargeGasArgs info (GAConstant unconsWorkNodeGas) + chargeUnconsWork info let cont' = CondC env info (FilterC clo x xs acc') cont applyLam clo [VPactValue x] cont' handler [] -> returnCEKValue cont handler (VList (V.fromList (reverse acc'))) @@ -1088,7 +1088,7 @@ applyContToValue (BuiltinC env info frame cont) handler cv = do case rest of x:xs -> do let cont' = BuiltinC env info (MapC closure xs (v:acc)) cont - chargeGasArgs info (GAConstant unconsWorkNodeGas) + chargeUnconsWork info applyLam closure [VPactValue x] cont' handler [] -> returnCEKValue cont handler (VList (V.fromList (reverse (v:acc)))) @@ -1096,14 +1096,14 @@ applyContToValue (BuiltinC env info frame cont) handler cv = do case rest of x:xs -> do let cont' = BuiltinC env info (FoldC clo xs) cont - chargeGasArgs info (GAConstant unconsWorkNodeGas) + chargeUnconsWork info applyLam clo [VPactValue v, VPactValue x] cont' handler [] -> returnCEKValue cont handler cv ZipC clo (l, r) acc -> do case (l, r) of (x:xs, y:ys) -> do let cont' = BuiltinC env info (ZipC clo (xs, ys) (v:acc)) cont - chargeGasArgs info (GAConstant unconsWorkNodeGas) + chargeUnconsWork info applyLam clo [VPactValue x, VPactValue y] cont' handler (_, _) -> returnCEKValue cont handler (VList (V.fromList (reverse (v:acc)))) diff --git a/pact/Pact/Core/IR/Eval/CEK/Utils.hs b/pact/Pact/Core/IR/Eval/CEK/Utils.hs index 725307f80..502968a3f 100644 --- a/pact/Pact/Core/IR/Eval/CEK/Utils.hs +++ b/pact/Pact/Core/IR/Eval/CEK/Utils.hs @@ -8,9 +8,7 @@ module Pact.Core.IR.Eval.CEK.Utils , readOnlyEnv , envFromPurity , enforcePactValue - , tryNodeGas - , unconsWorkNodeGas - , constantWorkNodeGas) where + ) where import Control.Lens @@ -20,7 +18,6 @@ import Pact.Core.Type import Pact.Core.Errors import Pact.Core.Persistence import Pact.Core.Environment -import Pact.Core.Gas import Pact.Core.IR.Eval.CEK.Types mkBuiltinFn diff --git a/pact/Pact/Core/IR/Eval/Direct/CoreBuiltin.hs b/pact/Pact/Core/IR/Eval/Direct/CoreBuiltin.hs index c1339a211..053130644 100644 --- a/pact/Pact/Core/IR/Eval/Direct/CoreBuiltin.hs +++ b/pact/Pact/Core/IR/Eval/Direct/CoreBuiltin.hs @@ -613,7 +613,7 @@ zipList info b _env = \case VList <$> V.zipWithM go l r where go x y = do - chargeGasArgs info (GAConstant unconsWorkNodeGas) + chargeUnconsWork info enforcePactValue info =<< applyLam clo [VPactValue x, VPactValue y] args -> argsError info b args @@ -623,7 +623,7 @@ coreMap info b _env = \case VList <$> traverse go li where go x = do - chargeGasArgs info (GAConstant unconsWorkNodeGas) + chargeUnconsWork info applyLam clo [VPactValue x] >>= enforcePactValue info args -> argsError info b args @@ -633,7 +633,7 @@ coreFilter info b _env = \case VList <$> V.filterM go li where go e = do - chargeGasArgs info (GAConstant unconsWorkNodeGas) + chargeUnconsWork info applyLam clo [VPactValue e] >>= enforceBool info args -> argsError info b args @@ -643,7 +643,7 @@ coreFold info b _env = \case VPactValue <$> foldlM go initElem li where go e inc = do - chargeGasArgs info (GAConstant unconsWorkNodeGas) + chargeUnconsWork info applyLam clo [VPactValue e, VPactValue inc] >>= enforcePactValue info args -> argsError info b args diff --git a/pact/Pact/Core/IR/Eval/Direct/Evaluator.hs b/pact/Pact/Core/IR/Eval/Direct/Evaluator.hs index c87647e6a..a2360c2fc 100644 --- a/pact/Pact/Core/IR/Eval/Direct/Evaluator.hs +++ b/pact/Pact/Core/IR/Eval/Direct/Evaluator.hs @@ -23,7 +23,6 @@ module Pact.Core.IR.Eval.Direct.Evaluator , interpretGuard , resumePact , applyPact - , constantWorkNodeGas , applyLamUnsafe , evalCap , installCap @@ -38,7 +37,6 @@ module Pact.Core.IR.Eval.Direct.Evaluator , enforceGuard , applyLam , evalWithinCap - , unconsWorkNodeGas , enforceNotWithinDefcap , isKeysetInSigs , isKeysetNameInSigs @@ -294,7 +292,7 @@ evaluate env = \case _ -> throwExecutionError info $ NativeExecutionError (NativeName "create-user-guard") $ "create-user-guard: expected function application of a top-level function" CTry catchExpr tryExpr -> do - chargeGasArgs info (GAConstant tryNodeGas) + chargeTryNodeWork info let env' = readOnlyEnv env catchRecoverable (evaluate env' tryExpr) (\_ _ -> evaluate env catchExpr) CEnforceOne str (ListLit conds _) -> @@ -302,7 +300,7 @@ evaluate env = \case where go (x:xs) = do cond <- catchRecoverable (enforceBool info =<< evaluate env x) (\_ _ -> pure False) - chargeGasArgs info (GAConstant unconsWorkNodeGas) + chargeUnconsWork info if cond then return (VBool True) else go xs go [] = do diff --git a/pact/Pact/Core/IR/Eval/Runtime/Utils.hs b/pact/Pact/Core/IR/Eval/Runtime/Utils.hs index b35d2f296..1d19e9781 100644 --- a/pact/Pact/Core/IR/Eval/Runtime/Utils.hs +++ b/pact/Pact/Core/IR/Eval/Runtime/Utils.hs @@ -55,6 +55,9 @@ module Pact.Core.IR.Eval.Runtime.Utils , guardForModuleCall , guardTable , emitPactWarning + , chargeConstantWork + , chargeUnconsWork + , chargeTryNodeWork ) where import Control.Lens hiding (from, to) @@ -183,6 +186,26 @@ typecheckArgument info pv ty = do c <- gassedRuntimeTypecheck info ty pv unless c $ throwExecutionError info (RunTimeTypecheckFailure (pvToArgTypeError pv) ty) +chargeConstantFromConfig :: (GasCostConfig -> SatWord) -> i -> EvalM e b i () +chargeConstantFromConfig f i = do + gcc <- viewEvalEnv (eeGasEnv . geGasModel . gmGasCostConfig) + chargeGasArgs i (GAConstant (MilliGas (f gcc))) + +chargeConstantScalarMulFromConfig :: (GasCostConfig -> SatWord) -> SatWord -> i -> EvalM e b i () +chargeConstantScalarMulFromConfig f k i = do + gcc <- viewEvalEnv (eeGasEnv . geGasModel . gmGasCostConfig) + chargeGasArgs i (GAConstant (MilliGas (f gcc * k))) + + +chargeConstantWork :: i -> EvalM e b i () +chargeConstantWork = chargeConstantFromConfig _gcMachineTickCost + +chargeTryNodeWork :: i -> EvalM e b i () +chargeTryNodeWork = chargeConstantFromConfig _gcUnconsWork + +chargeUnconsWork :: i -> EvalM e b i () +chargeUnconsWork = chargeConstantFromConfig _gcUnconsWork + -- | Runtime typechecking. For "simple" non-recursive types, -- this is free. Otherwise, we will charge a small amount of gas per -- "layer" of typechecking @@ -199,14 +222,14 @@ gassedRuntimeTypecheck i ty = \case | S.size ifs < 10 -> pure (mns `S.isSubsetOf` ifs) | otherwise -> do - chargeGasArgs i (GAConstant (scalarMulMilliGas constantWorkNodeGas (S.size ifs))) + chargeConstantScalarMulFromConfig _gcMachineTickCost (fromIntegral (S.size ifs)) i pure (mns `S.isSubsetOf` ifs) _ -> pure False PList pli -> case ty of TyAnyList -> pure True TyList t -> do -- Note: length is O(1) - chargeGasArgs i (GAConstant (scalarMulMilliGas constantWorkNodeGas (V.length pli))) + chargeConstantScalarMulFromConfig _gcMachineTickCost (fromIntegral (V.length pli)) i vs <- traverse (gassedRuntimeTypecheck i t) pli pure (and vs) _ -> pure False @@ -219,7 +242,7 @@ gassedRuntimeTypecheck i ty = \case gassedTypecheckObj :: i -> M.Map Field PactValue -> Schema -> EvalM e b i Bool gassedTypecheckObj i o (Schema _ sc) | M.size o == M.size sc = do - chargeGasArgs i (GAConstant (scalarMulMilliGas constantWorkNodeGas (M.size o))) + chargeConstantScalarMulFromConfig _gcMachineTickCost (fromIntegral (M.size o)) i go (M.toList o) (M.toList sc) | otherwise = pure False where @@ -338,7 +361,7 @@ checkSchema = gassedTypecheckObj -- | Todo: revisit checkPartialSchema :: i -> M.Map Field PactValue -> Schema -> EvalM e b i Bool checkPartialSchema info o (Schema q sc) = do - chargeGasArgs info (GAConstant (scalarMulMilliGas constantWorkNodeGas (M.size o))) + chargeConstantScalarMulFromConfig _gcMachineTickCost (fromIntegral (M.size o)) info let keys = M.keys o if all (`M.member` sc) keys then gassedTypecheckObj info o (Schema q (M.restrictKeys sc (S.fromList keys))) diff --git a/pact/Pact/Core/Serialise/CBOR_V1.hs b/pact/Pact/Core/Serialise/CBOR_V1.hs index ac7f8126f..aac2fc942 100644 --- a/pact/Pact/Core/Serialise/CBOR_V1.hs +++ b/pact/Pact/Core/Serialise/CBOR_V1.hs @@ -18,7 +18,7 @@ module Pact.Core.Serialise.CBOR_V1 , encodeKeySet, decodeKeySet , encodeDefPactExec, decodeDefPactExec , encodeNamespace, decodeNamespace - , encodeRowData, decodeRowData + , decodeRowData , encodeRowDataNoGas -- only used for legacy translation , encodeModuleName @@ -26,7 +26,6 @@ module Pact.Core.Serialise.CBOR_V1 , SerialiseV1(..) ) where -import Control.Lens import Codec.CBOR.Read (deserialiseFromBytes) import Codec.CBOR.Write (toStrictByteString) import Codec.Serialise @@ -34,18 +33,12 @@ import Codec.CBOR.Encoding import Codec.CBOR.Decoding import Data.ByteString (ByteString, fromStrict) import Data.Decimal -import Data.Foldable import Data.Coerce -import qualified Data.Map as Map -import qualified Data.Text as Text -import qualified GHC.Integer.Logarithms as IntLog -import GHC.Int(Int(..)) import Pact.Core.Builtin import Pact.Core.Capabilities import Pact.Core.ChainData import Pact.Core.DefPacts.Types -import Pact.Core.Gas import Pact.Core.Guards import Pact.Core.Hash import Pact.Core.Imports @@ -57,7 +50,6 @@ import Pact.Core.Names import Pact.Core.Namespace import Pact.Core.PactValue import Pact.Core.Persistence -import Pact.Core.Pretty import Pact.Core.Type import Pact.Time.Internal (UTCTime(..), NominalDiffTime(..)) import qualified Data.Set as S @@ -122,105 +114,10 @@ encodeNamespace = toStrictByteString . encodeS decodeNamespace :: ByteString -> Maybe Namespace decodeNamespace bs =either (const Nothing) (Just . snd) (deserialiseFromBytes decodeS (fromStrict bs)) - -encodeRowData :: RowData -> GasM b i ByteString -encodeRowData rd = do - gasSerializeRowData rd - pure . toStrictByteString $ encodeS rd - encodeRowDataNoGas :: RowData -> ByteString encodeRowDataNoGas rd = toStrictByteString $ encodeS rd -chargeGasMSerialize :: MilliGas -> GasM b i () -chargeGasMSerialize amount = do - chargeGasM (GAConstant amount) - -gasSerializeRowData :: forall i b. RowData -> GasM b i () -gasSerializeRowData (RowData fields) = do - - -- Charge for keys - chargeGasMString $ Text.concat $ _field <$> Map.keys fields - - -- Charge for values - traverse_ gasSerializePactValue fields - - where - - gasSerializePactValue :: PactValue -> GasM b i () - gasSerializePactValue = \case - PLiteral l -> gasSerializeLiteral l - PList vs -> do - traverse_ gasSerializePactValue vs - PGuard g -> do - gasSerializeGuard g - PModRef modRef -> gasModRef modRef - PObject o -> do - chargeGasMString $ Text.concat $ _field <$> Map.keys o - traverse_ gasSerializePactValue o - PCapToken (CapToken name args) -> do - chargeGasMString (renderText name) - traverse_ gasSerializePactValue args - PTime _ -> do - SerializationCosts { timeCostMilliGas } <- view (_1 . geGasModel . gmSerialize) - chargeGasMSerialize $ MilliGas timeCostMilliGas - - gasSerializeLiteral l = do - SerializationCosts { - boolMilliGasCost, - unitMilliGasCost, - integerCostMilliGasPerDigit, - decimalCostMilliGasOffset, - decimalCostMilliGasPerDigit} <- view (_1 . geGasModel . gmSerialize) - case l of - LString s -> - -- See the analysis in `Bench.hs` - `pact-string-2` for details. - chargeGasMString s - LInteger i -> - -- See the analysis in `Bench.hs` - `pact-ineger-2` for details. - chargeGasMSerialize $ MilliGas $ integerCostMilliGasPerDigit * fromIntegral (I# (IntLog.integerLogBase# 10 (abs i))) - LDecimal d -> - chargeGasMSerialize $ MilliGas $ decimalCostMilliGasOffset + decimalCostMilliGasPerDigit * fromIntegral (I# (IntLog.integerLogBase# 10 (decimalMantissa d))) - LBool _ -> chargeGasMSerialize $ MilliGas boolMilliGasCost - LUnit -> chargeGasMSerialize $ MilliGas unitMilliGasCost - - gasSerializeGuard = \case - - GKeyset keyset -> gasSerializeKeySet keyset - GKeySetRef keysetName -> chargeGasMString (renderText keysetName) - GUserGuard (UserGuard name term) -> do - chargeGasMString (renderText name) - traverse_ gasSerializePactValue term - GCapabilityGuard (CapabilityGuard name args defpactId) -> do - chargeGasMString (renderText name) - traverse_ gasSerializePactValue args - traverse_ (chargeGasMString . renderText) defpactId - GModuleGuard (ModuleGuard moduleName guardName) -> do - chargeGasMString (renderText moduleName) - chargeGasMString (renderText guardName) - GDefPactGuard (DefPactGuard defpactId name) -> do - chargeGasMString (renderText defpactId) - chargeGasMString (renderText name) - - gasSerializeKeySet :: KeySet -> GasM b i () - gasSerializeKeySet (KeySet keys pred') = do - -- See the analysis in `Bench.hs` - `pact-keyset-2` for details. - chargeGasMString (renderText pred') - traverse_ (chargeGasMString . renderText) keys - - gasModRef :: ModRef -> GasM b i () - gasModRef (ModRef name implemented) = do - chargeGasMString (renderText name) - traverse_ (chargeGasMString . renderText) implemented - - chargeGasMString :: Text.Text -> GasM b i () - chargeGasMString str = do - SerializationCosts { - objectKeyCostMilliGasOffset, - objectKeyCostMilliGasPer1000Chars - } <- view (_1 . geGasModel . gmSerialize) - chargeGasMSerialize $ MilliGas $ objectKeyCostMilliGasOffset + objectKeyCostMilliGasPer1000Chars * fromIntegral (Text.length str) `div` 1000 - decodeRowData :: ByteString -> Maybe RowData decodeRowData bs = either (const Nothing) (Just . snd) (deserialiseFromBytes decodeS (fromStrict bs)) diff --git a/pact/Pact/Core/SizeOf.hs b/pact/Pact/Core/SizeOf.hs index 6642659eb..5f6eeb6b1 100644 --- a/pact/Pact/Core/SizeOf.hs +++ b/pact/Pact/Core/SizeOf.hs @@ -13,6 +13,8 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -- | -- Module : Pact.Types.SizeOf @@ -22,12 +24,11 @@ -- module Pact.Core.SizeOf - ( SizeOf(..) - , SizeOf1(..) + ( sizeOf , Bytes , wordSize , SizeOfVersion(..) - + , SizeOf(..) -- * SizeOf , countBytes @@ -41,6 +42,13 @@ import Pact.Time import Data.Vector (Vector) import Data.Word (Word8, Word64) import GHC.Int(Int(..)) +import Control.Monad.ST +import Control.Monad.Reader hiding (lift) +import Control.Monad.Except +import Data.Foldable +import Control.Monad.Trans(lift) +import Data.STRef +import Data.IORef import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HS import qualified Data.List.NonEmpty as NE @@ -57,7 +65,7 @@ import Pact.Core.Hash import Pact.Core.IR.Term import Pact.Core.Capabilities import Pact.Core.Type -import Pact.Core.Environment.Types +import Pact.Core.Environment import Pact.Core.Builtin import Pact.Core.Literal import Pact.Core.PactValue @@ -68,6 +76,7 @@ import Pact.Core.Imports import Pact.Core.Info import Pact.Core.ModRefs import Pact.Core.Namespace +import Pact.Core.SizeOf.Deriving import Pact.Core.Gas import Control.Monad @@ -78,16 +87,7 @@ import Control.Monad -- We do not charge 1 word per field for estimating the in-memory size anymore. This is because this ends up -- Costing the user a factor of 10 larger than the actual bytes needed to represent the structure in -- --- Assumptions: GHC, 64-bit machine --- General approach: --- Memory Consumption = Constructor Header Size + Cost of Constructor Field(s) --- Cost of Constructor Field(s)* = 1 word per field + cost of each field's value --- (*) See Resource 2 for exceptions to these rules (i.e. newtypes are free) --- Resources: --- 1. http://wiki.haskell.org/GHC/Memory_Footprint --- 2. https://stackoverflow.com/questions/3254758/memory-footprint-of-haskell-data-types - --- | Size estimates determine the gas cost of various operations, +-- Size estimates determine the gas cost of various operations, -- (e.g., writing data to a user table or loading a module), so -- we must version the estimation process in order to allow us to -- update our estimates without breaking compatibility. @@ -104,15 +104,74 @@ data SizeOfVersion instance Pretty SizeOfVersion where pretty = viaShow -type Bytes = Word64 +type Bytes = SatWord + +{-# INLINABLE sizeOf #-} + +data SizeOfEnv s + = SizeOfEnv + { _szLimit :: !SatWord + , _szVer :: !SizeOfVersion + , _szCountRef :: !(STRef s SatWord) + } deriving (Eq) + +newtype ByteLimitExceeded + = ByteLimitExceeded SatWord + deriving (Eq, Show) + +newtype SizeOfM s a + = SizeOfM (ReaderT (SizeOfEnv s) (ExceptT ByteLimitExceeded (ST s)) a) + deriving (Functor, Applicative, Monad, MonadReader (SizeOfEnv s), MonadError ByteLimitExceeded) + +sizeOf :: SizeOf a => i -> SizeOfVersion -> a -> EvalM e b i Bytes +sizeOf info ver v = do + genv <- viewEvalEnv eeGasEnv + let milliGasPerByte = _gcSizeOfBytePenalty $ _gmGasCostConfig (_geGasModel genv) + MilliGas currGas <- liftIO (readIORef (_geGasRef genv)) + let byteLimit = case _gmGasLimit (_geGasModel genv) of + Nothing -> maxBound + Just (MilliGasLimit (MilliGas limit)) -> + (limit - currGas) `div` milliGasPerByte + let byteAmt = runST $ do + r <- newSTRef 0 + let env = SizeOfEnv byteLimit ver r + let (SizeOfM e) = estimateSize v + runExceptT (runReaderT e env) >>= \case + Left ble -> pure (Left ble) + _ -> Right <$> readSTRef r + case byteAmt of + Right b -> pure b + Left (ByteLimitExceeded blim) -> do + -- Note: this will raise a gas limit exceeded + chargeGasArgs info (GAConstant (MilliGas (blim * milliGasPerByte))) + pure blim + + +-- | Count bytes up to a limit. +-- NOTE: do not change the name of this function without fixing `SizeOf.Deriving.hs` +countBytes :: SatWord -> SizeOfM s () +countBytes bytes = do + SizeOfEnv lim _ ref <- ask + !currCount <- SizeOfM ((lift . lift) (readSTRef ref)) + let !newTotal = bytes + currCount + SizeOfM ((lift . lift) (writeSTRef ref newTotal)) + when (newTotal > lim) $ throwError (ByteLimitExceeded newTotal) + +-- | For a small data type (that is, < 24 fields), there's only a need for a 1-byte +-- Overhead, since it is represented as a list of items, with `n < 24` elements. +-- +-- _most data types_ qualify as this. +-- NOTE: do not change the name of this function without fixing `SizeOf.Deriving.hs` +addSmallTagOverhead :: SizeOfM s () +addSmallTagOverhead = countBytes tagOverhead -countBytes :: i -> Bytes -> EvalM e b i Bytes -countBytes i bytes = do - chargeGasArgs i GCountBytes - pure bytes +-- | Most algebraic data types take up 1 small tag tag + 1 byte for their word tag +-- NOTE: do not change the name of this function without fixing `SizeOf.Deriving.hs` +adtTagOverhead :: SizeOfM s () +adtTagOverhead = countBytes (tagOverhead + 1) class SizeOf t where - sizeOf :: forall e b i. i -> SizeOfVersion -> t -> EvalM e b i Bytes + estimateSize :: t -> SizeOfM s () -- | "word" is 8 bytes on 64-bit wordSize64, wordSize :: Bytes @@ -124,153 +183,115 @@ tagOverhead :: Bytes tagOverhead = 1 -cborArraySize :: (Foldable f, SizeOf a) => i -> SizeOfVersion -> f a -> EvalM e b i Bytes -cborArraySize i ver v = do +cborArraySize :: (Foldable f, SizeOf a) => f a -> SizeOfM s () +cborArraySize v = do -- CBOR size overhead for arrays: -- 1 byte for type tag (3 bits major type array, 5 bits for variable length) -- 4 bytes for length (this is actually a MAJOR overshoot, but this is fine) let arrayOverhead = 5 - !elementSizes <- foldM (\count e -> (+ count) <$> sizeOf i ver e) 0 v - countBytes i $ arrayOverhead + elementSizes + countBytes arrayOverhead + traverse_ estimateSize v {-# INLINE cborArraySize #-} instance (SizeOf v) => SizeOf (Vector v) where - sizeOf i ver v = cborArraySize i ver v + estimateSize v = cborArraySize v instance (SizeOf a) => SizeOf (Set a) where - sizeOf i ver s = cborArraySize i ver s + estimateSize v = cborArraySize v instance (SizeOf k, SizeOf v) => SizeOf (M.Map k v) where - sizeOf i ver m = cborArraySize i ver (M.toList m) + estimateSize m = cborArraySize (M.toList m) instance (SizeOf a, SizeOf b) => SizeOf (a,b) where - sizeOf i ver (a,b) = do - -- A tuple is essentially an array but with a fixed length of 2 - aBytes <- sizeOf i ver a - bBytes <- sizeOf i ver b - pure $ tagOverhead + aBytes + bBytes - -instance (SizeOf a) => SizeOf (Maybe a) where - sizeOf i ver e = cborArraySize i ver e + estimateSize (a, b) = do + addSmallTagOverhead + estimateSize a + estimateSize b instance (SizeOf a) => SizeOf [a] where - sizeOf i ver arr = cborArraySize i ver arr + estimateSize arr = cborArraySize arr instance SizeOf BS.ByteString where - sizeOf i _ver bs = - countBytes i (fromIntegral (BS.length bs) + 4) -- We're going to use an array size overhead of 4 here + estimateSize bs = + countBytes (fromIntegral (BS.length bs) + 4) -- We're going to use an array size overhead of 4 here instance SizeOf SBS.ShortByteString where - sizeOf i ver = sizeOf i ver . SBS.fromShort + estimateSize = estimateSize . SBS.fromShort instance SizeOf Text where - sizeOf i _ver t = + estimateSize t = -- We will - countBytes i $ fromIntegral (TU.lengthWord8 t + 4) + countBytes $ fromIntegral (TU.lengthWord8 t + 4) instance SizeOf Integer where - sizeOf i _ e = countBytes i $ + estimateSize e = countBytes $ fromIntegral (max 64 (I# (IntLog.integerLog2# (abs e)) + 1)) `quot` 8 -- And int fits in 4 bytes instance SizeOf Int where - sizeOf i _ver _ = countBytes i (tagOverhead + 4) + estimateSize _ = countBytes (tagOverhead + 4) -- Word 8 = 1 byte, so the tag overhead is enough instance SizeOf Word8 where - sizeOf i _ver _ = countBytes i tagOverhead - -instance (SizeOf i) => SizeOf (DecimalRaw i) where - sizeOf i ver (Decimal p m) = do - pSize <- sizeOf i ver p - mSize <- sizeOf i ver m - countBytes i $ tagOverhead + pSize + mSize + estimateSize _ = countBytes tagOverhead instance SizeOf Int64 where - sizeOf i _ver _ = countBytes i (tagOverhead + wordSize) + estimateSize _ = countBytes (tagOverhead + wordSize) instance SizeOf Word64 where - sizeOf i _ver _ = countBytes i (tagOverhead + wordSize) + estimateSize _ = countBytes (tagOverhead + wordSize) instance SizeOf UTCTime where -- newtype is free -- Internally 'UTCTime' is just a 64-bit integer - sizeOf i _ver _ = - countBytes i wordSize + estimateSize _ = + countBytes wordSize -- Note: a bool takes up 1 byte of space, so the tagoverhead is enough instance SizeOf Bool where -- Note: this probably overestimates - sizeOf i _ver _ = countBytes i tagOverhead + estimateSize _ = countBytes tagOverhead instance SizeOf () where - sizeOf :: i -> SizeOfVersion -> () -> EvalM e b i Bytes - sizeOf _ _ _ = pure 0 + estimateSize _ = pure () -- We can assume the amount it takes to represent this in memory -- is something along the lines of -- - 1 word per the number of elements -- - instance (SizeOf k, SizeOf v) => SizeOf (HM.HashMap k v) where - sizeOf i ver m = cborArraySize i ver (HM.toList m) + estimateSize m = cborArraySize (HM.toList m) -- Note: Atm hashset is only a newtype wrapper over hashmap with unit as the element -- member of every entry. This means you don't pay at all for the cost of (), -- but you do pay for the extra constructor field of holding it, hence the `hsSize` bit -- stays roughly the same. instance (SizeOf k) => SizeOf (HS.HashSet k) where - sizeOf i ver hs = cborArraySize i ver (HS.toList hs) + estimateSize hs = cborArraySize (HS.toList hs) -instance (SizeOf a, SizeOf b) => SizeOf (Either a b) where - sizeOf i ver = fmap (+ tagOverhead) . \case - Left e -> sizeOf i ver e - Right r -> sizeOf i ver r - {-# INLINE sizeOf #-} instance (SizeOf a) => SizeOf (NE.NonEmpty a) where - sizeOf i ver e = cborArraySize i ver e - - -class SizeOf1 f where - sizeOf1 :: SizeOf a => SizeOfVersion -> f a -> Bytes + estimateSize e = cborArraySize e ---- Pact-core instances --- Putting some of the more annoying GADTs here -instance SizeOf (FQNameRef name) where - sizeOf i ver c = do - tailBytes <- case c of - FQParsed n -> sizeOf i ver n - FQName fqn -> sizeOf i ver fqn - pure $ tagOverhead + tailBytes - -instance SizeOf (TableSchema name) where - sizeOf i ver c = do - tailBytes <- case c of - DesugaredTable n -> sizeOf i ver n - ResolvedTable fqn -> sizeOf i ver fqn - pure $ tagOverhead + tailBytes - -instance SizeOf Literal where - sizeOf i ver literal = do - -- Overhead of a tag + word - (tagOverhead +) <$> case literal of - LString s -> sizeOf i ver s - LInteger i' -> sizeOf i ver i' - LDecimal d -> sizeOf i ver d - LBool b -> sizeOf i ver b - LUnit -> countBytes i tagOverhead +------------------------------------------------------------------------------ +-- SizeOf instances +------------------------------------------------------------------------------ +makeSizeOf ''Either +makeSizeOf ''Maybe +makeSizeOf ''DecimalRaw +makeSizeOf ''Literal instance SizeOf LineInfo where - sizeOf i ver (LineInfo li) = sizeOf i ver li - {-# INLINE sizeOf #-} + estimateSize (LineInfo li) = estimateSize li + {-# INLINE estimateSize #-} -- | Note: we will _not_ charge for the size of the module instance SizeOf ModuleCode where - sizeOf i ver (ModuleCode m) - | T.null m = pure 0 - | otherwise = sizeOf i ver m + estimateSize (ModuleCode m) + | T.null m = pure () + | otherwise = estimateSize m deriving newtype instance SizeOf Hash deriving newtype instance SizeOf Field @@ -278,498 +299,98 @@ deriving newtype instance SizeOf NamespaceName deriving newtype instance SizeOf BareName deriving newtype instance SizeOf ModuleHash -instance SizeOf ModuleName where - sizeOf i ver (ModuleName mn nsn) = do - szm <- sizeOf i ver mn - szn <- sizeOf i ver nsn - pure (tagOverhead + szm + szn) - -instance SizeOf DynamicRef where - sizeOf i ver (DynamicRef a b) = do - szm <- sizeOf i ver a - szn <- sizeOf i ver b - pure (tagOverhead + szm + szn) - -instance SizeOf NameKind where - sizeOf i ver nk = do - namesz <- case nk of - NBound b -> sizeOf i ver b - NTopLevel mn mh -> (+) <$> sizeOf i ver mn <*> sizeOf i ver mh - NModRef mn mns -> (+) <$> sizeOf i ver mn <*> sizeOf i ver mns - NDynRef dr -> sizeOf i ver dr - pure $ tagOverhead + namesz - - -instance SizeOf Name where - sizeOf i ver (Name a b) = do - szm <- sizeOf i ver a - szn <- sizeOf i ver b - pure (tagOverhead + szm + szn) - - -instance SizeOf QualifiedName where - sizeOf i ver (QualifiedName a b) = do - szm <- sizeOf i ver a - szn <- sizeOf i ver b - pure (tagOverhead + szm + szn) - -instance SizeOf DynamicName where - sizeOf i ver (DynamicName a b) = do - szm <- sizeOf i ver a - szn <- sizeOf i ver b - pure (tagOverhead + szm + szn) - -instance SizeOf ParsedName where - sizeOf i ver pn = do - namesz <- case pn of - BN b -> sizeOf i ver b - QN n -> sizeOf i ver n - DN n -> sizeOf i ver n - pure $ tagOverhead + namesz - -instance SizeOf ParsedTyName where - sizeOf i ver pn = do - namesz <- case pn of - TBN b -> sizeOf i ver b - TQN n -> sizeOf i ver n - pure $ tagOverhead + namesz - - -instance SizeOf FullyQualifiedName where - sizeOf i ver (FullyQualifiedName a b c) = do - szm <- sizeOf i ver a - szn <- sizeOf i ver b - szc <- sizeOf i ver c - pure (tagOverhead + szm + szn + szc) +makeSizeOf ''ModuleName +makeSizeOf ''QualifiedName +makeSizeOf ''DynamicName +makeSizeOf ''DynamicRef +makeSizeOf ''ParsedName +makeSizeOf ''ParsedTyName +makeSizeOf ''FullyQualifiedName +makeSizeOf ''NameKind +makeSizeOf ''Name -- Prim types are at most 2 bytes instance SizeOf PrimType where - sizeOf i _ver _ = countBytes i tagOverhead - -instance SizeOf Schema where - sizeOf i ver (Schema a b) = do - szm <- sizeOf i ver a - szn <- sizeOf i ver b - pure (tagOverhead + szm + szn) - -instance SizeOf Type where - sizeOf i ver ty = do - namesz <- case ty of - TyPrim p -> sizeOf i ver p - TyList t -> sizeOf i ver t - TyAnyList -> pure tagOverhead - TyModRef mrs -> sizeOf i ver mrs - TyObject sc -> sizeOf i ver sc - TyAnyObject -> pure tagOverhead - TyTable sc -> sizeOf i ver sc - TyCapToken -> pure tagOverhead - TyAny -> pure tagOverhead - pure $ tagOverhead + namesz + estimateSize _ = countBytes tagOverhead + +-- These are mutually recursive +$(concat <$> traverse makeSizeOf [''Schema, ''Type]) --- defpacts deriving newtype instance SizeOf DefPactId +deriving newtype instance SizeOf ChainId -instance (SizeOf n, SizeOf v) => SizeOf (DefPactContinuation n v) where - sizeOf i ver (DefPactContinuation a b) = do - szm <- sizeOf i ver a - szn <- sizeOf i ver b - pure (tagOverhead + szm + szn) +--- Note: SizeOf deriving does not support GADTs +instance SizeOf (FQNameRef name) where + estimateSize c = do + adtTagOverhead + case c of + FQParsed n -> estimateSize n + FQName fqn -> estimateSize fqn -deriving newtype instance SizeOf ChainId -instance SizeOf Provenance where - sizeOf i ver (Provenance a b) = do - szm <- sizeOf i ver a - szn <- sizeOf i ver b - pure (tagOverhead + szm + szn) -instance SizeOf Yield where - sizeOf i ver (Yield a b c) = do - szm <- sizeOf i ver a - szn <- sizeOf i ver b - szc <- sizeOf i ver c - pure (tagOverhead + szm + szn + szc) - -instance SizeOf DefPactExec where - sizeOf i ver (DefPactExec a b c d e f g) = do - sza <- sizeOf i ver a - szb <- sizeOf i ver b - szc <- sizeOf i ver c - szd <- sizeOf i ver d - sze <- sizeOf i ver e - szf <- sizeOf i ver f - szg <- sizeOf i ver g - pure (tagOverhead + sza + szb + szc + szd + sze + szf + szg) - --- spaninfo -instance SizeOf SpanInfo where - sizeOf i ver (SpanInfo a b c d) = do - szm <- sizeOf i ver a - szn <- sizeOf i ver b - szc <- sizeOf i ver c - szd <- sizeOf i ver d - pure (tagOverhead + szm + szn + szc + szd) +--- Note: SizeOf deriving does not support GADTs +instance SizeOf (TableSchema name) where + estimateSize c = do + adtTagOverhead + case c of + DesugaredTable n -> estimateSize n + ResolvedTable fqn -> estimateSize fqn --- builtins -instance SizeOf CoreBuiltin where - sizeOf _i _ver _ = pure (tagOverhead + 1) - {-# INLINE sizeOf #-} -instance SizeOf ReplOnlyBuiltin where - sizeOf _i _ver _ = pure (tagOverhead + 1) +-- defpacts -instance SizeOf b => SizeOf (ReplBuiltin b) where - sizeOf i ver = fmap (+ tagOverhead) . \case - RBuiltinWrap b -> sizeOf i ver b - RBuiltinRepl r -> sizeOf i ver r +makeSizeOf ''SpanInfo +-- builtins +instance SizeOf CoreBuiltin where + estimateSize _ = countBytes (tagOverhead + 1) + {-# INLINE estimateSize #-} + +instance SizeOf ReplOnlyBuiltin where + estimateSize _ = countBytes (tagOverhead + 1) --- Import -instance SizeOf Import where - sizeOf i ver (Import a b c) = do - szm <- sizeOf i ver a - szn <- sizeOf i ver b - szc <- sizeOf i ver c - pure (tagOverhead + szm + szn + szc) +makeSizeOf ''ReplBuiltin +makeSizeOf ''Import -- guards deriving newtype instance SizeOf PublicKeyText -instance SizeOf KeySetName where - sizeOf i ver (KeySetName a b) = do - szm <- sizeOf i ver a - szn <- sizeOf i ver b - pure (tagOverhead + szm + szn) - -instance (SizeOf name, SizeOf v) => SizeOf (UserGuard name v) where - sizeOf i ver (UserGuard a b) = do - szm <- sizeOf i ver a - szn <- sizeOf i ver b - pure (tagOverhead + szm + szn) - -instance (SizeOf name, SizeOf v) => SizeOf (CapabilityGuard name v) where - sizeOf i ver (CapabilityGuard a b c) = do - szm <- sizeOf i ver a - szn <- sizeOf i ver b - szc <- sizeOf i ver c - pure (tagOverhead + szm + szn + szc) - -instance SizeOf KSPredicate where - sizeOf i ver = \case - CustomPredicate pn -> sizeOf i ver pn - _ -> pure (tagOverhead + 1) - -instance SizeOf KeySet where - sizeOf i ver (KeySet a b) = do - szm <- sizeOf i ver a - szn <- sizeOf i ver b - pure (tagOverhead + szm + szn) - -instance SizeOf ModuleGuard where - sizeOf i ver (ModuleGuard a b) = do - szm <- sizeOf i ver a - szn <- sizeOf i ver b - pure (tagOverhead + szm + szn) - -instance SizeOf DefPactGuard where - sizeOf i ver (DefPactGuard a b) = do - szm <- sizeOf i ver a - szn <- sizeOf i ver b - pure (tagOverhead + szm + szn) - -instance (SizeOf name, SizeOf v) => SizeOf (Guard name v) where - sizeOf i ver = fmap (+ tagOverhead) . \case - GKeyset d -> sizeOf i ver d - GKeySetRef d -> sizeOf i ver d - GUserGuard d -> sizeOf i ver d - GCapabilityGuard d -> sizeOf i ver d - GDefPactGuard d -> sizeOf i ver d - GModuleGuard d -> sizeOf i ver d - --- Caps -instance (SizeOf name, SizeOf v) => SizeOf (CapToken name v) where - sizeOf i ver (CapToken a b) = do - szm <- sizeOf i ver a - szn <- sizeOf i ver b - pure (tagOverhead + szm + szn) - -instance SizeOf n => SizeOf (DefManagedMeta n) where - sizeOf i ver = fmap (+ tagOverhead) . \case - DefManagedMeta a b -> do - szm <- sizeOf i ver a - szn <- sizeOf i ver b - pure (tagOverhead + szm + szn) - AutoManagedMeta -> pure tagOverhead - -instance SizeOf n => SizeOf (DefCapMeta n) where - sizeOf i ver = fmap (+ tagOverhead) . \case - DefEvent -> pure tagOverhead - DefManaged dm -> sizeOf i ver dm - Unmanaged -> pure tagOverhead - -instance SizeOf (Governance n) where - sizeOf i ver = fmap (+ tagOverhead) . \case - KeyGov kg -> sizeOf i ver kg - CapGov cg -> sizeOf i ver cg - -instance SizeOf ModRef where - sizeOf i ver (ModRef a b) = do - szm <- sizeOf i ver a - szn <- sizeOf i ver b - pure (tagOverhead + szm + szn) - - -instance SizeOf PactValue where - sizeOf i ver pactValue = fmap (+ tagOverhead) $ case pactValue of - PLiteral l -> sizeOf i ver l - PObject obj -> sizeOf i ver obj - PList l -> sizeOf i ver l - PGuard g -> sizeOf i ver g - PModRef m -> sizeOf i ver m - PCapToken t -> sizeOf i ver t - PTime t -> sizeOf i ver t - --- Modules and interfaces -instance (SizeOf ty, SizeOf i) => SizeOf (Arg ty i) where - sizeOf i ver (Arg a b c) = do - szm <- sizeOf i ver a - szn <- sizeOf i ver b - szc <- sizeOf i ver c - pure (tagOverhead + szm + szn + szc) - -instance (SizeOf e) => SizeOf (BuiltinForm e) where - sizeOf i ver = \case - CAnd a b -> do - sza <- sizeOf i ver a - szb <- sizeOf i ver b - pure (tagOverhead + sza + szb) - - COr a b -> do - sza <- sizeOf i ver a - szb <- sizeOf i ver b - pure (tagOverhead + sza + szb) - - CIf a b c -> do - sza <- sizeOf i ver a - szb <- sizeOf i ver b - szc <- sizeOf i ver c - pure (tagOverhead + sza + szb + szc) - - CEnforce a b -> do - sza <- sizeOf i ver a - szb <- sizeOf i ver b - pure (tagOverhead + sza + szb) - - CWithCapability a b -> do - sza <- sizeOf i ver a - szb <- sizeOf i ver b - pure (tagOverhead + sza + szb) - - CCreateUserGuard a -> sizeOf i ver a - - CEnforceOne a b -> do - sza <- sizeOf i ver a - szb <- sizeOf i ver b - pure (tagOverhead + sza + szb) - - CTry a b -> do - sza <- sizeOf i ver a - szb <- sizeOf i ver b - pure (tagOverhead + sza + szb) - -instance (SizeOf n, SizeOf t, SizeOf b, SizeOf i) => SizeOf (Term n t b i) where - sizeOf i ver = \case - Var a b -> do - sza <- sizeOf i ver a - szb <- sizeOf i ver b - pure (tagOverhead + sza + szb) - Lam a b c -> do - sza <- sizeOf i ver a - szb <- sizeOf i ver b - szc <- sizeOf i ver c - pure (tagOverhead + sza + szb + szc) - Let a b c d -> do - sza <- sizeOf i ver a - szb <- sizeOf i ver b - szc <- sizeOf i ver c - szd <- sizeOf i ver d - pure (tagOverhead + sza + szb + szc + szd) - App a b c -> do - sza <- sizeOf i ver a - szb <- sizeOf i ver b - szc <- sizeOf i ver c - pure (tagOverhead + sza + szb + szc) - BuiltinForm a b -> do - sza <- sizeOf i ver a - szb <- sizeOf i ver b - pure (tagOverhead + sza + szb) - Constant a b -> do - sza <- sizeOf i ver a - szb <- sizeOf i ver b - pure (tagOverhead + sza + szb) - Builtin a b -> do - sza <- sizeOf i ver a - szb <- sizeOf i ver b - pure (tagOverhead + sza + szb) - Sequence a b c -> do - sza <- sizeOf i ver a - szb <- sizeOf i ver b - szc <- sizeOf i ver c - pure (tagOverhead + sza + szb + szc) - Nullary a b -> do - sza <- sizeOf i ver a - szb <- sizeOf i ver b - pure (tagOverhead + sza + szb) - ListLit a b -> do - sza <- sizeOf i ver a - szb <- sizeOf i ver b - pure (tagOverhead + sza + szb) - ObjectLit a b -> do - sza <- sizeOf i ver a - szb <- sizeOf i ver b - pure (tagOverhead + sza + szb) - InlineValue a b -> do - sza <- sizeOf i ver a - szb <- sizeOf i ver b - pure (tagOverhead + sza + szb) - -instance (SizeOf n, SizeOf t, SizeOf b, SizeOf i) => SizeOf (Defun n t b i) where - sizeOf i ver (Defun a b c d) = do - sza <- sizeOf i ver a - szb <- sizeOf i ver b - szc <- sizeOf i ver c - szd <- sizeOf i ver d - pure (tagOverhead + sza + szb + szc + szd) - -instance (SizeOf term) => SizeOf (ConstVal term) where - sizeOf i ver = fmap (+ tagOverhead) . \case - EvaledConst cv -> sizeOf i ver cv - TermConst cv -> sizeOf i ver cv - -instance (SizeOf n, SizeOf t, SizeOf b, SizeOf i) => SizeOf (DefConst n t b i) where - sizeOf i ver (DefConst a b c) = do - sza <- sizeOf i ver a - szb <- sizeOf i ver b - szc <- sizeOf i ver c - pure (tagOverhead + sza + szb + szc) - -instance (SizeOf n, SizeOf t, SizeOf b, SizeOf i) => SizeOf (DefCap n t b i) where - sizeOf i ver (DefCap a b c d e) = do - sza <- sizeOf i ver a - szb <- sizeOf i ver b - szc <- sizeOf i ver c - szd <- sizeOf i ver d - sze <- sizeOf i ver e - pure (tagOverhead + sza + szb + szc + szd + sze) - -instance (SizeOf n, SizeOf t, SizeOf b, SizeOf i) => SizeOf (Step n t b i) where - sizeOf i ver = fmap (+ tagOverhead) . \case - Step term -> sizeOf i ver term - StepWithRollback a b -> do - sza <- sizeOf i ver a - szb <- sizeOf i ver b - pure (sza + szb) - -instance (SizeOf n, SizeOf t, SizeOf b, SizeOf i) => SizeOf (DefPact n t b i) where - sizeOf i ver (DefPact a b c d) = do - sza <- sizeOf i ver a - szb <- sizeOf i ver b - szc <- sizeOf i ver c - szd <- sizeOf i ver d - pure (tagOverhead + sza + szb + szc + szd) - -instance (SizeOf t, SizeOf i) => SizeOf (DefSchema t i) where - sizeOf i ver (DefSchema a b c) = do - sza <- sizeOf i ver a - szb <- sizeOf i ver b - szc <- sizeOf i ver c - pure (tagOverhead + sza + szb + szc) - -instance (SizeOf i) => SizeOf (DefTable n i) where - sizeOf i ver (DefTable a b c) = do - sza <- sizeOf i ver a - szb <- sizeOf i ver b - szc <- sizeOf i ver c - pure (tagOverhead + sza + szb + szc) - -instance (SizeOf n, SizeOf t, SizeOf b, SizeOf i) => SizeOf (Def n t b i) where - sizeOf i ver = fmap (+ tagOverhead) . \case - Dfun d -> sizeOf i ver d - DConst d -> sizeOf i ver d - DCap d -> sizeOf i ver d - DPact d -> sizeOf i ver d - DSchema d -> sizeOf i ver d - DTable d -> sizeOf i ver d - -instance (SizeOf n, SizeOf t, SizeOf b, SizeOf i) => SizeOf (Module n t b i) where - sizeOf i ver (Module a b c d e f g h i' j) = do - sza <- sizeOf i ver a - szb <- sizeOf i ver b - szc <- sizeOf i ver c - szd <- sizeOf i ver d - sze <- sizeOf i ver e - szf <- sizeOf i ver f - szg <- sizeOf i ver g - szh <- sizeOf i ver h - szi' <- sizeOf i ver i' - szj <- sizeOf i ver j - pure (tagOverhead + sza + szb + szc + szd + sze + szf + szg + szh + szi' + szj) - -instance (SizeOf t, SizeOf i) => SizeOf (IfDefun t i) where - sizeOf i ver (IfDefun a b c) = do - sza <- sizeOf i ver a - szb <- sizeOf i ver b - szc <- sizeOf i ver c - pure (tagOverhead + sza + szb + szc) - -instance (SizeOf t, SizeOf i) => SizeOf (IfDefPact t i) where - sizeOf i ver (IfDefPact a b c) = do - sza <- sizeOf i ver a - szb <- sizeOf i ver b - szc <- sizeOf i ver c - pure (tagOverhead + sza + szb + szc) - -instance (SizeOf t, SizeOf i) => SizeOf (IfDefCap n t i) where - sizeOf i ver (IfDefCap a b c d) = do - sza <- sizeOf i ver a - szb <- sizeOf i ver b - szc <- sizeOf i ver c - szd <- sizeOf i ver d - pure (tagOverhead + sza + szb + szc + szd) - -instance (SizeOf n, SizeOf t, SizeOf b, SizeOf i) => SizeOf (IfDef n t b i) where - sizeOf i ver = fmap (+ tagOverhead) . \case - IfDfun d -> sizeOf i ver d - IfDCap d -> sizeOf i ver d - IfDConst d -> sizeOf i ver d - IfDSchema d -> sizeOf i ver d - IfDPact d -> sizeOf i ver d - -instance (SizeOf n, SizeOf t, SizeOf b, SizeOf i) => SizeOf (Interface n t b i) where - sizeOf i ver (Interface a b c d e f g) = do - sza <- sizeOf i ver a - szb <- sizeOf i ver b - szc <- sizeOf i ver c - szd <- sizeOf i ver d - sze <- sizeOf i ver e - szf <- sizeOf i ver f - szg <- sizeOf i ver g - pure (tagOverhead + sza + szb + szc + szd + sze + szf + szg) - -instance SizeOf Namespace where - sizeOf i ver (Namespace a b c) = do - sza <- sizeOf i ver a - szb <- sizeOf i ver b - szc <- sizeOf i ver c - pure (tagOverhead + sza + szb + szc) - -instance (SizeOf b, SizeOf i) => SizeOf (ModuleData b i) where - sizeOf i ver = \case - ModuleData a b -> do - sza <- sizeOf i ver a - szb <- sizeOf i ver b - pure (tagOverhead + sza + szb) - InterfaceData a b -> do - sza <- sizeOf i ver a - szb <- sizeOf i ver b - pure (tagOverhead + sza + szb) +makeSizeOf ''KeySetName +makeSizeOf ''UserGuard +makeSizeOf ''CapabilityGuard +makeSizeOf ''KSPredicate +makeSizeOf ''KeySet +makeSizeOf ''ModuleGuard +makeSizeOf ''DefPactGuard +makeSizeOf ''Guard +makeSizeOf ''CapToken +makeSizeOf ''DefManagedMeta +makeSizeOf ''DefCapMeta +makeSizeOf ''Governance +makeSizeOf ''ModRef +makeSizeOf ''PactValue +makeSizeOf ''DefPactContinuation +makeSizeOf ''Provenance +makeSizeOf ''Yield +makeSizeOf ''Arg +makeSizeOf ''BuiltinForm +makeSizeOf ''Term +makeSizeOf ''Defun +makeSizeOf ''ConstVal +makeSizeOf ''DefConst +makeSizeOf ''DefCap +makeSizeOf ''Step +makeSizeOf ''DefPactExec +makeSizeOf ''DefPact +makeSizeOf ''DefSchema +makeSizeOf ''DefTable +makeSizeOf ''Def +makeSizeOf ''Module +makeSizeOf ''IfDefun +makeSizeOf ''IfDefPact +makeSizeOf ''IfDefCap +makeSizeOf ''IfDef +makeSizeOf ''Interface +makeSizeOf ''Namespace +makeSizeOf ''ModuleData diff --git a/pact/Pact/Core/SizeOf/Deriving.hs b/pact/Pact/Core/SizeOf/Deriving.hs new file mode 100644 index 000000000..14727759b --- /dev/null +++ b/pact/Pact/Core/SizeOf/Deriving.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} + +-- | +-- Module : Pact.Core.DeriveConTag +-- Copyright : (C) 2022 Kadena +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Jose Cardona +-- +-- A small module for a a template haskell class which derives constructor +-- names and declaration ordering. +-- + +module Pact.Core.SizeOf.Deriving + ( makeSizeOf + ) where + +#if !MIN_VERSION_base(4,20,0) +import Data.List(foldl') +#endif + +import Data.Word(Word8) +import Control.Monad +import Language.Haskell.TH + +-- | Simple constructor info: Constructor name and constructor +-- index in order of data type declaration + +-- | A simple metadata info typeclass for getting the constructor tag and info for a haskell +-- algebraic data type with simple constructors + +-- | Derive a `HasConstrInfo` instance +makeSizeOf :: Name -> Q [Dec] +makeSizeOf ty = reify ty >>= \case + TyConI (DataD _ctx _n _tvs _k cons _) -> do + when (length cons >= fromIntegral (maxBound :: Word8)) $ + fail "deriveConstrInfo: too many constructors" + -- Create our `SizeOf (f a_1 ... a_n)` signature + let sizeOfName = mkName "SizeOf" + tyVars <- traverse (const (newName "a")) _tvs + let tyCtx = AppT (ConT sizeOfName) . VarT <$> tyVars + let declTy = mkTyApp (ConT ty) (VarT <$> tyVars) + let instTy = mkTyApp (ConT (mkName "SizeOf")) [declTy] + let szClause = FunD (mkName "estimateSize") + let countBytes = mkName "countBytes" + decl <- case cons of + [] -> fail "makeSizeOf not supported for empty data decls" + -- This is for a single constructor, our by-far most common case + [NormalC n bt] -> case bt of + -- No fields, so assume it's just 1 byte + [] -> do + let body = AppE (VarE countBytes) (LitE (IntegerL 1)) + pure $ Clause [WildP] (NormalB body) [] + _ -> do + -- We generate the overhead for + let overhead = VarE (mkName "addSmallTagOverhead") + let vars = fieldNames bt + -- (Ctor f_a f_b ... f_n) + let clausePats = ConP n [] (VarP <$> vars) + -- do + -- addSmallTagOverhead + -- estimateSize f_a + -- estimateSize f_b + -- ... + let body = DoE Nothing (NoBindS overhead : (NoBindS . callEstimateSize . VarE <$> vars)) + pure $ Clause [clausePats] (NormalB body) [] + -- Record ctor, which we support the same as the other case + [RecC n bt] -> case bt of + -- No fields, so assume it's just 1 byte + [] -> do + let body = AppE (VarE countBytes) (LitE (IntegerL 1)) + pure $ Clause [WildP] (NormalB body) [] + _ -> do + -- We generate the overhead for + let overhead = VarE (mkName "addSmallTagOverhead") + let vars = fieldNames bt + -- (Ctor f_a f_b ... f_n) + let clausePats = ConP n [] (VarP <$> vars) + -- do + -- addSmallTagOverhead + -- estimateSize f_a + -- estimateSize f_b + -- ... + let body = DoE Nothing (NoBindS overhead : (NoBindS . callEstimateSize . VarE <$> vars)) + pure $ Clause [clausePats] (NormalB body) [] + -- Case is an adt variant + _ -> do + normalCInfos <- traverse getNormalCInfo cons + variantVar <- newName "x" + let overhead = VarE (mkName "adtTagOverhead") + variants <- traverse (uncurry mkSingleVariantMatch) normalCInfos + let bodyExp = DoE Nothing [NoBindS overhead , NoBindS (CaseE (VarE variantVar) variants)] + pure $ Clause [VarP variantVar] (NormalB bodyExp) [] + pure [InstanceD Nothing tyCtx instTy [szClause [decl]]] + + _ -> fail "Can only derive HasConstrInfo for a Type" + where + callEstimateSize = AppE (VarE (mkName "estimateSize")) + fieldNames = zipWith (\a _ -> mkName ("f_" <> [a])) ['a' .. 'z'] + getNormalCInfo (NormalC n bt) = pure (n, fieldNames bt) + getNormalCInfo _ = fail "makeSizeOf is not supported for infix data constructors, record variants or GADTs" + mkSingleVariantMatch n fields = do + let clausePat = ConP n [] (VarP <$> fields) + body <- case fields of + [] -> pure $ NormalB $ AppE (VarE (mkName "pure")) (TupE []) + _ -> pure $ NormalB $ DoE Nothing (NoBindS . callEstimateSize . VarE <$> fields) + pure $ Match clausePat body [] + + + mkTyApp :: Type -> [Type] -> Type + mkTyApp = + foldl' AppT +