Update to mempack-0.2

Author: jasagredo

cabal.project

@@ -55,7 +55,22 @@ if impl (ghc >= 9.10)
     -- https://github.com/phadej/regression-simple/pull/14
     , regression-simple:base
 
--- source-repository-package
---   type: git
---   location: https://github.com/lehins/mempack
---   tag: 2f2528780c715afd2f270447359c7cde632f2c49
+source-repository-package
+  type: git
+  location: https://github.com/lehins/mempack
+  tag: 2f2528780c715afd2f270447359c7cde632f2c49
+  --sha256: sha256-OtcXXetYvECE6iofJxVu/Tz+Vk0OGmbS8lTyOJXWmQ0=
+
+source-repository-package
+  type: git
+  location: https://github.com/IntersectMBO/cardano-base
+  tag: 4b2337529c6ae12677461f6fa373e47020455850
+  --sha256: sha256-RDOM3SGVCfi4eeblh9a+7mtA6Rk7262HiDKsYmaXeBU=
+  subdir: cardano-crypto-class
+
+source-repository-package
+  type: git
+  location: https://github.com/IntersectMBO/cardano-ledger
+  tag: 8b139be8ffcc1a84d4352beed44ef27a18e179f7
+  --sha256: sha256-2Srt5YUdRRUhN/TZBShcG9JlldvWywN0DpjjjRHkzaU=
+  subdir: libs/cardano-ledger-core

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/Impl/LMDB/Bridge.hs

@@ -41,7 +41,7 @@ import Database.LMDB.Simple.Cursor (CursorM)
 import qualified Database.LMDB.Simple.Cursor as Cursor
 import qualified Database.LMDB.Simple.Internal as Internal
 import Foreign (Storable (peek, poke), castPtr)
-import GHC.Ptr (Ptr (..))
+import GHC.Exts
 import Ouroboros.Consensus.Util.IndexedMemPack
 
 instance Buffer MDB_val where
