Remove old GC code, and adjust GC condition.

IntersectMBO · Dec 15, 2021 · 1fd924d · 1fd924d
1 parent 2b15b91
commit 1fd924d
Show file tree

Hide file tree

Showing 3 changed files with 23 additions and 46 deletions.
diff --git a/plutus-chain-index-core/src/Plutus/ChainIndex/UtxoState.hs b/plutus-chain-index-core/src/Plutus/ChainIndex/UtxoState.hs
@@ -107,11 +107,11 @@ trimIndex ::
   => Integer
   -> UtxoIndex a
   -> UtxoIndex a
-trimIndex 0          ix = Debug.trace ("Trimming index @0") $ ix
+trimIndex 0          ix = ix
 trimIndex kParameter ix =
-    let (lb, rb) = Debug.trace ("Trimming index @" <> show kParameter) $ bounds ix
-    in  if (rb - lb) > kParameter * 2
-        then FT.dropUntil (\(_, uxst) -> rb - blockNumber (view usTip uxst) <= kParameter) ix
+    let (lb, rb) = bounds ix
+    in  if (rb - lb) > kParameter * 10
+        then Debug.trace "Collecting garbage.." $ FT.dropUntil (\(_, uxst) -> rb - blockNumber (view usTip uxst) <= kParameter) ix
         else ix
     where
         bounds :: Monoid a => UtxoIndex a -> (Integer, Integer)

diff --git a/plutus-pab/src/Plutus/PAB/App.hs b/plutus-pab/src/Plutus/PAB/App.hs
@@ -67,8 +67,7 @@ import Plutus.ChainIndex.Client qualified as ChainIndex
 import Plutus.PAB.Core (EffectHandlers (EffectHandlers), PABAction)
 import Plutus.PAB.Core qualified as Core
 import Plutus.PAB.Core.ContractInstance.BlockchainEnv qualified as BlockchainEnv
-import Plutus.PAB.Core.ContractInstance.STM as Instances (BlockchainEnv (beRollbackHistory), InstancesState,
-                                                          emptyInstancesState)
+import Plutus.PAB.Core.ContractInstance.STM as Instances (InstancesState, emptyInstancesState)
 import Plutus.PAB.Db.Beam.ContractStore qualified as BeamEff
 import Plutus.PAB.Db.Memory.ContractStore (InMemInstances, initialInMemInstances)
 import Plutus.PAB.Db.Memory.ContractStore qualified as InMem
@@ -90,8 +89,6 @@ import Wallet.Emulator.Wallet (Wallet)
 import Wallet.Error (WalletAPIError)
 import Wallet.Types (ContractInstanceId)
 
-import Debug.Trace qualified as Debug
-
 ------------------------------------------------------------
 
 -- | Application environment with a contract type `a`.

diff --git a/plutus-pab/src/Plutus/PAB/Core/ContractInstance/BlockchainEnv.hs b/plutus-pab/src/Plutus/PAB/Core/ContractInstance/BlockchainEnv.hs
@@ -8,7 +8,6 @@ module Plutus.PAB.Core.ContractInstance.BlockchainEnv(
   startNodeClient
   , processMockBlock
   , processChainSyncEvent
-  , garbageCollect
   ) where
 
 import Cardano.Api (BlockInMode (..), ChainPoint (..), NetworkId)
@@ -31,15 +30,14 @@ import Control.Concurrent.STM qualified as STM
 import Control.Lens
 import Control.Monad (forM_, void, when)
 import Control.Tracer (nullTracer)
