Add static redeploy native

docs/builtins/General/acquire-module-admin.md

@@ -23,8 +23,6 @@ It will attempt to acquire the governance cap and if successful, it will grant m
 
 ### Arguments
 
-Use one of the following argument to define the value you want to retrieve using the `at` Pact function.
-
 | Argument | Type | Description
 | -------- | ---- | -----------
 | `ref` | modref | Specifies the module to acquire administrative capabilities for.

docs/builtins/General/static-redeploy.md

@@ -0,0 +1,39 @@
+## static-redeploy
+
+Use `static-redeploy` to redeploy any module, without _any_ code changes. Roundtripping a legacy module will store the new module in our new, more compact storage format, which will result in less gas on loads.
+
+Note: this leaves governance unchanged.
+
+### Basic syntax
+
+Assume you have some module
+```pact
+(module m g
+  (defcap g () true)
+
+  (defun f () 1)
+
+  (defun gg () 2)
+  )
+```
+
+To redeploy using the new pact-5, call
+
+```pact
+(static-redeploy "m")
+```
+
+### Arguments
+
+
+| Argument | Type | Description
+| -------- | ---- | -----------
+| `module` | string | Specifies the module to redeploy
+
+### Return values
+
+The unit value `()` will be returned if successful.
+
+### Examples
+
+See: Basic Syntax.

gasmodel/Pact/Core/GasModel/BuiltinsGas.hs

@@ -920,6 +920,7 @@ benchesForBuiltin bn = case bn of
   CoreHyperlaneDecodeMessage -> todo
   CoreHyperlaneEncodeMessage -> todo
   CoreHyperlaneMessageId -> todo
+  CoreStaticRedeploy -> omittedDeliberately
   where
   omittedDeliberately = const []
   alreadyCovered = const []

pact-lsp/Pact/Core/LanguageServer.hs

@@ -380,7 +380,7 @@ processFile replEnv nuri source = do
         functionDocs tl
         (ds, deps) <- compileDesugarOnly replEnv tl
         constEvaled <- ConstEval.evalTLConsts replEnv ds
-        let tlFinal = MHash.hashTopLevel constEvaled
+        tlFinal <- MHash.hashTopLevel constEvaled
         let act = M.singleton nuri [ds] <$ evalTopLevel replEnv (RawCode mempty) tlFinal deps
         catchError act (const (pure mempty))
       _ ->  pure mempty

pact-tests/constructor-tag-goldens/CoreBuiltin.golden

@@ -133,4 +133,5 @@
 {"conName":"CoreHyperlaneEncodeMessage","conIndex":"84"}
 {"conName":"CoreReadWithFields","conIndex":"85"}
 {"conName":"CoreListModules","conIndex":"86"}
+{"conName":"CoreStaticRedeploy","conIndex":"87"}
 

pact-tests/gas-goldens/builtinGas.golden

@@ -103,14 +103,15 @@ shift: 1286
 show: 1400
 sort: 1400
 sqrt: 2022
+static-redeploy: 298900
 str-to-int: 708
 str-to-list: 751
 take: 2200
 time: 500
 tx-hash: 200
 typeof-principal: 997
 typeof: 200
-update: 634750
+update: 584750
 validate-principal: 4540
 where: 2340
 with-default-read: 540016

pact-tests/gas-goldens/static-redeploy.repl