@@ -51,6 +51,15 @@ instance Buffer MDB_val where
   buffer (MDB_val _ (Ptr addr#)) _ f = f addr#
   {-# INLINE buffer #-}
 
+  mkBuffer ba# =
+    MDB_val
+      (fromIntegral (I# (sizeofByteArray# ba#)))
+      (Ptr (byteArrayContents# ba#))
+  {-# INLINE mkBuffer #-}
+
+  bufferHasToBePinned = True
+  {-# INLINE bufferHasToBePinned #-}
+
 {-------------------------------------------------------------------------------
   Internal: peek and poke
 -------------------------------------------------------------------------------}

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/LSM.hs

@@ -111,16 +111,16 @@ toTxOutBytes st txout =
    in TxOutBytes $ LSM.RawBytes (VP.Vector 0 (PBA.sizeofByteArray barr) barr)
 
 fromTxOutBytes :: IndexedMemPack (l EmptyMK) (TxOut l) => l EmptyMK -> TxOutBytes -> TxOut l
-fromTxOutBytes st (TxOutBytes (LSM.RawBytes (VP.force -> (VP.Vector _ _ barr)))) =
-  case indexedUnpackLeftOver' st barr of
+fromTxOutBytes st (TxOutBytes (LSM.RawBytes vec)) =
+  case indexedUnpackEither st vec of
     Left err ->
       error $
         unlines
           [ "There was an error deserializing a TxOut from the LSM backend."
           , "This will likely result in a restart-crash loop."
           , "The error: " <> show err
           ]
-    Right (v, _) -> v
+    Right v -> v
 
 instance LSM.SerialiseValue TxOutBytes where
   serialiseValue = unTxOutBytes
@@ -140,16 +140,16 @@ toTxInBytes _ txin =
    in TxInBytes $ LSM.RawBytes (VP.Vector 0 (PBA.sizeofByteArray barr) barr)
 
 fromTxInBytes :: MemPack (TxIn l) => Proxy l -> TxInBytes -> TxIn l
-fromTxInBytes _ (TxInBytes (LSM.RawBytes (VP.force -> (VP.Vector _ _ barr)))) =
-  case unpackLeftOver' barr of
+fromTxInBytes _ (TxInBytes (LSM.RawBytes vec)) =
+  case unpackEither vec of
     Left err ->
       error $
         unlines
           [ "There was an error deserializing a TxIn from the LSM backend."
           , "This will likely result in a restart-crash loop."
           , "The error: " <> show err
           ]
-    Right (v, _) -> v
+    Right v -> v
 
 instance LSM.SerialiseKey TxInBytes where
   serialiseKey = unTxInBytes

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/IndexedMemPack.hs

@@ -17,12 +17,13 @@ module Ouroboros.Consensus.Util.IndexedMemPack
   , indexedPackByteArray
   , indexedUnpackError
   , indexedUnpack
-  , indexedUnpackLeftOver'
-  , unpackLeftOver'
+  , indexedUnpackEither
+  , unpackEither
   ) where
 
 import qualified Control.Monad as Monad
-import Control.Monad.Trans.Fail (Fail, errorFail, failT, runFailAgg)
+import Control.Monad.ST
+import Control.Monad.Trans.Fail
 import Data.Array.Byte (ByteArray (..))
 import Data.Bifunctor (first)
 import Data.ByteString
@@ -35,7 +36,7 @@ import GHC.Stack
 class IndexedMemPack idx a where
   indexedPackedByteCount :: idx -> a -> Int
   indexedPackM :: idx -> a -> Pack s ()
-  indexedUnpackM :: Buffer b => idx -> Unpack b a
+  indexedUnpackM :: Buffer b => forall s. idx -> Unpack s b a
   indexedTypeName :: idx -> String
 
 indexedPackByteString ::
@@ -82,24 +83,30 @@ indexedUnpackFail idx b = do
 indexedUnpackLeftOver ::
   forall idx a b.
   (IndexedMemPack idx a, Buffer b, HasCallStack) => idx -> b -> Fail SomeError (a, Int)
-indexedUnpackLeftOver idx b = do
+indexedUnpackLeftOver idx b = FailT $ pure $ runST $ runFailAggT $ indexedUnpackLeftOverST idx b
+{-# INLINEABLE indexedUnpackLeftOver #-}
+
+indexedUnpackLeftOverST ::
+  forall idx a b s.
+  (IndexedMemPack idx a, Buffer b, HasCallStack) => idx -> b -> FailT SomeError (ST s) (a, Int)
+indexedUnpackLeftOverST idx b = do
   let len = bufferByteCount b
   res@(_, consumedBytes) <- runStateT (runUnpack (indexedUnpackM idx) b) 0
   Monad.when (consumedBytes > len) $ errorLeftOver (indexedTypeName @idx @a idx) consumedBytes len
   pure res
-{-# INLINEABLE indexedUnpackLeftOver #-}
+{-# INLINEABLE indexedUnpackLeftOverST #-}
 
-indexedUnpackLeftOver' ::
+indexedUnpackEither ::
   forall idx a b.
-  (IndexedMemPack idx a, Buffer b, HasCallStack) => idx -> b -> Either SomeError (a, Int)
-indexedUnpackLeftOver' idx = first fromMultipleErrors . runFailAgg . indexedUnpackLeftOver idx
-{-# INLINEABLE indexedUnpackLeftOver' #-}
+  (IndexedMemPack idx a, Buffer b, HasCallStack) => idx -> b -> Either SomeError a
+indexedUnpackEither idx = first fromMultipleErrors . runFailAgg . indexedUnpackFail idx
+{-# INLINEABLE indexedUnpackEither #-}
 
-unpackLeftOver' ::
+unpackEither ::
   forall a b.
-  (MemPack a, Buffer b, HasCallStack) => b -> Either SomeError (a, Int)
-unpackLeftOver' = first fromMultipleErrors . runFailAgg . unpackLeftOver
-{-# INLINEABLE unpackLeftOver' #-}
+  (MemPack a, Buffer b, HasCallStack) => b -> Either SomeError a
+unpackEither = first fromMultipleErrors . runFailAgg . unpackFail
+{-# INLINEABLE unpackEither #-}
 
 errorLeftOver :: HasCallStack => String -> Int -> Int -> a
 errorLeftOver name consumedBytes len =