-import Data.Foldable (foldl', traverse_)
+import Data.Foldable (foldl')
 import Data.Maybe (catMaybes)
 import Ledger.TimeSlot (SlotConfig)
-import Plutus.ChainIndex (BlockNumber (..), ChainIndexTx (..), ChainIndexTxOutputs (..), Depth (..),
-                          InsertUtxoFailed (..), InsertUtxoSuccess (..), RollbackFailed (..), RollbackResult (..),
-                          Tip (..), TxConfirmedState (..), TxIdState (..), TxOutBalance, TxValidity (..),
-                          UtxoState (..), blockId, citxTxId, dropOlder, fromOnChainTx, insert, trimIndex, utxoState)
+import Plutus.ChainIndex (BlockNumber (..), ChainIndexTx (..), ChainIndexTxOutputs (..), InsertUtxoFailed (..),
+                          InsertUtxoSuccess (..), RollbackFailed (..), RollbackResult (..), Tip (..),
+                          TxConfirmedState (..), TxIdState (..), TxOutBalance, TxValidity (..), UtxoState (..), blockId,
+                          citxTxId, fromOnChainTx, insert, trimIndex, utxoState)
 import Plutus.ChainIndex.Compatibility (fromCardanoBlockHeader, fromCardanoPoint)
-import Plutus.ChainIndex.TxIdState (chainConstant)
 import Plutus.ChainIndex.TxIdState qualified as TxIdState
 import Plutus.ChainIndex.TxOutBalance qualified as TxOutBalance
 import Plutus.Contract.CardanoAPI (fromCardanoTx)
@@ -98,24 +96,19 @@ blockAndSlot BlockchainEnv{beCurrentBlock, beCurrentSlot} =
 -- | Process a chain sync event that we receive from the alonzo node client
 processChainSyncEvent :: BlockchainEnv -> ChainSyncEvent -> Slot -> STM (Either SyncActionFailure (Slot, BlockNumber))
 processChainSyncEvent blockchainEnv event _slot = do
-  result <- case event of
-              Resume _ -> Right <$> blockAndSlot blockchainEnv
-              RollForward  (BlockInMode (C.Block header transactions) era) _ ->
-                case era of
-                  -- Unfortunately, we need to pattern match again all eras because
-                  -- 'processBlock' has the constraints 'C.IsCardanoEra era', but not
-                  -- 'C.BlockInMode'.
-                  C.ByronEraInCardanoMode   -> processBlock header blockchainEnv transactions era
-                  C.ShelleyEraInCardanoMode -> processBlock header blockchainEnv transactions era
-                  C.AllegraEraInCardanoMode -> processBlock header blockchainEnv transactions era
-                  C.MaryEraInCardanoMode    -> processBlock header blockchainEnv transactions era
-                  C.AlonzoEraInCardanoMode  -> processBlock header blockchainEnv transactions era
-              RollBackward chainPoint _ -> runRollback blockchainEnv chainPoint
-  flip traverse_ result $ \(_, BlockNumber n) -> do
-    if n `mod` 5_000 == 0
-      then garbageCollect blockchainEnv
-      else pure ()
-  pure result
+  case event of
+    Resume _ -> Right <$> blockAndSlot blockchainEnv
+    RollForward  (BlockInMode (C.Block header transactions) era) _ ->
+      case era of
+        -- Unfortunately, we need to pattern match again all eras because
+        -- 'processBlock' has the constraints 'C.IsCardanoEra era', but not
+        -- 'C.BlockInMode'.
+        C.ByronEraInCardanoMode   -> processBlock header blockchainEnv transactions era
+        C.ShelleyEraInCardanoMode -> processBlock header blockchainEnv transactions era
+        C.AllegraEraInCardanoMode -> processBlock header blockchainEnv transactions era
+        C.MaryEraInCardanoMode    -> processBlock header blockchainEnv transactions era
+        C.AlonzoEraInCardanoMode  -> processBlock header blockchainEnv transactions era
+    RollBackward chainPoint _ -> runRollback blockchainEnv chainPoint
 
 data SyncActionFailure
   = RollbackFailure RollbackFailed
@@ -149,19 +142,6 @@ txEvent tx =
                             ChainIndexTx { _citxOutputs = InvalidTx } -> TxInvalid
    in (view citxTxId tx, TxOutBalance.fromTx tx, validity)
 
--- | Drop all entries in the beTxChanges field that are older than
--- 'chainConstant'.
-garbageCollect :: BlockchainEnv -> STM ()
-garbageCollect BlockchainEnv{beTxChanges, beTxOutChanges, beCurrentBlock} = do
-  txIdStateIndex <- STM.readTVar beTxChanges
-  txOutBalanceStateIndex <- STM.readTVar beTxOutChanges
-  currentBlock   <- STM.readTVar beCurrentBlock
-
-  let targetBlock = BlockNumber $ unBlockNumber currentBlock - fromIntegral (unDepth chainConstant)
-
-  STM.writeTVar beTxChanges $ dropOlder targetBlock txIdStateIndex
-  STM.writeTVar beTxOutChanges $ dropOlder targetBlock txOutBalanceStateIndex
-
 -- | Update the blockchain env. with changes from a new block of cardano
 --   transactions in any era
 processBlock :: forall era. C.IsCardanoEra era