@@ -0,0 +1,9 @@
+(module m g
+  (defcap g () true)
+
+  (defun f () 1)
+
+  (defun gg () 2)
+  )
+
+(static-redeploy 'm)

pact-tests/legacy-serial-tests/coin-v5/coin-v5.repl

@@ -396,7 +396,7 @@
 (env-gaslog)
 (expect
   "Gas cost of transfer"
-  235 (env-gas))
+  185 (env-gas))
 
 (expect-failure "emily->doug capability used up"
   "TRANSFER exceeded"
@@ -433,7 +433,7 @@
   (transfer-create 'doug 'will (read-keyset 'will) 1.0))
 (env-gaslog)
 (expect
-  "Gas cost of transfer-create" 221 (env-gas))
+  "Gas cost of transfer-create" 171 (env-gas))
 
 (expect
   "doug now has 0.4 coins"

pact-tests/pact-tests/coin-v1.repl

@@ -395,7 +395,7 @@
 (env-gaslog)
 (expect
   "Gas cost of transfer"
-  235 (env-gas))
+  185 (env-gas))
 
 (expect-failure "emily->doug capability used up"
   "TRANSFER exceeded"
@@ -432,7 +432,7 @@
   (transfer-create 'doug 'will (read-keyset 'will) 1.0))
 (env-gaslog)
 (expect
-  "Gas cost of transfer-create" 218 (env-gas))
+  "Gas cost of transfer-create" 168 (env-gas))
 
 (expect
   "doug now has 0.4 coins"

pact-tests/pact-tests/coin-v5.repl

@@ -26,7 +26,7 @@
 (env-gaslog)
 (expect
   "Gas cost of loading coin contract"
-  20532
+  20539
   (env-gas))
 
 (create-table coin.coin-table)
@@ -407,7 +407,7 @@
 (env-gaslog)
 (expect
   "Gas cost of transfer"
-  235 (env-gas))
+  185 (env-gas))
 
 (expect-failure "emily->doug capability used up"
   "TRANSFER exceeded"
@@ -444,7 +444,7 @@
   (transfer-create 'doug 'will (read-keyset 'will) 1.0))
 (env-gaslog)
 (expect
-  "Gas cost of transfer-create" 221 (env-gas))
+  "Gas cost of transfer-create" 171 (env-gas))
 
 (expect
   "doug now has 0.4 coins"

pact/Pact/Core/Builtin.hs

@@ -236,6 +236,7 @@ data CoreBuiltin
   -- | BackCompat: read with filtering columns
   | CoreReadWithFields
   | CoreListModules
+  | CoreStaticRedeploy
   deriving (Eq, Show, Ord, Bounded, Enum, Generic)
 
 instance NFData CoreBuiltin
@@ -409,6 +410,7 @@ coreBuiltinToText = \case
   CoreHyperlaneEncodeMessage -> "hyperlane-encode-token-message"
   CoreReadWithFields -> "read-with-fields"
   CoreListModules -> "list-modules"
+  CoreStaticRedeploy -> "static-redeploy"
 
 -- | Our `CoreBuiltin` user-facing representation.
 -- note: `coreBuiltinToUserText` is primarily for pretty printing
@@ -560,6 +562,7 @@ coreBuiltinToUserText = \case
   CoreAcquireModuleAdmin -> "acquire-module-admin"
   CoreReadWithFields -> "read"
   CoreListModules -> "list-modules"
+  CoreStaticRedeploy -> "static-redeploy"
 
 instance IsBuiltin CoreBuiltin where
   builtinName = NativeName . coreBuiltinToText
@@ -714,6 +717,7 @@ instance IsBuiltin CoreBuiltin where
     CoreHyperlaneEncodeMessage -> 1
     CoreReadWithFields -> 3
     CoreListModules -> 0
+    CoreStaticRedeploy -> 1
 
 coreBuiltinNames :: [Text]
 coreBuiltinNames =

pact/Pact/Core/Compile.hs

@@ -163,7 +163,7 @@ compileDesugarOnly interpreter tl = do
   debugPrint (DPParser @b) tl
   (DesugarOutput ds deps) <- runDesugarTopLevel tl
   constEvaled <- ConstEval.evalTLConsts interpreter ds
-  let tlFinal = MHash.hashTopLevel constEvaled
+  tlFinal <- MHash.hashTopLevel constEvaled
   debugPrint DPDesugar ds
   pure (tlFinal, deps)
 
@@ -180,7 +180,7 @@ interpretTopLevel interpreter code tl = do
   debugPrint (DPParser @b) tl
   (DesugarOutput ds deps) <- runDesugarTopLevel tl
   constEvaled <- ConstEval.evalTLConsts interpreter ds
-  let tlFinal = MHash.hashTopLevel constEvaled
+  tlFinal <- MHash.hashTopLevel constEvaled
   debugPrint DPDesugar ds
   evalTopLevel interpreter code tlFinal deps
 

pact/Pact/Core/Evaluate.hs

@@ -83,7 +83,7 @@ data EnableGasLogs
   | GasLogsDisabled
   deriving (Eq, Show, Ord)
 
-evalInterpreter :: Interpreter ExecRuntime CoreBuiltin i
+evalInterpreter :: Interpreter ExecRuntime CoreBuiltin Info
 evalInterpreter =
   Interpreter runGuard runTerm resume evalWithCap
   where
@@ -93,10 +93,10 @@ evalInterpreter =
   evalWithCap info purity ct term =
     CEK.evalWithinCap info purity cekEnv ct term
 
-cekEnv :: CEK.BuiltinEnv ExecRuntime CoreBuiltin i
+cekEnv :: CEK.BuiltinEnv ExecRuntime CoreBuiltin Info
 cekEnv = coreBuiltinEnv @ExecRuntime
 
-evalDirectInterpreter :: Interpreter ExecRuntime CoreBuiltin i
+evalDirectInterpreter :: Interpreter ExecRuntime CoreBuiltin Info
 evalDirectInterpreter =
   Interpreter runGuard runTerm resume evalWithCap
   where

pact/Pact/Core/Gas/TableGasModel.hs

@@ -40,7 +40,8 @@ tableGasCostConfig = GasCostConfig
   , _gcPoseidonLinearGasFactor = 38_000
   , _gcModuleLoadSlope = 200
   , _gcModuleLoadIntercept = 10
-  , _gcDesugarBytePenalty = 500
+  , _gcDesugarBytePenalty = 400
+  , _gcMHashBytePenalty = 100
   , _gcSizeOfBytePenalty = 5
   }
 
@@ -386,7 +387,9 @@ runTableModel nativeTable GasCostConfig{..} = \case
       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
-      MilliGas (fromIntegral sz * _gcDesugarBytePenalty)
+      MilliGas (sz * _gcDesugarBytePenalty)
+    MOpHashModule w ->
+      MilliGas $ w * _gcMHashBytePenalty
   GStrOp op -> case op of
     StrOpLength len ->
       let charsPerMg = 100
@@ -626,7 +629,7 @@ coreBuiltinGasCost GasCostConfig{..} = MilliGas . \case
   CoreSelectWithFields ->
     _gcSelectPenalty
   -- Update same gas penalty as write and insert
-  CoreUpdate -> 100_000
+  CoreUpdate -> _gcWritePenalty
   -- note: with-default read and read
   -- should cost the same.
   CoreWithDefaultRead ->
@@ -703,6 +706,7 @@ coreBuiltinGasCost GasCostConfig{..} = MilliGas . \case
   CoreAcquireModuleAdmin -> 20_000
   CoreReadWithFields -> _gcReadPenalty
   CoreListModules -> _gcMetadataTxPenalty
+  CoreStaticRedeploy -> _gcNativeBasicWork
 {-# INLINABLE runTableModel #-}
 
 

pact/Pact/Core/Gas/Types.hs

@@ -162,6 +162,8 @@ data GasCostConfig
   -- ^ Module load cost function Intercept
   , _gcDesugarBytePenalty :: !SatWord
   -- ^ Module load desugaring byte penalty
+  , _gcMHashBytePenalty :: !SatWord
+  -- ^ Module load hashing byte penalty
   , _gcSizeOfBytePenalty :: !SatWord
   -- ^ Our `SizeOf` limit penalty
   } deriving (Eq, Show, Generic)
@@ -327,6 +329,8 @@ data ModuleOp
   -- ^ Cost of adding deps to the symbol table
   | MOpDesugarModule !SatWord -- Size of the tree
   -- ^ the cost of module desugar
+  | MOpHashModule !SatWord -- Size of the tree
+  -- ^ the cost of module desugar
   deriving (Show, Eq, Generic, NFData)
 
 instance Show b => Pretty (GasArgs b) where
@@ -392,6 +396,7 @@ freeGasCostConfig = GasCostConfig
   , _gcFunctionArgumentCost = 1
   -- ^ The flat cost per argument for
   -- function calls. Note: Typechecking is costed separately
+  , _gcMHashBytePenalty = 1
   , _gcMachineTickCost = 1
   -- ^ The flat cost for a state transition in our machine
   , _gcUnconsWork = 1

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

@@ -67,6 +67,7 @@ import Pact.Core.Namespace
 import Pact.Core.Gas
 import Pact.Core.Type
 import Pact.Core.ModRefs
+import Pact.Core.Info
 #ifndef WITHOUT_CRYPTO
 import Pact.Core.Crypto.Pairing
 import Pact.Core.Crypto.Hash.Poseidon
@@ -1986,23 +1987,56 @@ coreListModules info b cont handler env = \case
     returnCEKValue cont handler $ VList $ V.fromList (PString . renderModuleName <$> mns)
   args -> argsError info b args
 
+coreStaticRedeploy :: (IsBuiltin b, SizeOf b, SizeOf i) => NativeFunction e b i
+coreStaticRedeploy info b cont handler env = \case
+  [VString m] -> do
+    enforceTopLevelOnly info b
+    case parseModuleName m of
+      Just mname -> do
+        mdata <- getModuleData info mname
+        let code@(ModuleCode mcode) = moduleDataCode mdata
+        let mdFqn = HashedModuleName mname (view mdModuleHash mdata)
+        -- Write the module code to SYS:ModuleSources
+        -- so we don't break tooling on redeploys, because we definitely won't write it out
+        -- to CBOR
+        if T.null mcode then pure ()
+        else do
+          wtSize <- sizeOf info SizeOfV0 (ModuleCode mcode)
+          chargeGasArgs info (GWrite wtSize)
+          evalWrite info (_cePactDb env) Write DModuleSource mdFqn code
+        msize <- sizeOf info SizeOfV0 mdata
+        chargeGasArgs info (GWrite msize)
+        evalWrite info (_cePactDb env) Write DModules mname mdata
+        -- There is no meaningful return value here
+        returnCEKValue cont handler VUnit
+      Nothing -> throwNativeExecutionError info b $ "invalid module name format"
+  args -> argsError info b args
+  where
+  moduleDataCode = \case
+    ModuleData m _ -> _mCode m
+    InterfaceData iface _ -> _ifCode iface
+
 -----------------------------------
 -- Builtin exports
 -----------------------------------
 
 
 coreBuiltinEnv
-  :: BuiltinEnv e CoreBuiltin i
+  :: forall e i. SizeOf i => BuiltinEnv e CoreBuiltin i
 coreBuiltinEnv i b env = mkBuiltinFn i b env (coreBuiltinRuntime b)
 {-# INLINEABLE coreBuiltinEnv #-}
 
 
 {-# SPECIALIZE coreBuiltinRuntime
    :: CoreBuiltin
-   -> NativeFunction ExecRuntime CoreBuiltin i
+   -> NativeFunction ExecRuntime CoreBuiltin LineInfo
+    #-}
+{-# SPECIALIZE coreBuiltinRuntime
+   :: CoreBuiltin
+   -> NativeFunction ExecRuntime CoreBuiltin SpanInfo
     #-}
 coreBuiltinRuntime
-  :: (IsBuiltin b)
+  :: (IsBuiltin b, SizeOf b, SizeOf i)
   => CoreBuiltin
   -> NativeFunction e b i
 coreBuiltinRuntime = \case
@@ -2143,3 +2177,4 @@ coreBuiltinRuntime = \case
   CoreAcquireModuleAdmin -> coreAcquireModuleAdmin
   CoreReadWithFields -> dbRead
   CoreListModules -> coreListModules
+  CoreStaticRedeploy -> coreStaticRedeploy