Memoise toBabbagePParams

steshaw · Dec 23, 2022 · 94fc6e1 · 94fc6e1
1 parent 950c4e2
commit 94fc6e1
Show file tree

Hide file tree

Showing 4 changed files with 33 additions and 5 deletions.
diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal
@@ -70,6 +70,7 @@ library
                         Cardano.Api.KeysShelley
                         Cardano.Api.LedgerEvent
                         Cardano.Api.LedgerState
+                        Cardano.Api.Memo
                         Cardano.Api.Modes
                         Cardano.Api.NetworkId
                         Cardano.Api.OperationalCertificate

diff --git a/cardano-api/src/Cardano/Api/Memo.hs b/cardano-api/src/Cardano/Api/Memo.hs
@@ -0,0 +1,21 @@
+{-# LANGUAGE ImportQualifiedPost #-}
+
+module Cardano.Api.Memo where
+
+import Prelude
+import Data.IORef
+import Data.Map qualified as Map
+import System.IO.Unsafe (unsafePerformIO)
+
+{-# NOINLINE memoise #-}
+memoise :: Ord a => (a -> b) -> (a -> b)
+memoise f = unsafePerformIO $ do
+  ref <- newIORef Map.empty
+  pure $ \x -> unsafePerformIO $ do
+    m <- readIORef ref
+    case Map.lookup x m of
+      Just y  -> pure y
+      Nothing -> do
+        let y = f x
+        writeIORef ref (Map.insert x y m)
+        pure y
diff --git a/cardano-api/src/Cardano/Api/ProtocolParameters.hs b/cardano-api/src/Cardano/Api/ProtocolParameters.hs
@@ -121,6 +121,7 @@ import           Cardano.Api.StakePoolMetadata
 import           Cardano.Api.TxMetadata
 import           Cardano.Api.Utils
 import           Cardano.Api.Value
+import           Cardano.Api.Memo
 
 -- | The values of the set of /updatable/ protocol parameters. At any
 -- particular point on the chain there is a current set of parameters in use.
@@ -294,7 +295,7 @@ data ProtocolParameters =
        protocolParamUTxOCostPerByte :: Maybe Lovelace
 
     }
-  deriving (Eq, Generic, Show)
+  deriving (Eq, Generic, Show, Ord)
 
 instance FromJSON ProtocolParameters where
   parseJSON =
@@ -716,7 +717,7 @@ data ExecutionUnitPrices =
        priceExecutionSteps  :: Rational,
        priceExecutionMemory :: Rational
      }
-  deriving (Eq, Show)
+  deriving (Eq, Ord, Show)
 
 instance ToCBOR ExecutionUnitPrices where
   toCBOR ExecutionUnitPrices{priceExecutionSteps, priceExecutionMemory} =
@@ -770,7 +771,7 @@ fromAlonzoPrices Alonzo.Prices{Alonzo.prSteps, Alonzo.prMem} =
 --
 
 newtype CostModel = CostModel (Map Text Integer)
-  deriving (Eq, Show)
+  deriving (Eq, Show, Ord)
   deriving newtype (ToJSON, FromJSON)
   deriving newtype (ToCBOR, FromCBOR)
 
@@ -1356,7 +1357,12 @@ toLedgerPParams ShelleyBasedEraShelley = toShelleyPParams
 toLedgerPParams ShelleyBasedEraAllegra = toShelleyPParams
 toLedgerPParams ShelleyBasedEraMary    = toShelleyPParams
 toLedgerPParams ShelleyBasedEraAlonzo  = toAlonzoPParams
-toLedgerPParams ShelleyBasedEraBabbage = toBabbagePParams
+toLedgerPParams ShelleyBasedEraBabbage = toBabbagePParamsMemo
+
+
+
+toBabbagePParamsMemo :: ProtocolParameters -> Babbage.PParams ledgerera
+toBabbagePParamsMemo = memoise toBabbagePParams
 
 toShelleyPParams :: ProtocolParameters -> Shelley.PParams ledgerera
 toShelleyPParams ProtocolParameters {

diff --git a/cardano-api/src/Cardano/Api/Script.hs b/cardano-api/src/Cardano/Api/Script.hs
@@ -872,7 +872,7 @@ data ExecutionUnits =
         -- execution.
         executionMemory :: Natural
      }
-  deriving (Eq, Show)
+  deriving (Eq, Ord, Show)
 
 instance ToCBOR ExecutionUnits where
   toCBOR ExecutionUnits{executionSteps, executionMemory} =