Make all fields strict

cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert.hs

@@ -42,7 +42,6 @@ import           Cardano.Ledger.Mary.Value (AssetName (..), PolicyID (..), Value
 import           Cardano.Slotting.Block (BlockNo (..))
 import           Cardano.Slotting.Slot (EpochNo (..), EpochSize (..), SlotNo (..))
 
-import           Control.Monad.Extra (whenJust)
 import           Control.Monad.Logger (LoggingT)
 import           Control.Monad.Trans.Control (MonadBaseControl)
 

cardano-sync/cardano-sync.cabal

@@ -85,6 +85,7 @@ library
                       , extra
                       , filepath
                       , iohk-monitoring
+                      , io-sim-classes
                       , lifted-base
                       , monad-control
                       , memory
@@ -98,6 +99,7 @@ library
                       , ouroboros-network-framework
                       , shelley-spec-ledger
                       , stm
+                      , strict
                       , text
                       , time
                       , transformers

cardano-sync/src/Cardano/Sync/Database.hs

@@ -28,7 +28,7 @@ import           Cardano.Sync.LedgerState
 import           Cardano.Sync.Metrics
 import           Cardano.Sync.Plugin
 import           Cardano.Sync.Types
-import           Cardano.Sync.Util
+import           Cardano.Sync.Util hiding (whenJust)
 
 data NextState
   = Continue

cardano-sync/src/Cardano/Sync/Era/Shelley/Generic/EpochUpdate.hs

@@ -7,11 +7,13 @@ module Cardano.Sync.Era.Shelley.Generic.EpochUpdate
   , shelleyEpochUpdate
   ) where
 
+import           Prelude hiding (Maybe)
+
 import           Cardano.Sync.Era.Shelley.Generic.ProtoParams
 import           Cardano.Sync.Era.Shelley.Generic.Rewards
 import           Cardano.Sync.Era.Shelley.Generic.StakeDist
 
-import           Data.Maybe (fromMaybe)
+import           Data.Strict.Maybe (Maybe, fromMaybe)
 
 import           Ouroboros.Consensus.Block (EpochNo)
 import           Ouroboros.Consensus.Cardano.Block (LedgerState (..), StandardAllegra, StandardMary,

cardano-sync/src/Cardano/Sync/LedgerState.hs

@@ -33,14 +33,15 @@ import qualified Cardano.Sync.Era.Shelley.Generic.Rewards as Generic
 import           Cardano.Sync.Types hiding (CardanoBlock)
 import           Cardano.Sync.Util
 
-import           Cardano.Prelude
+import           Cardano.Prelude hiding (atomically)
 import           Cardano.Slotting.Block (BlockNo (..))
 
 import           Cardano.Slotting.EpochInfo (EpochInfo, epochInfoEpoch)
 import           Cardano.Slotting.Slot (EpochNo (..), SlotNo (..), WithOrigin (..), fromWithOrigin)
 
-import           Control.Concurrent.STM.TVar (TVar, newTVarIO, readTVar, readTVarIO, writeTVar)
 import qualified Control.Exception as Exception
+import           Control.Monad.Class.MonadSTM.Strict (StrictTVar, atomically, newTVarIO, readTVar,
+                   writeTVar)
 import           Control.Monad.Extra (firstJustM, fromMaybeM)
 
 import qualified Data.ByteString.Base16 as Base16
@@ -49,6 +50,7 @@ import qualified Data.ByteString.Lazy.Char8 as LBS
 import qualified Data.ByteString.Short as BSS
 import qualified Data.List as List
 import qualified Data.Map.Strict as Map
+import qualified Data.Strict.Maybe as Strict
 import qualified Data.Text as Text
 
 import           Ouroboros.Consensus.Block (CodecConfig, WithOrigin (..), blockHash, blockIsEBB,
@@ -93,12 +95,13 @@ import           System.FilePath (dropExtension, takeExtension, (</>))
 -- therefore ledger states are stored in files with the SlotNo and hash in the file name.
 
 {- HLINT ignore "Reduce duplication" -}
+{- HLINT ignore "Use readTVarIO" -}
 
 data LedgerEnv = LedgerEnv
   { leProtocolInfo :: !(Consensus.ProtocolInfo IO CardanoBlock)
   , leDir :: !LedgerStateDir
   , leNetwork :: !Shelley.Network
-  , leStateVar :: !(TVar CardanoLedgerState)
+  , leStateVar :: !(StrictTVar IO CardanoLedgerState)
   }
 
 topLevelConfig :: LedgerEnv -> TopLevelConfig CardanoBlock
@@ -117,7 +120,7 @@ data LedgerStateFile = LedgerStateFile
 
 data LedgerStateSnapshot = LedgerStateSnapshot
   { lssState :: !CardanoLedgerState
-  , lssNewEpoch :: !(Maybe Generic.NewEpoch) -- Only Just for a single block at the epoch boundary
+  , lssNewEpoch :: !(Strict.Maybe Generic.NewEpoch) -- Only Just for a single block at the epoch boundary
   }
 
 mkLedgerEnv :: Consensus.ProtocolInfo IO CardanoBlock
@@ -158,7 +161,7 @@ applyBlock env blk =
       writeTVar (leStateVar env) newState
       pure $ LedgerStateSnapshot
                 { lssState = newState
-                , lssNewEpoch = mkNewEpoch oldState newState
+                , lssNewEpoch = maybeToStrict $ mkNewEpoch oldState newState
                 }
   where
     applyBlk
@@ -177,10 +180,10 @@ applyBlock env blk =
             Generic.NewEpoch
               { Generic.epoch = ledgerEpochNo env newState
               , Generic.isEBB = isJust $ blockIsEBB blk
-              , Generic.adaPots = getAdaPots newState
+              , Generic.adaPots = maybeToStrict $ getAdaPots newState
               , Generic.epochUpdate =
-                  ledgerEpochUpdate env (clsState newState)
-                    (ledgerRewardUpdate env (ledgerState $ clsState oldState))
+                  maybeToStrict $ ledgerEpochUpdate env (clsState newState)
+                    (maybeToStrict $ ledgerRewardUpdate env (ledgerState $ clsState oldState))
               }
         else Nothing
 
@@ -195,7 +198,7 @@ deleteNewerLedgerStateFiles stateDir slotNo = do
 
 saveCurrentLedgerState :: LedgerEnv -> Bool -> IO ()
 saveCurrentLedgerState env isNewEpoch = do
-    ledger <- readTVarIO (leStateVar env)
+    ledger <- atomically $ readTVar (leStateVar env)
     case mkLedgerStateFilename (leDir env) ledger isNewEpoch of
       Origin -> pure () -- we don't store genesis
       At file -> LBS.writeFile file $
@@ -213,11 +216,11 @@ saveLedgerStateMaybe :: LedgerEnv -> LedgerStateSnapshot -> SyncState -> IO ()
 saveLedgerStateMaybe env snapshot synced = do
   writeLedgerState env ledger
   case (synced, lssNewEpoch snapshot) of
-    (_, Just newEpoch) | not (Generic.isEBB newEpoch) ->
+    (_, Strict.Just newEpoch) | not (Generic.isEBB newEpoch) ->
       saveCleanupState True    -- Save ledger states on epoch boundaries, unless they are EBBs
-    (SyncFollowing, Nothing) ->
+    (SyncFollowing, Strict.Nothing) ->
       saveCleanupState False   -- If following, save every state.
-    (SyncLagging, Nothing) | block `mod` 2000 == 0 ->
+    (SyncLagging, Strict.Nothing) | block `mod` 2000 == 0 ->
       saveCleanupState False   -- Only save state ocassionally.
     _ -> pure ()
   where
@@ -437,16 +440,16 @@ ledgerEpochNo env cls =
     epochInfo = epochInfoLedger (configLedger $ topLevelConfig env) (hardForkLedgerStatePerEra . ledgerState $ clsState cls)
 
 -- Create an EpochUpdate from the current epoch state and the rewards from the last epoch.
-ledgerEpochUpdate :: LedgerEnv -> ExtLedgerState CardanoBlock -> Maybe Generic.Rewards -> Maybe Generic.EpochUpdate
+ledgerEpochUpdate :: LedgerEnv -> ExtLedgerState CardanoBlock -> Strict.Maybe Generic.Rewards -> Maybe Generic.EpochUpdate
 ledgerEpochUpdate env els mRewards =
   case ledgerState els of
     LedgerStateByron _ -> Nothing
     LedgerStateShelley sls -> Just $ Generic.shelleyEpochUpdate (leNetwork env) sls mRewards mNonce
     LedgerStateAllegra als -> Just $ Generic.allegraEpochUpdate (leNetwork env) als mRewards mNonce
     LedgerStateMary mls -> Just $ Generic.maryEpochUpdate (leNetwork env) mls mRewards mNonce
   where
-    mNonce :: Maybe Shelley.Nonce
-    mNonce = extractEpochNonce els
+    mNonce :: Strict.Maybe Shelley.Nonce
+    mNonce = maybeToStrict $ extractEpochNonce els
 
 -- This will return a 'Just' from the time the rewards are updated until the end of the
 -- epoch. It is 'Nothing' for the first block of a new epoch (which is slightly inconvenient).

cardano-sync/src/Cardano/Sync/StateQuery.hs

@@ -22,9 +22,9 @@ import           Cardano.Sync.Api
 import           Cardano.Sync.Types
 import           Cardano.Sync.Util
 
-import           Cardano.Prelude
+import           Cardano.Prelude hiding (atomically)
 
-import           Control.Concurrent.STM.TMVar (TMVar, newEmptyTMVarIO, putTMVar, takeTMVar)
+import           Control.Monad.Class.MonadSTM.Strict
 
 import           Data.IORef (IORef, newIORef, readIORef, writeIORef)
 import           Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime)
@@ -51,9 +51,9 @@ import           System.IO.Unsafe (unsafePerformIO)
 
 newtype StateQueryTMVar blk result = StateQueryTMVar
   { unStateQueryTMVar ::
-      TMVar
+      StrictTMVar IO
         ( Query blk result
-        , TMVar (Either AcquireFailure result)
+        , StrictTMVar IO (Either AcquireFailure result)
         )
   }
 

cardano-sync/src/Cardano/Sync/Util.hs

@@ -18,6 +18,8 @@ module Cardano.Sync.Util
   , tipBlockNo
   , traverseMEither
   , nullMetricSetters
+  , maybeToStrict
+  , whenJust
   ) where
 
 import           Cardano.Prelude hiding (catch)
@@ -36,6 +38,7 @@ import           Data.ByteArray (ByteArrayAccess)
 import qualified Data.ByteArray
 import qualified Data.ByteString.Base16 as Base16
 import qualified Data.List as List
+import qualified Data.Strict.Maybe as Strict
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 import qualified Data.Text.IO as Text
@@ -142,3 +145,12 @@ renderSlotList xs
   | length xs < 10 = textShow (map unSlotNo xs)
   | otherwise =
       mconcat [ "[", textShow (unSlotNo $ List.head xs), "..", textShow (unSlotNo $ List.last xs), "]" ]
+
+maybeToStrict :: Maybe a -> Strict.Maybe a
+maybeToStrict Nothing = Strict.Nothing
+maybeToStrict (Just a) = Strict.Just a
+
+whenJust :: Applicative m => Strict.Maybe a -> (a -> m ()) -> m ()
+whenJust ma f = case ma of
+  Strict.Nothing -> pure ()
+  Strict.Just a -> f a