diff --git a/cabal.project b/cabal.project
index 674ca2e36ff..b48b6fb04e8 100644
--- a/cabal.project
+++ b/cabal.project
@@ -98,6 +98,12 @@ source-repository-package
   tag: ee59880f47ab835dbd73bea0847dab7869fc20d8
   --sha256: 1lrzknw765pz2j97nvv9ip3l1mcpf2zr4n56hwlz0rk7wq7ls4cm
 
+source-repository-package
+  type: git
+  location: https://github.com/fpco/weigh.git
+  tag: bfcf4415144d7d2817dfcb91b6f9a6dfd7236de7
+  --sha256: 01fy4nbq6kaqi73ydn6w7rd1izkg5p217q5znyp2icybf41sl1b6
+
 allow-newer:
   monoidal-containers:aeson,
   size-based:template-haskell,
diff --git a/eras/shelley/impl/cardano-ledger-shelley.cabal b/eras/shelley/impl/cardano-ledger-shelley.cabal
index 61b00d694e1..613e416cbd8 100644
--- a/eras/shelley/impl/cardano-ledger-shelley.cabal
+++ b/eras/shelley/impl/cardano-ledger-shelley.cabal
@@ -110,6 +110,7 @@ library
     cardano-protocol-tpraos,
     cardano-slotting,
     cborg,
+    compact-map,
     constraints,
     containers,
     data-default-class,
@@ -124,4 +125,4 @@ library
     strict-containers,
     text,
     time,
-    transformers
+    transformers,
diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Wallet.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Wallet.hs
index ec6d3d90447..216d418187c 100644
--- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Wallet.hs
+++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Wallet.hs
@@ -66,6 +66,7 @@ import Cardano.Ledger.BaseTypes
     epochInfo,
   )
 import Cardano.Ledger.Coin (Coin (..))
+import Cardano.Ledger.Compactible (fromCompact)
 import qualified Cardano.Ledger.Core as Core
 import Cardano.Ledger.Credential (Credential (..))
 import Cardano.Ledger.Crypto (DSIGN, VRF)
@@ -104,7 +105,7 @@ import Cardano.Ledger.Shelley.Rewards
   ( NonMyopic (..),
     PerformanceEstimate (..),
     StakeShare (..),
-    getTopRankedPools,
+    getTopRankedPoolsVMap,
     nonMyopicMemberRew,
     percentile',
   )
@@ -130,12 +131,12 @@ import Data.Coders
     (!>),
     (<!),
   )
+import qualified Data.Compact.VMap as VMap
 import Data.Default.Class (Default (..))
 import Data.Either (fromRight)
-import Data.Foldable (fold)
+import Data.Foldable (fold, foldMap')
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
-import Data.Maybe (fromMaybe)
 import Data.Proxy (Proxy (..))
 import Data.Ratio ((%))
 import Data.Sequence.Strict (StrictSeq)
@@ -225,7 +226,7 @@ poolsByTotalStakeFraction globals ss =
   where
     snap@(EB.SnapShot stake _ _) = currentSnapshot ss
     Coin totalStake = getTotalStake globals ss
-    Coin activeStake = fold . EB.unStake $ stake
+    Coin activeStake = VMap.foldMap fromCompact $ EB.unStake stake
     stakeRatio = activeStake % totalStake
     PoolDistr poolsByActiveStake = calculatePoolDistr snap
     poolsByTotalStake = Map.map toTotalStakeFrac poolsByActiveStake
@@ -261,39 +262,31 @@ getNonMyopicMemberRewards ::
     (Either Coin (Credential 'Staking (Crypto era)))
     (Map (KeyHash 'StakePool (Crypto era)) Coin)
 getNonMyopicMemberRewards globals ss creds =
-  Map.fromList $
-    fmap
-      (\cred -> (cred, Map.map (mkNMMRewards $ memShare cred) poolData))
-      (Set.toList creds)
+  Map.fromSet (\cred -> Map.map (mkNMMRewards $ memShare cred) poolData) creds
   where
     maxSupply = Coin . fromIntegral $ maxLovelaceSupply globals
     Coin totalStake = circulation es maxSupply
     toShare (Coin x) = StakeShare (x % totalStake)
     memShare (Right cred) =
-      toShare $
-        Map.findWithDefault (Coin 0) cred (EB.unStake stake)
+      toShare $ maybe mempty fromCompact $ VMap.lookup cred (EB.unStake stake)
     memShare (Left coin) = toShare coin
     es = nesEs ss
     pp = esPp es
-    NonMyopic
-      { likelihoodsNM = ls,
-        rewardPotNM = rPot
-      } = esNonMyopic es
+    NonMyopic {likelihoodsNM = ls, rewardPotNM = rPot} = esNonMyopic es
     EB.SnapShot stake delegs poolParams = currentSnapshot ss
     poolData =
-      Map.mapWithKey
-        ( \k p ->
+      Map.fromDistinctAscList
+        [ ( k,
             ( percentile' (histLookup k),
               p,
-              toShare . fold
-                . EB.unStake
-                $ EB.poolStake k delegs stake
+              toShare . VMap.foldMap fromCompact . EB.unStake $ EB.poolStake k delegs stake
             )
-        )
-        poolParams
-    histLookup k = fromMaybe mempty (Map.lookup k ls)
+          )
+          | (k, p) <- VMap.toAscList poolParams
+        ]
+    histLookup k = Map.findWithDefault mempty k ls
     topPools =
-      getTopRankedPools
+      getTopRankedPoolsVMap
         rPot
         (Coin totalStake)
         pp
@@ -306,19 +299,15 @@ getNonMyopicMemberRewards globals ss creds =
       where
         s = (toShare . _poolPledge) poolp
         checkPledge pool =
-          let ostake =
-                Set.foldl'
-                  ( \c o ->
-                      c
-                        <> fromMaybe
-                          mempty
-                          ( Map.lookup (KeyHashObj o) (EB.unStake stake)
-                          )
-                  )
-                  mempty
-                  (_poolOwners pool)
+          let ostake = sumPoolOwnersStake pool stake
            in _poolPledge poolp <= ostake
 
+sumPoolOwnersStake :: PoolParams crypto -> EB.Stake crypto -> Coin
+sumPoolOwnersStake pool stake =
+  let getStakeFor o =
+        maybe mempty fromCompact $ VMap.lookup (KeyHashObj o) (EB.unStake stake)
+   in foldMap' getStakeFor (_poolOwners pool)
+
 -- | Create a current snapshot of the ledger state.
 --
 -- When ranking pools, and reporting their saturation level, in the wallet, we
@@ -405,7 +394,7 @@ getRewardInfoPools ::
   NewEpochState era ->
   (RewardParams, Map (KeyHash 'StakePool (Crypto era)) RewardInfoPool)
 getRewardInfoPools globals ss =
-  (mkRewardParams, Map.mapWithKey mkRewardInfoPool poolParams)
+  (mkRewardParams, VMap.toMap (VMap.mapWithKey mkRewardInfoPool poolParams))
   where
     es = nesEs ss
     pp = esPp es
@@ -413,7 +402,7 @@ getRewardInfoPools globals ss =
       { likelihoodsNM = ls,
         rewardPotNM = rPot
       } = esNonMyopic es
-    histLookup key = fromMaybe mempty (Map.lookup key ls)
+    histLookup key = Map.findWithDefault mempty key ls
 
     EB.SnapShot stakes delegs poolParams = currentSnapshot ss
 
@@ -435,17 +424,8 @@ getRewardInfoPools globals ss =
             unPerformanceEstimate $ percentile' $ histLookup key
         }
       where
-        pstake = fold . EB.unStake $ EB.poolStake key delegs stakes
-        ostake =
-          Set.foldl'
-            ( \c o ->
-                c
-                  <> fromMaybe
-                    mempty
-                    (Map.lookup (KeyHashObj o) (EB.unStake stakes))
-            )
-            mempty
-            (_poolOwners poolp)
+        pstake = VMap.foldMap fromCompact . EB.unStake $ EB.poolStake key delegs stakes
+        ostake = sumPoolOwnersStake poolp stakes
 
 {-# DEPRECATED getRewardInfo "Use 'getRewardProvenance' instead." #-}
 getRewardInfo ::
diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/EpochBoundary.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/EpochBoundary.hs
index bb37c6a7c0b..cf002de8187 100644
--- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/EpochBoundary.hs
+++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/EpochBoundary.hs
@@ -43,6 +43,7 @@ import Cardano.Ledger.Coin
     coinToRational,
     rationalToCoinViaFloor,
   )
+import Cardano.Ledger.Compactible
 import qualified Cardano.Ledger.Core as Core
 import Cardano.Ledger.Credential (Credential, Ptr, StakeReference (..))
 import qualified Cardano.Ledger.Crypto as CC (Crypto)
@@ -55,10 +56,12 @@ import Cardano.Ledger.Val ((<+>), (<×>))
 import qualified Cardano.Ledger.Val as Val
 import Control.DeepSeq (NFData)
 import Control.SetAlgebra (dom, eval, setSingleton, (▷), (◁))
+import Data.Compact.VMap as VMap
 import Data.Default.Class (Default, def)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import Data.Ratio ((%))
+import Data.Typeable
 import GHC.Generics (Generic)
 import GHC.Records (HasField, getField)
 import NoThunks.Class (NoThunks (..))
@@ -66,9 +69,11 @@ import Numeric.Natural (Natural)
 
 -- | Type of stake as map from hash key to coins associated.
 newtype Stake crypto = Stake
-  { unStake :: Map (Credential 'Staking crypto) Coin
+  { unStake :: VMap VB VP (Credential 'Staking crypto) (CompactForm Coin)
   }
-  deriving (Show, Eq, Ord, NoThunks, NFData)
+  deriving (Show, Eq, NFData, Generic)
+
+deriving newtype instance Typeable crypto => NoThunks (Stake crypto)
 
 deriving newtype instance
   CC.Crypto crypto => ToCBOR (Stake crypto)
@@ -113,11 +118,11 @@ aggregateUtxoCoinByCredential ptrs (UTxO u) initial =
 -- | Get stake of one pool
 poolStake ::
   KeyHash 'StakePool crypto ->
-  Map (Credential 'Staking crypto) (KeyHash 'StakePool crypto) ->
+  VMap VB VB (Credential 'Staking crypto) (KeyHash 'StakePool crypto) ->
   Stake crypto ->
   Stake crypto
 poolStake hk delegs (Stake stake) =
-  Stake $ eval (dom (delegs ▷ setSingleton hk) ◁ stake)
+  Stake $ fromMap (eval (dom (toMap delegs ▷ setSingleton hk) ◁ toMap stake))
 
 -- | Calculate total possible refunds.
 obligation ::
@@ -165,12 +170,12 @@ maxPool pc r sigma pR = maxPool' a0 nOpt r sigma pR
 -- | Snapshot of the stake distribution.
 data SnapShot crypto = SnapShot
   { _stake :: !(Stake crypto),
-    _delegations :: !(Map (Credential 'Staking crypto) (KeyHash 'StakePool crypto)),
-    _poolParams :: !(Map (KeyHash 'StakePool crypto) (PoolParams crypto))
+    _delegations :: !(VMap VB VB (Credential 'Staking crypto) (KeyHash 'StakePool crypto)),
+    _poolParams :: !(VMap VB VB (KeyHash 'StakePool crypto) (PoolParams crypto))
   }
   deriving (Show, Eq, Generic)
 
-instance NoThunks (SnapShot crypto)
+instance Typeable crypto => NoThunks (SnapShot crypto)
 
 instance NFData (SnapShot crypto)
 
@@ -203,7 +208,7 @@ data SnapShots crypto = SnapShots
   }
   deriving (Show, Eq, Generic)
 
-instance NoThunks (SnapShots crypto)
+instance Typeable crypto => NoThunks (SnapShots crypto)
 
 instance NFData (SnapShots crypto)
 
@@ -234,7 +239,7 @@ instance Default (SnapShots crypto) where
   def = emptySnapShots
 
 emptySnapShot :: SnapShot crypto
-emptySnapShot = SnapShot (Stake Map.empty) Map.empty Map.empty
+emptySnapShot = SnapShot (Stake VMap.empty) VMap.empty VMap.empty
 
 emptySnapShots :: SnapShots crypto
 emptySnapShots = SnapShots emptySnapShot emptySnapShot emptySnapShot (Coin 0)
diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs
index 9a7a330cce2..b6fc4c43234 100644
--- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs
+++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs
@@ -233,6 +233,7 @@ import Data.Coders
     decodeRecordNamed,
     (<!),
   )
+import qualified Data.Compact.VMap as VMap
 import Data.Constraint (Constraint)
 import Data.Default.Class (Default, def)
 import Data.Foldable (fold, toList)
@@ -999,9 +1000,9 @@ stakeDistr ::
   SnapShot (Crypto era)
 stakeDistr u ds ps =
   SnapShot
-    (Stake $ eval (dom activeDelegs ◁ stakeRelation))
-    delegs
-    poolParams
+    (Stake $ VMap.fromMap (compactCoinOrError <$> eval (dom activeDelegs ◁ stakeRelation)))
+    (VMap.fromMap delegs)
+    (VMap.fromMap poolParams)
   where
     DState rewards' delegs ptrs' _ _ _ = ds
     PState poolParams _ _ = ps
@@ -1009,6 +1010,10 @@ stakeDistr u ds ps =
     stakeRelation = aggregateUtxoCoinByCredential (forwards ptrs') u rewards'
     activeDelegs :: Map (Credential 'Staking (Crypto era)) (KeyHash 'StakePool (Crypto era))
     activeDelegs = eval ((dom rewards' ◁ delegs) ▷ dom poolParams)
+    compactCoinOrError c =
+      case toCompact c of
+        Nothing -> error $ "Invalid ADA value in staking: " <> show c
+        Just compactCoin -> compactCoin
 
 -- | Apply a reward update
 applyRUpd ::
@@ -1115,7 +1120,7 @@ startStep ::
 startStep slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ss ls pr _ nm) maxSupply asc secparam =
   let SnapShot stake' delegs' poolParams = _pstakeGo ss
       f, numPools, k :: Rational
-      numPools = fromIntegral (Map.size poolParams)
+      numPools = fromIntegral (VMap.size poolParams)
       k = fromIntegral secparam
       f = unboundRational (activeSlotVal asc)
 
@@ -1168,7 +1173,7 @@ startStep slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ss ls pr _ nm) max
             rewTotalStake = totalStake,
             rewRPot = Coin rPot
           }
-      activestake = fold . unStake $ stake'
+      activestake = VMap.foldMap fromCompact $ unStake stake'
       free =
         FreeVars
           (unBlocksMade b)
@@ -1190,7 +1195,7 @@ startStep slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ss ls pr _ nm) max
         RSLP
           pulseSize
           free
-          (StrictSeq.fromList $ Map.elems poolParams)
+          (StrictSeq.fromList $ VMap.elems poolParams)
           (RewardAns Map.empty Map.empty)
       provenance =
         def
@@ -1277,7 +1282,7 @@ completeRupd
                 key
                 ( Desirability
                     { hitRateEstimate = unPerformanceEstimate estimate,
-                      desirabilityScore = case Map.lookup key poolParams of
+                      desirabilityScore = case VMap.lookup key poolParams of
                         Just ppx -> desirability (a0, nOpt) rpot ppx estimate totalstake
                         Nothing -> 0
                     }
diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/RewardUpdate.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/RewardUpdate.hs
index 2372fa4ed9d..15e02c3661f 100644
--- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/RewardUpdate.hs
+++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/RewardUpdate.hs
@@ -31,6 +31,7 @@ import Cardano.Ledger.BaseTypes
     boundedRationalToCBOR,
   )
 import Cardano.Ledger.Coin (Coin (..), DeltaCoin (..))
+import Cardano.Ledger.Compactible (fromCompact)
 import Cardano.Ledger.Credential (Credential (..))
 import qualified Cardano.Ledger.Crypto as CC (Crypto)
 import Cardano.Ledger.Keys (KeyHash, KeyRole (..))
@@ -65,11 +66,13 @@ import Data.Coders
     mapEncode,
     setDecode,
     setEncode,
+    vMapDecode,
+    vMapEncode,
     (!>),
     (<!),
   )
+import Data.Compact.VMap as VMap
 import Data.Default.Class (def)
-import Data.Foldable (fold)
 import Data.Group (invert)
 import Data.Kind (Type)
 import Data.Map.Strict (Map)
@@ -81,6 +84,7 @@ import Data.Sequence.Strict (StrictSeq)
 import qualified Data.Sequence.Strict as StrictSeq
 import Data.Set (Set)
 import qualified Data.Set as Set
+import Data.Typeable
 import GHC.Generics (Generic)
 import GHC.Records (HasField (..))
 import NoThunks.Class (NoThunks (..), allNoThunks)
@@ -174,7 +178,7 @@ data RewardSnapShot crypto = RewardSnapShot
   }
   deriving (Show, Eq, Generic)
 
-instance NoThunks (RewardSnapShot crypto)
+instance Typeable crypto => NoThunks (RewardSnapShot crypto)
 
 instance NFData (RewardSnapShot crypto)
 
@@ -234,7 +238,7 @@ instance HasField "_protocolVersion" (RewardSnapShot crypto) ProtVer where
 
 data FreeVars crypto = FreeVars
   { b :: !(Map (KeyHash 'StakePool crypto) Natural),
-    delegs :: !(Map (Credential 'Staking crypto) (KeyHash 'StakePool crypto)),
+    delegs :: !(VMap VB VB (Credential 'Staking crypto) (KeyHash 'StakePool crypto)),
     stake :: !(Stake crypto),
     addrsRew :: !(Set (Credential 'Staking crypto)),
     totalStake :: !Integer,
@@ -272,7 +276,7 @@ instance (CC.Crypto crypto) => ToCBOR (FreeVars crypto) where
         pp_mv
       } =
       encode
-        ( Rec FreeVars !> mapEncode b !> mapEncode delegs !> To stake !> setEncode addrsRew
+        ( Rec FreeVars !> mapEncode b !> vMapEncode delegs !> To stake !> setEncode addrsRew
             !> To totalStake
             !> To activeStake
             !> To asc
@@ -288,7 +292,7 @@ instance (CC.Crypto crypto) => ToCBOR (FreeVars crypto) where
 instance (CC.Crypto crypto) => FromCBOR (FreeVars crypto) where
   fromCBOR =
     decode
-      ( RecD FreeVars <! mapDecode {- b -} <! mapDecode {- delegs -} <! From {- stake -} <! setDecode {- addrsRew -}
+      ( RecD FreeVars <! mapDecode {- b -} <! vMapDecode {- delegs -} <! From {- stake -} <! setDecode {- addrsRew -}
           <! From {- totalStake -}
           <! From {- activeStake -}
           <! From {- asc -}
@@ -332,7 +336,7 @@ rewardStakePool
     let hk = _poolId pparams
         blocksProduced = Map.lookup hk b
         actgr@(Stake s) = poolStake hk delegs stake
-        Coin pstake = fold s
+        Coin pstake = VMap.foldMap fromCompact s
         sigma = if totalStake == 0 then 0 else fromIntegral pstake % fromIntegral totalStake
         sigmaA = if activeStake == 0 then 0 else fromIntegral pstake % fromIntegral activeStake
         ls =
@@ -382,7 +386,7 @@ deriving instance Eq ans => Eq (RewardPulser c m ans)
 
 deriving instance Show ans => Show (RewardPulser c m ans)
 
-instance NoThunks (Pulser c) where
+instance Typeable c => NoThunks (Pulser c) where
   showTypeOf _ = "RewardPulser"
   wNoThunks ctxt (RSLP n free balance ans) =
     allNoThunks
diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rewards.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rewards.hs
index bec6c9780e5..3325d2b72ac 100644
--- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rewards.hs
+++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rewards.hs
@@ -18,6 +18,7 @@ module Cardano.Ledger.Shelley.Rewards
     PerformanceEstimate (..),
     NonMyopic (..),
     getTopRankedPools,
+    getTopRankedPoolsVMap,
     StakeShare (..),
     mkApparentPerformance,
     RewardType (..),
@@ -62,6 +63,7 @@ import Cardano.Ledger.Coin
     coinToRational,
     rationalToCoinViaFloor,
   )
+import Cardano.Ledger.Compactible (fromCompact)
 import Cardano.Ledger.Credential (Credential (..))
 import qualified Cardano.Ledger.Crypto as CC (Crypto)
 import Cardano.Ledger.Keys (KeyHash, KeyRole (..))
@@ -84,6 +86,7 @@ import Cardano.Slotting.Slot (EpochSize (..))
 import Control.DeepSeq (NFData)
 import Control.Provenance (ProvM, modifyM)
 import Data.Coders (Decode (..), Encode (..), decode, encode, (!>), (<!))
+import qualified Data.Compact.VMap as VMap
 import Data.Default.Class (Default, def)
 import Data.Foldable (find, fold)
 import Data.Function (on)
@@ -318,11 +321,33 @@ getTopRankedPools ::
   Map (KeyHash 'StakePool crypto) PerformanceEstimate ->
   Set (KeyHash 'StakePool crypto)
 getTopRankedPools rPot totalStake pp poolParams aps =
+  let pdata = Map.toAscList $ Map.intersectionWith (,) poolParams aps
+   in getTopRankedPoolsInternal rPot totalStake pp pdata
+
+getTopRankedPoolsVMap ::
+  (HasField "_a0" pp NonNegativeInterval, HasField "_nOpt" pp Natural) =>
+  Coin ->
+  Coin ->
+  pp ->
+  VMap.VMap VMap.VB VMap.VB (KeyHash 'StakePool crypto) (PoolParams crypto) ->
+  Map (KeyHash 'StakePool crypto) PerformanceEstimate ->
+  Set (KeyHash 'StakePool crypto)
+getTopRankedPoolsVMap rPot totalStake pp poolParams aps =
+  let pdata = [(kh, (pps, a)) | (kh, a) <- Map.toAscList aps, Just pps <- [VMap.lookup kh poolParams]]
+   in getTopRankedPoolsInternal rPot totalStake pp pdata
+
+getTopRankedPoolsInternal ::
+  (HasField "_a0" pp NonNegativeInterval, HasField "_nOpt" pp Natural) =>
+  Coin ->
+  Coin ->
+  pp ->
+  [(KeyHash 'StakePool crypto, (PoolParams crypto, PerformanceEstimate))] ->
+  Set (KeyHash 'StakePool crypto)
+getTopRankedPoolsInternal rPot totalStake pp pdata =
   Set.fromList $
     fst
       <$> take (fromIntegral $ getField @"_nOpt" pp) (sortBy (flip compare `on` snd) rankings)
   where
-    pdata = Map.toList $ Map.intersectionWith (,) poolParams aps
     rankings =
       [ ( hk,
           desirability (getField @"_a0" pp, getField @"_nOpt" pp) rPot pool ap totalStake
@@ -489,7 +514,7 @@ rewardOnePool
     where
       Coin ostake =
         Set.foldl'
-          (\c o -> c <> Map.findWithDefault mempty (KeyHashObj o) stake)
+          (\c o -> c <> maybe mempty fromCompact (VMap.lookup (KeyHashObj o) stake))
           mempty
           (_poolOwners pool)
       Coin pledge = _poolPledge pool
@@ -511,11 +536,12 @@ rewardOnePool
                   ( memberRew
                       poolR
                       pool
-                      (StakeShare (fromIntegral c % tot))
+                      (StakeShare (c % tot))
                       (StakeShare sigma)
                   )
             )
-            | (hk, Coin c) <- Map.toList stake,
+            | (hk, compactCoin) <- VMap.toAscList stake,
+              let Coin c = fromCompact compactCoin,
               notPoolOwner hk,
               hk `Set.member` addrsRew
           ]
diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/NewEpoch.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/NewEpoch.hs
index d2ef730e918..126bcb9462b 100644
--- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/NewEpoch.hs
+++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/NewEpoch.hs
@@ -22,6 +22,7 @@ where
 
 import Cardano.Ledger.BaseTypes
 import Cardano.Ledger.Coin
+import Cardano.Ledger.Compactible (Compactible (fromCompact))
 import qualified Cardano.Ledger.Core as Core
 import Cardano.Ledger.Credential (Credential)
 import Cardano.Ledger.Era (Crypto, Era)
@@ -38,9 +39,10 @@ import Cardano.Ledger.Slot
 import qualified Cardano.Ledger.Val as Val
 import Control.Provenance (runProvM)
 import Control.State.Transition
+import Data.Compact.VMap as VMap
 import Data.Default.Class (Default, def)
 import qualified Data.Map.Strict as Map
-import Data.Maybe (catMaybes)
+import Data.Ratio
 import Data.Set (Set)
 import GHC.Generics (Generic)
 import GHC.Records
@@ -171,16 +173,21 @@ newEpochTransition = do
 
 calculatePoolDistr :: SnapShot crypto -> PoolDistr crypto
 calculatePoolDistr (SnapShot (Stake stake) delegs poolParams) =
-  let Coin total = Map.foldl' (<>) mempty stake
+  let Coin total = VMap.foldMap fromCompact stake
+      -- total could be zero (in particular when shrinking)
+      nonZeroTotal = if total == 0 then 1 else total
       sd =
         Map.fromListWith (+) $
-          catMaybes
-            [ (,fromIntegral c / fromIntegral (if total == 0 then 1 else total))
-                <$> Map.lookup hk delegs -- TODO mgudemann total could be zero (in
-                -- particular when shrinking)
-              | (hk, Coin c) <- Map.toList stake
-            ]
-   in PoolDistr $ Map.intersectionWith IndividualPoolStake sd (Map.map _poolVrf poolParams)
+          [ (d, c % nonZeroTotal)
+            | (hk, compactCoin) <- VMap.toAscList stake,
+              let Coin c = fromCompact compactCoin,
+              Just d <- [VMap.lookup hk delegs]
+          ]
+   in PoolDistr $
+        Map.intersectionWith
+          IndividualPoolStake
+          sd
+          (toMap (VMap.map _poolVrf poolParams))
 
 instance
   ( UsesTxOut era,
diff --git a/eras/shelley/test-suite/cardano-ledger-shelley-test.cabal b/eras/shelley/test-suite/cardano-ledger-shelley-test.cabal
index 25b271924a9..b5620dc918f 100644
--- a/eras/shelley/test-suite/cardano-ledger-shelley-test.cabal
+++ b/eras/shelley/test-suite/cardano-ledger-shelley-test.cabal
@@ -95,6 +95,7 @@ library
     cardano-slotting,
     cborg,
     containers,
+    compact-map,
     data-default-class,
     deepseq,
     directory,
@@ -120,7 +121,7 @@ library
     time,
     transformers,
     tree-diff,
-    vector
+    vector,
 
 test-suite cardano-ledger-shelley-test
   import:             base, project-config
@@ -184,6 +185,7 @@ test-suite cardano-ledger-shelley-test
       cardano-slotting,
       cborg,
       containers,
+      compact-map,
       data-default-class,
       groups,
       hedgehog >= 1.0.4,
diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Serialisation/EraIndepGenerators.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Serialisation/EraIndepGenerators.hs
index 64cbfab56c6..49934f99553 100644
--- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Serialisation/EraIndepGenerators.hs
+++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Serialisation/EraIndepGenerators.hs
@@ -3,11 +3,14 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE QuantifiedConstraints #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -55,7 +58,7 @@ import Cardano.Ledger.BaseTypes
     textToDns,
     textToUrl,
   )
-import Cardano.Ledger.Coin (DeltaCoin (..))
+import Cardano.Ledger.Coin (CompactForm (..), DeltaCoin (..))
 import qualified Cardano.Ledger.Core as Core
 import Cardano.Ledger.Crypto (DSIGN)
 import qualified Cardano.Ledger.Crypto as CC (Crypto)
@@ -110,6 +113,7 @@ import Control.SetAlgebra (biMapFromList)
 import Control.State.Transition (STS (State))
 import qualified Data.ByteString.Char8 as BS
 import Data.Coerce (coerce)
+import qualified Data.Compact.VMap as VMap
 import Data.IP (IPv4, IPv6, toIPv4, toIPv6)
 import qualified Data.Map.Strict as Map (empty, fromList)
 import Data.Maybe (fromJust)
@@ -571,6 +575,13 @@ instance
       <*> arbitrary
       <*> arbitrary
 
+instance
+  (Arbitrary k, Arbitrary v, Ord k, VMap.Vector kv k, VMap.Vector vv v) =>
+  Arbitrary (VMap.VMap kv vv k v)
+  where
+  arbitrary = VMap.fromMap <$> arbitrary
+  shrink = fmap VMap.fromMap . shrink . VMap.toMap
+
 instance Arbitrary RewardType where
   arbitrary = genericArbitraryU
   shrink = genericShrink
@@ -615,6 +626,8 @@ instance CC.Crypto crypto => Arbitrary (SnapShots crypto) where
 instance Arbitrary PerformanceEstimate where
   arbitrary = PerformanceEstimate <$> arbitrary
 
+deriving instance Arbitrary (CompactForm Coin)
+
 instance CC.Crypto crypto => Arbitrary (Stake crypto) where
   arbitrary = Stake <$> arbitrary
 
diff --git a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/PoolLifetime.hs b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/PoolLifetime.hs
index 7e15b7ef887..987cebc209c 100644
--- a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/PoolLifetime.hs
+++ b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/PoolLifetime.hs
@@ -1,6 +1,9 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 
@@ -15,6 +18,7 @@ module Test.Cardano.Ledger.Shelley.Examples.PoolLifetime
     makePulser',
     makeCompletedPulser,
     poolLifetimeExample,
+    mkStake,
   )
 where
 
@@ -30,10 +34,11 @@ import Cardano.Ledger.BaseTypes
   )
 import Cardano.Ledger.Block (Block, bheader)
 import Cardano.Ledger.Coin (Coin (..), DeltaCoin (..), addDeltaCoin, toDeltaCoin)
-import Cardano.Ledger.Credential (Ptr (..))
+import Cardano.Ledger.Compactible
+import Cardano.Ledger.Credential (Credential, Ptr (..))
 import qualified Cardano.Ledger.Crypto as Cr
 import Cardano.Ledger.Era (Crypto (..))
-import Cardano.Ledger.Keys (asWitness, coerceKeyRole)
+import Cardano.Ledger.Keys (KeyRole (..), asWitness, coerceKeyRole)
 import Cardano.Ledger.PoolDistr
   ( IndividualPoolStake (..),
     PoolDistr (..),
@@ -97,13 +102,14 @@ import qualified Cardano.Ledger.Val as Val
 import Cardano.Protocol.TPraos.BHeader (BHeader, bhHash, hashHeaderToNonce)
 import Cardano.Protocol.TPraos.OCert (KESPeriod (..))
 import Control.Provenance (runProvM)
+import qualified Data.Compact.VMap as VMap
 import Data.Default.Class (def)
-import Data.Foldable (fold)
 import Data.Group (invert)
 import qualified Data.Map.Strict as Map
 import Data.Ratio ((%))
 import qualified Data.Sequence.Strict as StrictSeq
 import qualified Data.Set as Set
+import GHC.Exts (fromList)
 import GHC.Stack (HasCallStack)
 import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (C_Crypto, ExMock)
 import Test.Cardano.Ledger.Shelley.Examples (CHAINExample (..), testCHAINExample)
@@ -140,10 +146,24 @@ import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.HUnit (Assertion, testCase, (@?=))
 
 aliceInitCoin :: Coin
-aliceInitCoin = Coin $ 10 * 1000 * 1000 * 1000 * 1000 * 1000
+aliceInitCoin = Coin 10_000_000_000_000_000
 
 bobInitCoin :: Coin
-bobInitCoin = Coin $ 1 * 1000 * 1000 * 1000 * 1000 * 1000
+bobInitCoin = Coin 1_000_000_000_000_000
+
+toCompactCoinError :: Coin -> CompactForm Coin
+toCompactCoinError c =
+  case toCompact c of
+    Nothing -> error $ "Invalid coin: " <> show c
+    Just compactCoin -> compactCoin
+
+mkStake ::
+  [ ( Credential 'Staking crypto,
+      Coin
+    )
+  ] ->
+  EB.Stake crypto
+mkStake = EB.Stake . GHC.Exts.fromList . map (fmap toCompactCoinError)
 
 initUTxO :: Cr.Crypto c => UTxO (ShelleyEra c)
 initUTxO =
@@ -413,17 +433,15 @@ snapEx3 :: Cr.Crypto c => EB.SnapShot c
 snapEx3 =
   EB.SnapShot
     { EB._stake =
-        EB.Stake $
-          Map.fromList
-            [ (Cast.aliceSHK, aliceCoinEx2Base <> aliceCoinEx2Ptr),
-              (Cast.bobSHK, bobInitCoin)
-            ],
-      EB._delegations =
-        Map.fromList
-          [ (Cast.aliceSHK, hk Cast.alicePoolKeys),
-            (Cast.bobSHK, hk Cast.alicePoolKeys)
+        mkStake
+          [ (Cast.aliceSHK, aliceCoinEx2Base <> aliceCoinEx2Ptr),
+            (Cast.bobSHK, bobInitCoin)
           ],
-      EB._poolParams = Map.singleton (hk Cast.alicePoolKeys) Cast.alicePoolParams
+      EB._delegations =
+        [ (Cast.aliceSHK, hk Cast.alicePoolKeys),
+          (Cast.bobSHK, hk Cast.alicePoolKeys)
+        ],
+      EB._poolParams = [(hk Cast.alicePoolKeys, Cast.alicePoolParams)]
     }
 
 expectedStEx3 ::
@@ -558,19 +576,17 @@ snapEx5 :: forall c. Cr.Crypto c => EB.SnapShot c
 snapEx5 =
   EB.SnapShot
     { EB._stake =
-        EB.Stake $
-          Map.fromList
-            [ (Cast.aliceSHK, aliceCoinEx4Base <> aliceCoinEx2Ptr),
-              (Cast.carlSHK, carlMIR),
-              (Cast.bobSHK, bobInitCoin)
-            ],
-      EB._delegations =
-        Map.fromList
-          [ (Cast.aliceSHK, hk Cast.alicePoolKeys),
-            (Cast.carlSHK, hk Cast.alicePoolKeys),
-            (Cast.bobSHK, hk Cast.alicePoolKeys)
+        mkStake
+          [ (Cast.aliceSHK, aliceCoinEx4Base <> aliceCoinEx2Ptr),
+            (Cast.carlSHK, carlMIR),
+            (Cast.bobSHK, bobInitCoin)
           ],
-      EB._poolParams = Map.singleton (hk Cast.alicePoolKeys) Cast.alicePoolParams
+      EB._delegations =
+        [ (Cast.aliceSHK, hk Cast.alicePoolKeys),
+          (Cast.carlSHK, hk Cast.alicePoolKeys),
+          (Cast.bobSHK, hk Cast.alicePoolKeys)
+        ],
+      EB._poolParams = [(hk Cast.alicePoolKeys, Cast.alicePoolParams)]
     }
 
 pdEx5 :: forall c. Cr.Crypto c => PoolDistr c
@@ -873,12 +889,11 @@ snapEx9 :: forall c. Cr.Crypto c => EB.SnapShot c
 snapEx9 =
   snapEx5
     { EB._stake =
-        EB.Stake $
-          Map.fromList
-            [ (Cast.bobSHK, bobInitCoin <> bobRAcnt8),
-              (Cast.aliceSHK, aliceCoinEx4Base <> aliceCoinEx2Ptr <> aliceRAcnt8),
-              (Cast.carlSHK, carlMIR)
-            ]
+        mkStake
+          [ (Cast.bobSHK, bobInitCoin <> bobRAcnt8),
+            (Cast.aliceSHK, aliceCoinEx4Base <> aliceCoinEx2Ptr <> aliceRAcnt8),
+            (Cast.carlSHK, carlMIR)
+          ]
     }
 
 expectedStEx9 :: forall c. (ExMock (Crypto (ShelleyEra c))) => ChainState (ShelleyEra c)
@@ -1026,9 +1041,10 @@ alicePerfEx11 = applyDecay decayFactor alicePerfEx8 <> epoch4Likelihood
     epoch4Likelihood = likelihood blocks t (epochSize $ EpochNo 4)
     blocks = 0
     t = leaderProbability f relativeStake (_d ppEx)
-    (Coin stake) = fold (EB.unStake . EB._stake $ snapEx5 @c) -- everyone has delegated to Alice's Pool
+    -- everyone has delegated to Alice's Pool
+    Coin stake = VMap.foldMap fromCompact (EB.unStake . EB._stake $ snapEx5 @c)
     relativeStake = fromRational (stake % supply)
-    (Coin supply) = maxLLSupply <-> reserves12
+    Coin supply = maxLLSupply <-> reserves12
     f = activeSlotCoeff testGlobals
 
 nonMyopicEx11 :: forall c. Cr.Crypto c => NonMyopic c
@@ -1094,16 +1110,14 @@ snapEx12 :: forall c. Cr.Crypto c => EB.SnapShot c
 snapEx12 =
   snapEx9
     { EB._stake =
-        EB.Stake $
-          Map.fromList
-            [ (Cast.aliceSHK, aliceRAcnt8 <> aliceCoinEx2Ptr <> aliceCoinEx11Ptr),
-              (Cast.carlSHK, carlMIR)
-            ],
+        mkStake
+          [ (Cast.aliceSHK, aliceRAcnt8 <> aliceCoinEx2Ptr <> aliceCoinEx11Ptr),
+            (Cast.carlSHK, carlMIR)
+          ],
       EB._delegations =
-        Map.fromList
-          [ (Cast.aliceSHK, hk Cast.alicePoolKeys),
-            (Cast.carlSHK, hk Cast.alicePoolKeys)
-          ]
+        [ (Cast.aliceSHK, hk Cast.alicePoolKeys),
+          (Cast.carlSHK, hk Cast.alicePoolKeys)
+        ]
     }
 
 expectedStEx12 :: forall c. (ExMock (Crypto (ShelleyEra c))) => ChainState (ShelleyEra c)
diff --git a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/PoolReReg.hs b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/PoolReReg.hs
index e185c7380a7..d665cc81ec7 100644
--- a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/PoolReReg.hs
+++ b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/PoolReReg.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 
@@ -293,7 +294,7 @@ blockEx3 =
 
 snapEx3 :: Cr.Crypto c => SnapShot c
 snapEx3 =
-  emptySnapShot {_poolParams = Map.singleton (hk Cast.alicePoolKeys) Cast.alicePoolParams}
+  emptySnapShot {_poolParams = [(hk Cast.alicePoolKeys, Cast.alicePoolParams)]}
 
 expectedStEx3 :: forall c. (ExMock (Crypto (ShelleyEra c))) => ChainState (ShelleyEra c)
 expectedStEx3 =
diff --git a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/TwoPools.hs b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/TwoPools.hs
index a455376ab64..55055616f7d 100644
--- a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/TwoPools.hs
+++ b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/TwoPools.hs
@@ -3,6 +3,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 
@@ -121,7 +122,7 @@ import Test.Cardano.Ledger.Shelley.Examples.Init
     nonce0,
     ppEx,
   )
-import Test.Cardano.Ledger.Shelley.Examples.PoolLifetime (makeCompletedPulser)
+import Test.Cardano.Ledger.Shelley.Examples.PoolLifetime (makeCompletedPulser, mkStake)
 import Test.Cardano.Ledger.Shelley.Generator.Core
   ( AllIssuerKeys (..),
     NatNonce (..),
@@ -365,23 +366,20 @@ snapEx3 :: ExMock c => EB.SnapShot c
 snapEx3 =
   EB.SnapShot
     { EB._stake =
-        EB.Stake $
-          Map.fromList
-            [ (Cast.aliceSHK, aliceCoinEx1),
-              (Cast.bobSHK, bobInitCoin),
-              (Cast.carlSHK, carlInitCoin)
-            ],
-      EB._delegations =
-        Map.fromList
-          [ (Cast.aliceSHK, hk Cast.alicePoolKeys),
-            (Cast.bobSHK, hk Cast.bobPoolKeys),
-            (Cast.carlSHK, hk Cast.alicePoolKeys)
+        mkStake
+          [ (Cast.aliceSHK, aliceCoinEx1),
+            (Cast.bobSHK, bobInitCoin),
+            (Cast.carlSHK, carlInitCoin)
           ],
+      EB._delegations =
+        [ (Cast.aliceSHK, hk Cast.alicePoolKeys),
+          (Cast.bobSHK, hk Cast.bobPoolKeys),
+          (Cast.carlSHK, hk Cast.alicePoolKeys)
+        ],
       EB._poolParams =
-        Map.fromList
-          [ (hk Cast.alicePoolKeys, alicePoolParams'),
-            (hk Cast.bobPoolKeys, bobPoolParams')
-          ]
+        [ (hk Cast.alicePoolKeys, alicePoolParams'),
+          (hk Cast.bobPoolKeys, bobPoolParams')
+        ]
     }
 
 expectedStEx3 ::
@@ -482,13 +480,13 @@ blockEx5 =
     (mkOCert Cast.alicePoolKeys 0 (KESPeriod 10))
 
 activeStakeEx5 :: Integer
-activeStakeEx5 = sum $ unCoin <$> [aliceCoinEx1, bobInitCoin, carlInitCoin]
+activeStakeEx5 = sum $ map unCoin [aliceCoinEx1, bobInitCoin, carlInitCoin]
 
 alicePoolStake :: Rational
 alicePoolStake = (unCoin aliceCoinEx1 + unCoin carlInitCoin) % activeStakeEx5
 
 bobPoolStake :: Rational
-bobPoolStake = (unCoin bobInitCoin) % activeStakeEx5
+bobPoolStake = unCoin bobInitCoin % activeStakeEx5
 
 pdEx5 :: forall c. CryptoClass.Crypto c => PoolDistr c
 pdEx5 =
diff --git a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Rewards.hs b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Rewards.hs
index 7e653a856fb..f8c6a5940f5 100644
--- a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Rewards.hs
+++ b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Rewards.hs
@@ -35,6 +35,7 @@ import Cardano.Ledger.BaseTypes
     mkActiveSlotCoeff,
   )
 import Cardano.Ledger.Coin (Coin (..), DeltaCoin (..), rationalToCoinViaFloor, toDeltaCoin)
+import Cardano.Ledger.Compactible
 import qualified Cardano.Ledger.Core as Core
 import Cardano.Ledger.Credential (Credential (..))
 import Cardano.Ledger.Crypto (VRF)
@@ -104,6 +105,7 @@ import Control.Monad (replicateM)
 import Control.Monad.Trans.Reader (asks, runReader)
 import Control.Provenance (ProvM, preservesJust, preservesNothing, runProvM, runWithProvM)
 import Control.State.Transition.Trace (SourceSignalTarget (..), sourceSignalTargets)
+import qualified Data.Compact.VMap as VMap
 import Data.Default.Class (Default (def))
 import Data.Foldable (fold)
 import Data.Map (Map)
@@ -116,6 +118,7 @@ import qualified Data.Sequence.Strict as StrictSeq
 import Data.Set (Set)
 import qualified Data.Set as Set
 import Data.Word (Word64)
+import GHC.Stack
 import Numeric.Natural (Natural)
 import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (C)
 import Test.Cardano.Ledger.Shelley.Generator.Core (genCoin, genNatural)
@@ -289,6 +292,10 @@ genBlocksMade pools = BlocksMade . Map.fromList <$> mapM f pools
 
 -- Properties --
 
+toCompactCoinError :: HasCallStack => Coin -> CompactForm Coin
+toCompactCoinError c =
+  fromMaybe (error $ "Invalid Coin: " <> show c) $ toCompact c
+
 rewardsBoundedByPot :: forall era. Era era => Proxy era -> Property
 rewardsBoundedByPot _ = property $ do
   numPools <- choose (0, maxNumPools)
@@ -307,12 +314,8 @@ rewardsBoundedByPot _ = property $ do
             Map.fromList $ (,_poolId params) <$> Map.keys members
       rewardAcnts = Set.fromList $ Map.keys delegs
       poolParams =
-        Map.fromList $
-          fmap
-            ( \PoolInfo {params} ->
-                (_poolId params, params)
-            )
-            pools
+        VMap.fromList
+          [(_poolId params, params) | PoolInfo {params} <- pools]
       totalLovelace = undelegatedLovelace <> fold stake
       slotsPerEpoch = EpochSize . fromIntegral $ totalBlocks + silentSlots
       (RewardAns rs _) =
@@ -324,8 +327,8 @@ rewardsBoundedByPot _ = property $ do
               rewardPot
               rewardAcnts
               poolParams
-              (Stake stake)
-              delegs
+              (Stake (VMap.fromMap (toCompactCoinError <$> stake)))
+              (VMap.fromMap delegs)
               totalLovelace
               asc
               slotsPerEpoch
@@ -374,10 +377,11 @@ rewardsProvenance _ = do
   silentSlots <- genNatural 0 (3 * totalBlocks) -- the '3 * sum blocks' is pretty arbitrary
   let stake = foldMap members pools
       delegs =
-        foldMap (\PoolInfo {params, members} -> _poolId params <$ members) pools
-      rewardAcnts = Set.fromList $ Map.keys delegs
+        VMap.fromMap $
+          foldMap (\PoolInfo {params, members} -> _poolId params <$ members) pools
+      rewardAcnts = Set.fromDistinctAscList $ VMap.keys delegs
       poolParams =
-        Map.fromList [(_poolId params, params) | PoolInfo {params} <- pools]
+        VMap.fromList [(_poolId params, params) | PoolInfo {params} <- pools]
       totalLovelace = undelegatedLovelace <> fold stake
       slotsPerEpoch = EpochSize . fromIntegral $ totalBlocks + silentSlots
       (_, prov) =
@@ -389,7 +393,7 @@ rewardsProvenance _ = do
               rewardPot
               rewardAcnts
               poolParams
-              (Stake stake)
+              (Stake (VMap.fromMap (fmap toCompactCoinError stake)))
               delegs
               totalLovelace
               asc
@@ -507,7 +511,7 @@ rewardOnePool
     where
       Coin ostake =
         Set.foldl'
-          (\c o -> c <> Map.findWithDefault mempty (KeyHashObj o) stake)
+          (\c o -> maybe c (mappend c . fromCompact) $ VMap.lookup (KeyHashObj o) stake)
           mempty
           (_poolOwners pool)
       Coin pledge = _poolPledge pool
@@ -525,10 +529,10 @@ rewardOnePool
               memberRew
                 poolR
                 pool
-                (StakeShare (fromIntegral c % tot))
+                (StakeShare (unCoin (fromCompact c) % tot))
                 (StakeShare sigma)
             )
-            | (hk, Coin c) <- Map.toList stake,
+            | (hk, c) <- VMap.toAscList stake,
               notPoolOwner hk
           ]
       notPoolOwner (KeyHashObj hk) = hk `Set.notMember` _poolOwners pool
@@ -553,9 +557,9 @@ rewardOld ::
   BlocksMade (Crypto era) ->
   Coin ->
   Set.Set (Credential 'Staking (Crypto era)) ->
-  Map (KeyHash 'StakePool (Crypto era)) (PoolParams (Crypto era)) ->
+  VMap.VMap VMap.VB VMap.VB (KeyHash 'StakePool (Crypto era)) (PoolParams (Crypto era)) ->
   Stake (Crypto era) ->
-  Map (Credential 'Staking (Crypto era)) (KeyHash 'StakePool (Crypto era)) ->
+  VMap.VMap VMap.VB VMap.VB (Credential 'Staking (Crypto era)) (KeyHash 'StakePool (Crypto era)) ->
   Coin ->
   ActiveSlotCoeff ->
   EpochSize ->
@@ -577,15 +581,15 @@ rewardOld
   slotsPerEpoch = (rewards', hs)
     where
       totalBlocks = sum b
-      Coin activeStake = fold . unStake $ stake
+      Coin activeStake = VMap.foldMap fromCompact $ unStake stake
       results :: [(KeyHash 'StakePool (Crypto era), Maybe (Map (Credential 'Staking (Crypto era)) Coin), Likelihood)]
       results = do
-        (hk, pparams) <- Map.toList poolParams
+        (hk, pparams) <- VMap.toAscList poolParams
         let sigma = if totalStake == 0 then 0 else fromIntegral pstake % fromIntegral totalStake
             sigmaA = if activeStake == 0 then 0 else fromIntegral pstake % fromIntegral activeStake
             blocksProduced = Map.lookup hk b
             actgr@(Stake s) = poolStake hk delegs stake
-            Coin pstake = fold s
+            Coin pstake = VMap.foldMap fromCompact s
             rewardMap = case blocksProduced of
               Nothing -> Nothing -- This is equivalent to calling rewarOnePool with n = 0
               Just n ->
@@ -751,9 +755,9 @@ reward ::
   BlocksMade crypto ->
   Coin ->
   Set (Credential 'Staking crypto) ->
-  Map (KeyHash 'StakePool crypto) (PoolParams crypto) ->
+  VMap.VMap VMap.VB VMap.VB (KeyHash 'StakePool crypto) (PoolParams crypto) ->
   Stake crypto ->
-  Map (Credential 'Staking crypto) (KeyHash 'StakePool crypto) ->
+  VMap.VMap VMap.VB VMap.VB (Credential 'Staking crypto) (KeyHash 'StakePool crypto) ->
   Coin ->
   ActiveSlotCoeff ->
   EpochSize ->
@@ -771,7 +775,7 @@ reward
   slotsPerEpoch = completeM pulser
     where
       totalBlocks = sum b
-      Coin activeStake = fold . unStake $ stake
+      Coin activeStake = VMap.foldMap fromCompact $ unStake stake
       free =
         FreeVars
           { b,
@@ -789,8 +793,9 @@ reward
             pp_nOpt,
             pp_mv
           }
+      pps = StrictSeq.fromList $ VMap.elems poolParams
       pulser :: Pulser crypto
-      pulser = RSLP 2 free (StrictSeq.fromList $ Map.elems poolParams) (RewardAns Map.empty Map.empty)
+      pulser = RSLP 2 free pps (RewardAns Map.empty Map.empty)
 
 -- ==================================================================
 
diff --git a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Serialisation/Golden/Encoding.hs b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Serialisation/Golden/Encoding.hs
index d48e97dcdcf..34bbe5fadf2 100644
--- a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Serialisation/Golden/Encoding.hs
+++ b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Serialisation/Golden/Encoding.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -41,7 +42,7 @@ import Cardano.Ledger.BaseTypes
     textToUrl,
   )
 import Cardano.Ledger.Block (Block (..))
-import Cardano.Ledger.Coin (Coin (..), DeltaCoin (..))
+import Cardano.Ledger.Coin (Coin (..), CompactForm (..), DeltaCoin (..))
 import Cardano.Ledger.Credential (Credential (..), StakeReference (..))
 import qualified Cardano.Ledger.Crypto as CC
 import Cardano.Ledger.Era (Crypto (..))
@@ -426,7 +427,7 @@ tests =
     "CBOR Serialization Tests (Encoding)"
     [ checkEncodingCBOR
         "list"
-        [1 :: Integer]
+        ([1] :: [Integer])
         (T (TkListBegin . TkInteger 1 . TkBreak)),
       checkEncodingCBOR
         "set"
@@ -1204,7 +1205,7 @@ tests =
             <> S (Coin 1)
             <> S (Coin 2)
         ),
-      let stk = Map.singleton (testStakeCred @C_Crypto) (Coin 13)
+      let stk = [(testStakeCred @C_Crypto, CompactCoin 13)]
        in checkEncodingCBOR
             "stake"
             (Stake stk)
@@ -1214,18 +1215,18 @@ tests =
             ),
       let mark =
             SnapShot
-              (Stake $ Map.singleton (testStakeCred @C_Crypto) (Coin 11))
-              (Map.singleton (testStakeCred @C_Crypto) (hashKey $ vKey testStakePoolKey))
+              (Stake [(testStakeCred @C_Crypto, CompactCoin 11)])
+              [(testStakeCred @C_Crypto, hashKey $ vKey testStakePoolKey)]
               ps
           set =
             SnapShot
-              (Stake $ Map.singleton (KeyHashObj testKeyHash2) (Coin 22))
-              (Map.singleton (testStakeCred @C_Crypto) (hashKey $ vKey testStakePoolKey))
+              (Stake [(KeyHashObj testKeyHash2, CompactCoin 22)])
+              [(testStakeCred @C_Crypto, hashKey $ vKey testStakePoolKey)]
               ps
           go =
             SnapShot
-              (Stake $ Map.singleton (testStakeCred @C_Crypto) (Coin 33))
-              (Map.singleton (testStakeCred @C_Crypto) (hashKey $ vKey testStakePoolKey))
+              (Stake [(testStakeCred @C_Crypto, CompactCoin 33)])
+              [(testStakeCred @C_Crypto, hashKey $ vKey testStakePoolKey)]
               ps
           params =
             PoolParams
@@ -1244,7 +1245,7 @@ tests =
                         _poolMDHash = BS.pack "{}"
                       }
               }
-          ps = Map.singleton (hashKey $ vKey testStakePoolKey) params
+          ps = [(hashKey $ vKey testStakePoolKey, params)]
           fs = Coin 123
        in checkEncodingCBOR
             "snapshots"
@@ -1259,18 +1260,18 @@ tests =
           ac = AccountState (Coin 100) (Coin 100)
           mark =
             SnapShot
-              (Stake $ Map.singleton (testStakeCred @C_Crypto) (Coin 11))
-              (Map.singleton (testStakeCred @C_Crypto) (hashKey $ vKey testStakePoolKey))
+              (Stake [(testStakeCred @C_Crypto, CompactCoin 11)])
+              [(testStakeCred @C_Crypto, hashKey $ vKey testStakePoolKey)]
               ps
           set =
             SnapShot
-              (Stake $ Map.singleton (KeyHashObj testKeyHash2) (Coin 22))
-              (Map.singleton (testStakeCred @C_Crypto) (hashKey $ vKey testStakePoolKey))
+              (Stake [(KeyHashObj testKeyHash2, CompactCoin 22)])
+              [(testStakeCred @C_Crypto, hashKey $ vKey testStakePoolKey)]
               ps
           go =
             SnapShot
-              (Stake $ Map.singleton (testStakeCred @C_Crypto) (Coin 33))
-              (Map.singleton (testStakeCred @C_Crypto) (hashKey $ vKey testStakePoolKey))
+              (Stake [(testStakeCred @C_Crypto, CompactCoin 33)])
+              [(testStakeCred @C_Crypto, hashKey $ vKey testStakePoolKey)]
               ps
           params =
             PoolParams
@@ -1289,7 +1290,7 @@ tests =
                         _poolMDHash = BS.pack "{}"
                       }
               }
-          ps = Map.singleton (hashKey $ vKey testStakePoolKey) params
+          ps = [(hashKey $ vKey testStakePoolKey, params)]
           fs = Coin 123
           ss = SnapShots mark set go fs
           ls = def
diff --git a/libs/cardano-ledger-core/cardano-ledger-core.cabal b/libs/cardano-ledger-core/cardano-ledger-core.cabal
index 1421a0aa5fb..5d1d214a556 100644
--- a/libs/cardano-ledger-core/cardano-ledger-core.cabal
+++ b/libs/cardano-ledger-core/cardano-ledger-core.cabal
@@ -87,6 +87,7 @@ library
     quiet,
     scientific,
     non-integral,
+    primitive,
     small-steps,
     strict-containers,
     text,
diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Coin.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Coin.hs
index 79b049ed05c..3786316cd14 100644
--- a/libs/cardano-ledger-core/src/Cardano/Ledger/Coin.hs
+++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Coin.hs
@@ -1,9 +1,11 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UnboxedTuples #-}
 
 module Cardano.Ledger.Coin
   ( Coin (..),
@@ -27,6 +29,7 @@ import Data.Aeson (FromJSON, ToJSON)
 import Data.Group (Abelian, Group (..))
 import Data.Monoid (Sum (..))
 import Data.PartialOrd (PartialOrd)
+import Data.Primitive.Types
 import Data.Typeable (Typeable)
 import Data.Word (Word64)
 import GHC.Generics (Generic)
@@ -75,7 +78,7 @@ rationalToCoinViaCeiling = Coin . ceiling
 
 instance Compactible Coin where
   newtype CompactForm Coin = CompactCoin Word64
-    deriving (Eq, Show, NoThunks, NFData, Typeable, HeapWords)
+    deriving (Eq, Show, NoThunks, NFData, Typeable, HeapWords, Prim)
 
   toCompact (Coin c) = CompactCoin <$> integerToWord64 c
   fromCompact (CompactCoin c) = word64ToCoin c
@@ -86,6 +89,7 @@ integerToWord64 c
   | c < 0 = Nothing
   | c > fromIntegral (maxBound :: Word64) = Nothing
   | otherwise = Just $ fromIntegral c
+{-# INLINE integerToWord64 #-}
 
 instance ToCBOR (CompactForm Coin) where
   toCBOR (CompactCoin c) = toCBOR c
diff --git a/libs/cardano-ledger-pretty/cardano-ledger-pretty.cabal b/libs/cardano-ledger-pretty/cardano-ledger-pretty.cabal
index dfd020ee828..98a0dea6c40 100644
--- a/libs/cardano-ledger-pretty/cardano-ledger-pretty.cabal
+++ b/libs/cardano-ledger-pretty/cardano-ledger-pretty.cabal
@@ -48,6 +48,7 @@ library
     cardano-protocol-tpraos,
     cardano-slotting,
     containers,
+    compact-map,
     iproute,
     mtl,
     plutus-ledger-api,
diff --git a/libs/cardano-ledger-pretty/src/Cardano/Ledger/Pretty.hs b/libs/cardano-ledger-pretty/src/Cardano/Ledger/Pretty.hs
index 55a8c65c6d8..99c7d173f8f 100644
--- a/libs/cardano-ledger-pretty/src/Cardano/Ledger/Pretty.hs
+++ b/libs/cardano-ledger-pretty/src/Cardano/Ledger/Pretty.hs
@@ -173,6 +173,7 @@ import Control.SetAlgebra (forwards)
 import Control.State.Transition (STS (State))
 import qualified Data.ByteString as Long (ByteString)
 import qualified Data.ByteString.Lazy as Lazy (ByteString, toStrict)
+import qualified Data.Compact.VMap as VMap
 import Data.IP (IPv4, IPv6)
 import qualified Data.Map.Strict as Map (Map, toList)
 import Data.MemoBytes (MemoBytes (..))
@@ -374,12 +375,20 @@ ppMap' name kf vf m =
 ppMap :: (k -> PDoc) -> (v -> PDoc) -> Map.Map k v -> PDoc
 ppMap = ppMap' (text "Map")
 
+ppVMap ::
+  (VMap.Vector kv k, VMap.Vector vv v) =>
+  (k -> PDoc) ->
+  (v -> PDoc) ->
+  VMap.VMap kv vv k v ->
+  PDoc
+ppVMap pk pv = ppMap' (text "VMap") pk pv . VMap.toMap
+
 class PrettyA t where
   prettyA :: t -> PDoc
 
--- =====================================================================================================
+-- =============================================================================
 -- END HELPER FUNCTIONS
--- ================================= ====================================================================
+-- =============================================================================
 
 ppLastAppliedBlock :: LastAppliedBlock c -> PDoc
 ppLastAppliedBlock (LastAppliedBlock blkNo slotNo hh) =
@@ -511,7 +520,7 @@ ppFreeVars (FreeVars b1 del stake1 addrs total active asc1 blocks r1 slots d a0
   ppRecord
     "FreeVars"
     [ ("b", ppMap ppKeyHash ppNatural b1),
-      ("delegs", ppMap ppCredential ppKeyHash del),
+      ("delegs", ppVMap ppCredential ppKeyHash del),
       ("stake", ppStake stake1),
       ("addrsRew", ppSet ppCredential addrs),
       ("totalStake", ppInteger total),
@@ -801,7 +810,8 @@ instance PrettyA Likelihood where
 -- Cardano.Ledger.Shelley.EpochBoundary
 
 ppStake :: Stake crypto -> PDoc
-ppStake (Stake m) = ppMap' (text "Stake") ppCredential ppCoin m
+ppStake (Stake m) =
+  ppMap' (text "Stake") ppCredential (ppCoin . fromCompact) (VMap.toMap m)
 
 ppBlocksMade :: BlocksMade crypto -> PDoc
 ppBlocksMade (BlocksMade m) = ppMap' (text "BlocksMade") ppKeyHash ppNatural m
@@ -811,8 +821,8 @@ ppSnapShot (SnapShot st deleg params) =
   ppRecord
     "SnapShot"
     [ ("stake", ppStake st),
-      ("delegations", ppMap ppCredential ppKeyHash deleg),
-      ("poolParams", ppMap ppKeyHash ppPoolParams params)
+      ("delegations", ppVMap ppCredential ppKeyHash deleg),
+      ("poolParams", ppVMap ppKeyHash ppPoolParams params)
     ]
 
 ppSnapShots :: SnapShots crypto -> PDoc
diff --git a/libs/compact-map/compact-map.cabal b/libs/compact-map/compact-map.cabal
index 60585abd95c..6b762d3023e 100644
--- a/libs/compact-map/compact-map.cabal
+++ b/libs/compact-map/compact-map.cabal
@@ -31,9 +31,13 @@ library
 
   exposed-modules:     Data.Compact.KeyMap
                      , Data.Compact.HashMap
+                     , Data.Compact.VMap
   other-modules:       Data.Compact.Class
+                     , Data.Compact.KVVector
   build-depends:       base >=4.11 && <5
                      , array
+                     , cardano-binary
+                     , cardano-prelude
                      , containers
                      , cardano-crypto-class
                      , deepseq
@@ -41,7 +45,9 @@ library
                      , primitive
                      , random
                      , text
-                     , cardano-prelude
+                     , nothunks
+                     , vector
+                     , vector-algorithms
   hs-source-dirs:      src
 
 test-suite tests
@@ -50,14 +56,16 @@ test-suite tests
   hs-source-dirs:      test
   main-is:             Main.hs
   other-modules:       Test.Compact.KeyMap
+                     , Test.Compact.VMap
   type:                exitcode-stdio-1.0
   default-language:    Haskell2010
   build-depends:       base
-                     -- , containers
+                     , containers
                      , tasty
                      -- , tasty-expected-failure
                      , tasty-quickcheck
                      -- , tasty-hunit
                      , compact-map
                      , QuickCheck
+                     , quickcheck-classes-base
   ghc-options:        -threaded
diff --git a/libs/compact-map/src/Data/Compact/KVVector.hs b/libs/compact-map/src/Data/Compact/KVVector.hs
new file mode 100644
index 00000000000..1cdbcc0187d
--- /dev/null
+++ b/libs/compact-map/src/Data/Compact/KVVector.hs
@@ -0,0 +1,433 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.Compact.KVVector
+  ( VG.Vector,
+    VGM.MVector,
+    KVVector (..),
+    KVMVector,
+    toMap,
+    fromMap,
+    fromAscList,
+    fromAscListN,
+    fromAscListWithKey,
+    fromAscListWithKeyN,
+    fromDistinctAscList,
+    fromDistinctAscListN,
+    fromList,
+    fromListN,
+    mapValsKVVector,
+    mapWithKeyKVVector,
+    lookupKVVector,
+    lookupDefaultKVVector,
+    sortAscKVMVector,
+    internKVVectorMaybe,
+    normalize,
+    normalizeM,
+  )
+where
+
+import Cardano.Binary
+import Control.Applicative
+import Control.DeepSeq
+import Control.Monad
+import Control.Monad.Primitive
+import Control.Monad.ST
+import Data.Kind
+import qualified Data.List.NonEmpty as NE
+import qualified Data.Map.Strict as Map
+import Data.Maybe as Maybe
+import Data.Semigroup
+import Data.Typeable
+import Data.Vector.Algorithms.Merge
+import qualified Data.Vector.Generic as VG
+import qualified Data.Vector.Generic.Mutable as VGM
+import qualified Data.Vector.Primitive as VP
+import qualified Data.Vector.Storable as VS
+import qualified GHC.Exts as Exts
+import GHC.Generics
+import NoThunks.Class
+
+-- | Convert a __sorted__ key/value vector into a `Map.Map`
+toMap ::
+  (VG.Vector kv k, VG.Vector vv v) =>
+  KVVector kv vv (k, v) ->
+  Map.Map k v
+toMap = Map.fromDistinctAscList . VG.toList
+
+-- | Convert a `Map.Map` into a sorted key/value vector.
+fromMap ::
+  (VG.Vector kv k, VG.Vector vv v) => Map.Map k v -> KVVector kv vv (k, v)
+fromMap m = fromDistinctAscListN (Map.size m) $ Map.toAscList m
+
+-- | Convert a possibly unsorted assoc list into a KVVector.
+fromList ::
+  (VG.Vector kv k, VG.Vector vv v, Ord k) =>
+  [(k, v)] ->
+  KVVector kv vv (k, v)
+fromList xs = VG.create $ do
+  mv <- VGM.unsafeNew (Prelude.length xs)
+  forM_ (Prelude.zip [0 ..] xs) (uncurry (VGM.unsafeWrite mv))
+  sortAscKVMVector mv
+  removeDuplicates_ mv
+{-# INLINE fromList #-}
+
+-- | Convert a possibly unsorted assoc list into a KVVector.
+fromListN ::
+  (VG.Vector kv k, VG.Vector vv v, Ord k) =>
+  Int ->
+  [(k, v)] ->
+  KVVector kv vv (k, v)
+fromListN n xs = VG.create $ do
+  mv <- fillWithList xs =<< VGM.unsafeNew n
+  sortAscKVMVector mv
+  removeDuplicates_ mv
+{-# INLINE fromListN #-}
+
+-- | Convert a sorted assoc list with distionct keys into a KVVector
+fromDistinctAscList ::
+  (VG.Vector kv k, VG.Vector vv v) =>
+  [(k, v)] ->
+  KVVector kv vv (k, v)
+fromDistinctAscList xs = VG.fromListN (Prelude.length xs) xs
+-- We do not use `VG.fromList`, because we need guarantees for minimal memory
+-- consumption by the vector, which growing conversion algorithm implemented in
+-- vector does not provide
+{-# INLINE fromDistinctAscList #-}
+
+-- | Convert a sorted assoc list with distionct keys into a KVVector. Length
+-- must be supplied.
+fromDistinctAscListN ::
+  (VG.Vector kv k, VG.Vector vv v) =>
+  Int ->
+  [(k, v)] ->
+  KVVector kv vv (k, v)
+fromDistinctAscListN = VG.fromListN
+{-# INLINE fromDistinctAscListN #-}
+
+-- | Convert a sorted assoc list into a KVVector
+fromAscList ::
+  (Eq k, VG.Vector kv k, VG.Vector vv v) =>
+  [(k, v)] ->
+  KVVector kv vv (k, v)
+fromAscList xs = fromAscListN (Prelude.length xs) xs
+{-# INLINE fromAscList #-}
+
+-- | Convert a sorted assoc list into a KVVector
+fromAscListN ::
+  (Eq k, VG.Vector kv k, VG.Vector vv v) =>
+  Int ->
+  [(k, v)] ->
+  KVVector kv vv (k, v)
+fromAscListN n = fromAscListWithKeyN n selectDuplicate
+{-# INLINE fromAscListN #-}
+
+-- | Fill a mutable vector with elements from the list, slicing the vector if
+-- the list too short.
+fillWithList ::
+  (VGM.MVector v a, PrimMonad m) =>
+  [a] ->
+  v (PrimState m) a ->
+  m (v (PrimState m) a)
+fillWithList zs mv = go 0 zs
+  where
+    n = VGM.length mv
+    go i ys
+      | i == n = pure mv
+      | x : xs <- ys = VGM.write mv i x >> go (i + 1) xs
+      | otherwise = pure $ VGM.slice 0 i mv
+{-# INLINE fillWithList #-}
+
+fromAscListWithKey ::
+  (Eq k, VG.Vector kv k, VG.Vector vv v) =>
+  (k -> v -> v -> v) ->
+  [(k, v)] ->
+  KVVector kv vv (k, v)
+fromAscListWithKey f xs = fromAscListWithKeyN (length xs) f xs
+{-# INLINE fromAscListWithKey #-}
+
+fromAscListWithKeyN ::
+  (Eq k, VG.Vector kv k, VG.Vector vv v) =>
+  Int ->
+  (k -> v -> v -> v) ->
+  [(k, v)] ->
+  KVVector kv vv (k, v)
+fromAscListWithKeyN n f xs
+  | n <= 0 = VG.empty
+  | otherwise = VG.create $ VGM.unsafeNew n >>= fillWithList xs >>= removeDuplicates f
+{-# INLINE fromAscListWithKeyN #-}
+
+mapValsKVVector ::
+  (VG.Vector vv a, VG.Vector vv b) =>
+  (a -> b) ->
+  KVVector kv vv (k, a) ->
+  KVVector kv vv (k, b)
+mapValsKVVector f vec =
+  KVVector {keysVector = keysVector vec, valsVector = VG.map f (valsVector vec)}
+{-# INLINE mapValsKVVector #-}
+
+mapWithKeyKVVector ::
+  (VG.Vector kv k, VG.Vector vv a, VG.Vector vv b) =>
+  (k -> a -> b) ->
+  KVVector kv vv (k, a) ->
+  KVVector kv vv (k, b)
+mapWithKeyKVVector f KVVector {..} =
+  KVVector
+    { keysVector = keysVector,
+      valsVector = VG.imap (\i -> f (keysVector VG.! i)) valsVector
+    }
+{-# INLINE mapWithKeyKVVector #-}
+
+internKVVectorMaybe :: (VG.Vector kv k, Ord k) => k -> KVVector kv vv (k, v) -> Maybe k
+internKVVectorMaybe key (KVVector keys _values) =
+  VG.indexM keys =<< lookupIxSortedVector key keys
+{-# INLINE internKVVectorMaybe #-}
+
+-- | Look up a value by the key in a __sorted__ key/value vector. Ensure it is
+-- sorted otherwise terrible things happen.
+lookupKVVector ::
+  (Ord k, VG.Vector kv k, VG.Vector vv v) => k -> KVVector kv vv (k, v) -> Maybe v
+lookupKVVector key (KVVector keys values) =
+  VG.indexM values =<< lookupIxSortedVector key keys
+{-# INLINE lookupKVVector #-}
+
+-- | Look up a value by the key in a __sorted__ key/value vector. Ensure it is
+-- sorted otherwise terrible things happen.
+lookupDefaultKVVector ::
+  (Ord k, VG.Vector kv k, VG.Vector vv v) => v -> k -> KVVector kv vv (k, v) -> v
+lookupDefaultKVVector v k = fromMaybe v . lookupKVVector k
+{-# INLINE lookupDefaultKVVector #-}
+
+-- | Perform a binary search on a sorted vector
+lookupIxSortedVector ::
+  (VG.Vector kv k, Ord k) => k -> kv k -> Maybe Int
+lookupIxSortedVector key keys = go 0 (VG.length keys)
+  where
+    go !l !u = do
+      guard (l < u)
+      let !i = ((u - l) `div` 2) + l
+      case compare key (keys VG.! i) of
+        LT -> go l i
+        GT -> go (i + 1) u
+        EQ -> Just i
+{-# INLINE lookupIxSortedVector #-}
+
+sortAscKVMVector ::
+  (VGM.MVector kmv k, VGM.MVector vmv v, Ord k, PrimMonad m) =>
+  KVMVector kmv vmv (PrimState m) (k, v) ->
+  m ()
+sortAscKVMVector = sortBy (\(k1, _) (k2, _) -> compare k1 k2)
+{-# INLINE sortAscKVMVector #-}
+
+selectDuplicate :: k -> v -> v -> v
+selectDuplicate _ v _ = v
+
+removeDuplicates_ ::
+  (VGM.MVector kmv k, VGM.MVector vmv v, Eq k, PrimMonad m) =>
+  KVMVector kmv vmv (PrimState m) (k, v) ->
+  m (KVMVector kmv vmv (PrimState m) (k, v))
+removeDuplicates_ = removeDuplicates selectDuplicate
+{-# INLINE removeDuplicates_ #-}
+
+removeDuplicates ::
+  (VGM.MVector kmv k, VGM.MVector vmv v, Eq k, PrimMonad m) =>
+  (k -> v -> v -> v) ->
+  KVMVector kmv vmv (PrimState m) (k, v) ->
+  m (KVMVector kmv vmv (PrimState m) (k, v))
+removeDuplicates f mv
+  | VGM.null mv = pure mv
+  | otherwise = do
+    let n = VGM.length mv
+        goMoved lastIx prev@(pk, pv) curIx = do
+          VGM.write mv lastIx prev
+          if curIx < n
+            then do
+              cur@(ck, cv) <- VGM.read mv curIx
+              if ck == pk
+                then goMoved lastIx (ck, f ck cv pv) (curIx + 1)
+                else goMoved (lastIx + 1) cur (curIx + 1)
+            else pure $ VGM.slice 0 (lastIx + 1) mv
+        goUnmoved (pk, pv) curIx
+          | curIx < n = do
+            cur@(ck, cv) <- VGM.read mv curIx
+            if ck == pk
+              then goMoved (curIx - 1) (ck, f ck cv pv) (curIx + 1)
+              else goUnmoved cur (curIx + 1)
+          | otherwise = pure mv
+    x0 <- VGM.read mv 0
+    goUnmoved x0 1
+{-# INLINE removeDuplicates #-}
+
+normalize ::
+  (VG.Vector kv k, VG.Vector vv v, Ord k) =>
+  KVVector kv vv (k, v) ->
+  KVVector kv vv (k, v)
+normalize v = runST $ VG.thaw v >>= normalizeM >>= VG.unsafeFreeze
+{-# INLINE normalize #-}
+
+normalizeM ::
+  (Ord k, PrimMonad m, VG.Vector kv k, VG.Vector vv v) =>
+  KVMVector (VG.Mutable kv) (VG.Mutable vv) (PrimState m) (k, v) ->
+  m (KVMVector (VG.Mutable kv) (VG.Mutable vv) (PrimState m) (k, v))
+normalizeM mv = sortAscKVMVector mv >> removeDuplicates_ mv
+{-# INLINE normalizeM #-}
+
+instance (VG.Vector kv k, VG.Vector vv v, Ord k) => Semigroup (KVVector kv vv (k, v)) where
+  (<>) v1 v2 = normalize (v1 VG.++ v2)
+  {-# INLINE (<>) #-}
+  sconcat = normalize . VG.concat . NE.toList
+  {-# INLINE sconcat #-}
+
+instance (VG.Vector kv k, VG.Vector vv v, Ord k) => Monoid (KVVector kv vv (k, v)) where
+  mempty = VG.empty
+  mconcat = normalize . VG.concat
+  {-# INLINE mconcat #-}
+
+type family Key e :: Type where
+  Key (k, v) = k
+
+type family Value e :: Type where
+  Value (k, v) = v
+
+data KVVector kv vv a = KVVector
+  { keysVector :: !(kv (Key a)),
+    valsVector :: !(vv (Value a))
+  }
+  deriving (Generic)
+
+instance (VG.Vector kv k, VG.Vector vv v, Ord k) => Exts.IsList (KVVector kv vv (k, v)) where
+  type Item (KVVector kv vv (k, v)) = (k, v)
+  fromList = fromList
+  {-# INLINE fromList #-}
+  fromListN = fromListN
+  {-# INLINE fromListN #-}
+  toList = VG.toList
+  {-# INLINE toList #-}
+
+deriving instance (Eq (kv k), Eq (vv v)) => Eq (KVVector kv vv (k, v))
+
+deriving instance (Show (kv k), Show (vv v)) => Show (KVVector kv vv (k, v))
+
+data KVMVector kmv vmv s a = KVMVector
+  { _keysMVector :: !(kmv s (Key a)),
+    _valsMVector :: !(vmv s (Value a))
+  }
+
+type instance VG.Mutable (KVVector kv vv) = KVMVector (VG.Mutable kv) (VG.Mutable vv)
+
+instance (NFData (kv k), (NFData (vv v))) => NFData (KVVector kv vv (k, v)) where
+  rnf KVVector {..} = keysVector `deepseq` valsVector `deepseq` ()
+
+instance (VG.Vector kv k, VG.Vector vv v) => VG.Vector (KVVector kv vv) (k, v) where
+  {-# INLINE basicUnsafeFreeze #-}
+  basicUnsafeFreeze (KVMVector kmv vmv) =
+    KVVector <$> VG.basicUnsafeFreeze kmv <*> VG.basicUnsafeFreeze vmv
+
+  {-# INLINE basicUnsafeThaw #-}
+  basicUnsafeThaw (KVVector kv vv) = KVMVector <$> VG.basicUnsafeThaw kv <*> VG.basicUnsafeThaw vv
+
+  {-# INLINE basicLength #-}
+  -- ignore length on values, it assumed to match vector with keys
+  basicLength (KVVector kv _) = VG.basicLength kv
+
+  {-# INLINE basicUnsafeSlice #-}
+  basicUnsafeSlice i n (KVVector kv vv) =
+    KVVector (VG.basicUnsafeSlice i n kv) (VG.basicUnsafeSlice i n vv)
+
+  {-# INLINE basicUnsafeIndexM #-}
+  basicUnsafeIndexM (KVVector kv vv) i = do
+    k <- VG.basicUnsafeIndexM kv i
+    v <- VG.basicUnsafeIndexM vv i
+    pure (k, v)
+
+  {-# INLINE basicUnsafeCopy #-}
+  basicUnsafeCopy (KVMVector kvDst vvDst) (KVVector kvSrc vvSrc) =
+    VG.basicUnsafeCopy kvDst kvSrc >> VG.basicUnsafeCopy vvDst vvSrc
+
+instance (VGM.MVector kmv k, VGM.MVector vmv v) => VGM.MVector (KVMVector kmv vmv) (k, v) where
+  {-# INLINE basicLength #-}
+  -- ignore length on values, it assumed to match vector with keys
+  basicLength (KVMVector kmv _) = VGM.basicLength kmv
+
+  {-# INLINE basicUnsafeSlice #-}
+  basicUnsafeSlice j m (KVMVector kmv vmv) =
+    KVMVector (VGM.basicUnsafeSlice j m kmv) (VGM.basicUnsafeSlice j m vmv)
+
+  {-# INLINE basicOverlaps #-}
+  basicOverlaps (KVMVector kmv1 vmv1) (KVMVector kmv2 vmv2) =
+    VGM.basicOverlaps kmv1 kmv2 && VGM.basicOverlaps vmv1 vmv2
+
+  {-# INLINE basicUnsafeNew #-}
+  basicUnsafeNew n = do
+    kmv1 <- VGM.basicUnsafeNew n
+    vmv1 <- VGM.basicUnsafeNew n
+    return (KVMVector kmv1 vmv1)
+
+  {-# INLINE basicInitialize #-}
+  basicInitialize (KVMVector kmv vmv) = VGM.basicInitialize kmv >> VGM.basicInitialize vmv
+
+  {-# INLINE basicUnsafeReplicate #-}
+  basicUnsafeReplicate n !(!k, !v) =
+    KVMVector <$> VGM.basicUnsafeReplicate n k <*> VGM.basicUnsafeReplicate n v
+
+  {-# INLINE basicUnsafeRead #-}
+  basicUnsafeRead (KVMVector kmv vmv) i = do
+    k <- VGM.basicUnsafeRead kmv i
+    v <- VGM.basicUnsafeRead vmv i
+    pure (k, v)
+
+  {-# INLINE basicUnsafeWrite #-}
+  basicUnsafeWrite (KVMVector kmv vmv) i !(!k, !v) =
+    VGM.basicUnsafeWrite kmv i k >> VGM.basicUnsafeWrite vmv i v
+
+  {-# INLINE basicUnsafeCopy #-}
+  basicUnsafeCopy (KVMVector kmvDst vmvDst) (KVMVector kmvSrc vmvSrc) =
+    VGM.basicUnsafeCopy kmvDst kmvSrc >> VGM.basicUnsafeCopy vmvDst vmvSrc
+
+  {-# INLINE basicUnsafeMove #-}
+  basicUnsafeMove (KVMVector kmvDst vmvDst) (KVMVector kmvSrc vmvSrc) =
+    VGM.basicUnsafeMove kmvDst kmvSrc >> VGM.basicUnsafeMove vmvDst vmvSrc
+
+  {-# INLINE basicClear #-}
+  basicClear (KVMVector kmv vmv) = VGM.basicClear kmv >> VGM.basicClear vmv
+
+instance
+  ( NoThunks (kv k),
+    NoThunks (vv v),
+    Typeable kv,
+    Typeable vv,
+    Typeable k,
+    Typeable v
+  ) =>
+  NoThunks (KVVector kv vv (k, v))
+  where
+  wNoThunks c (KVVector kv vv) = (<|>) <$> wNoThunks c kv <*> wNoThunks c vv
+  showTypeOf px = showsTypeRep (typeRep px) ""
+
+instance
+  (ToCBOR k, ToCBOR v, Ord k, VG.Vector kv k, VG.Vector vv v, Typeable kv, Typeable vv) =>
+  ToCBOR (KVVector kv vv (k, v))
+  where
+  toCBOR = toCBOR . toMap
+
+instance
+  (FromCBOR k, FromCBOR v, Ord k, VG.Vector kv k, VG.Vector vv v, Typeable kv, Typeable vv) =>
+  FromCBOR (KVVector kv vv (k, v))
+  where
+  fromCBOR = fromMap <$> fromCBOR
+
+instance Typeable e => NoThunks (VS.Vector e) where
+  wNoThunks _ !_ = pure Nothing
+  showTypeOf px = showsTypeRep (typeRep px) ""
+
+instance Typeable e => NoThunks (VP.Vector e) where
+  wNoThunks _ !_ = pure Nothing
+  showTypeOf px = showsTypeRep (typeRep px) ""
diff --git a/libs/compact-map/src/Data/Compact/VMap.hs b/libs/compact-map/src/Data/Compact/VMap.hs
new file mode 100644
index 00000000000..f293d8eebd0
--- /dev/null
+++ b/libs/compact-map/src/Data/Compact/VMap.hs
@@ -0,0 +1,205 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Data.Compact.VMap
+  ( VG.Vector,
+    VB,
+    VU,
+    VP,
+    VS,
+    VMap (..),
+    empty,
+    size,
+    lookup,
+    findWithDefault,
+    map,
+    mapWithKey,
+    fold,
+    foldMap,
+    foldMapWithKey,
+    fromMap,
+    toMap,
+    fromList,
+    fromListN,
+    toAscList,
+    keys,
+    elems,
+    fromAscList,
+    fromAscListN,
+    fromAscListWithKey,
+    fromAscListWithKeyN,
+    fromDistinctAscList,
+    fromDistinctAscListN,
+    intern,
+    interns,
+    internMaybe,
+    -- Internal types
+    KV.KVMVector,
+    KV.KVVector,
+    KV.normalize,
+    KV.normalizeM,
+  )
+where
+
+import Cardano.Binary
+import Control.DeepSeq
+import Data.Compact.KVVector (KVVector (..))
+import qualified Data.Compact.KVVector as KV
+import qualified Data.Map.Strict as Map
+import Data.Maybe as Maybe
+import qualified Data.Vector as V
+import qualified Data.Vector.Generic as VG
+import qualified Data.Vector.Primitive as VP
+import qualified Data.Vector.Storable as VS
+import qualified Data.Vector.Storable as VU
+import qualified GHC.Exts as Exts
+import GHC.Generics (Generic)
+import NoThunks.Class
+import Prelude hiding (foldMap, lookup, map)
+
+type VB = V.Vector
+
+type VU = VU.Vector
+
+type VP = VP.Vector
+
+type VS = VS.Vector
+
+newtype VMap kv vv k v = VMap
+  { unVMap :: KVVector kv vv (k, v)
+  }
+  deriving (Eq, Generic, NoThunks, ToCBOR, FromCBOR, NFData, Semigroup, Monoid)
+
+instance (Show k, Show v, VG.Vector kv k, VG.Vector vv v) => Show (VMap kv vv k v) where
+  show = show . KV.toMap . unVMap
+
+instance (VG.Vector kv k, VG.Vector vv v, Ord k) => Exts.IsList (VMap kv vv k v) where
+  type Item (VMap kv vv k v) = (k, v)
+  fromList = fromList
+  {-# INLINE fromList #-}
+  fromListN = fromListN
+  {-# INLINE fromListN #-}
+  toList = toAscList
+  {-# INLINE toList #-}
+
+empty :: (VG.Vector kv k, VG.Vector vv v) => VMap kv vv k v
+empty = VMap VG.empty
+
+size :: (VG.Vector kv k, VG.Vector vv v) => VMap kv vv k v -> Int
+size = VG.length . unVMap
+
+lookup ::
+  (Ord k, VG.Vector kv k, VG.Vector vv v) => k -> VMap kv vv k v -> Maybe v
+lookup k = KV.lookupKVVector k . unVMap
+{-# INLINE lookup #-}
+
+findWithDefault ::
+  (Ord k, VG.Vector kv k, VG.Vector vv v) => v -> k -> VMap kv vv k v -> v
+findWithDefault a k = fromMaybe a . lookup k
+{-# INLINE findWithDefault #-}
+
+fromMap :: (VG.Vector kv k, VG.Vector vv v) => Map.Map k v -> VMap kv vv k v
+fromMap = VMap . KV.fromMap
+{-# INLINE fromMap #-}
+
+toMap :: (VG.Vector kv k, VG.Vector vv v) => VMap kv vv k v -> Map.Map k v
+toMap = KV.toMap . unVMap
+{-# INLINE toMap #-}
+
+toAscList :: (VG.Vector kv k, VG.Vector vv v) => VMap kv vv k v -> [(k, v)]
+toAscList = VG.toList . unVMap
+{-# INLINE toAscList #-}
+
+fromList ::
+  (Ord k, VG.Vector kv k, VG.Vector vv v) => [(k, v)] -> VMap kv vv k v
+fromList = VMap . KV.fromList
+{-# INLINE fromList #-}
+
+fromListN ::
+  (Ord k, VG.Vector kv k, VG.Vector vv v) => Int -> [(k, v)] -> VMap kv vv k v
+fromListN n = VMap . KV.fromListN n
+{-# INLINE fromListN #-}
+
+fromAscList ::
+  (Eq k, VG.Vector kv k, VG.Vector vv v) => [(k, v)] -> VMap kv vv k v
+fromAscList = VMap . KV.fromAscList
+{-# INLINE fromAscList #-}
+
+fromAscListN ::
+  (Eq k, VG.Vector kv k, VG.Vector vv v) => Int -> [(k, v)] -> VMap kv vv k v
+fromAscListN n = VMap . KV.fromAscListN n
+{-# INLINE fromAscListN #-}
+
+fromAscListWithKey ::
+  (Eq k, VG.Vector kv k, VG.Vector vv v) => (k -> v -> v -> v) -> [(k, v)] -> VMap kv vv k v
+fromAscListWithKey f = VMap . KV.fromAscListWithKey f
+{-# INLINE fromAscListWithKey #-}
+
+fromAscListWithKeyN ::
+  (Eq k, VG.Vector kv k, VG.Vector vv v) => Int -> (k -> v -> v -> v) -> [(k, v)] -> VMap kv vv k v
+fromAscListWithKeyN n f = VMap . KV.fromAscListWithKeyN n f
+{-# INLINE fromAscListWithKeyN #-}
+
+fromDistinctAscList ::
+  (VG.Vector kv k, VG.Vector vv v) => [(k, v)] -> VMap kv vv k v
+fromDistinctAscList = VMap . KV.fromDistinctAscList
+{-# INLINE fromDistinctAscList #-}
+
+fromDistinctAscListN ::
+  (VG.Vector kv k, VG.Vector vv v) => Int -> [(k, v)] -> VMap kv vv k v
+fromDistinctAscListN n = VMap . KV.fromDistinctAscListN n
+{-# INLINE fromDistinctAscListN #-}
+
+map ::
+  (VG.Vector vv a, VG.Vector vv b) =>
+  (a -> b) ->
+  VMap kv vv k a ->
+  VMap kv vv k b
+map f (VMap vec) = VMap (KV.mapValsKVVector f vec)
+{-# INLINE map #-}
+
+mapWithKey ::
+  (VG.Vector kv k, VG.Vector vv a, VG.Vector vv b) =>
+  (k -> a -> b) ->
+  VMap kv vv k a ->
+  VMap kv vv k b
+mapWithKey f (VMap vec) = VMap (KV.mapWithKeyKVVector f vec)
+{-# INLINE mapWithKey #-}
+
+foldMapWithKey ::
+  (VG.Vector kv k, VG.Vector vv v, Monoid m) =>
+  (k -> v -> m) ->
+  VMap kv vv k v ->
+  m
+foldMapWithKey f = VG.foldMap' (uncurry f) . unVMap
+{-# INLINE foldMapWithKey #-}
+
+foldMap :: (VG.Vector vv v, Monoid m) => (v -> m) -> VMap kv vv k v -> m
+foldMap f = VG.foldMap' f . valsVector . unVMap
+{-# INLINE foldMap #-}
+
+-- | Fold values monoidally
+fold :: (VG.Vector vv m, Monoid m) => VMap kv vv k m -> m
+fold = VG.foldMap' id . valsVector . unVMap
+{-# INLINE fold #-}
+
+keys :: VG.Vector kv k => VMap kv vv k v -> [k]
+keys = VG.toList . keysVector . unVMap
+{-# INLINE keys #-}
+
+elems :: VG.Vector vv v => VMap kv vv k v -> [v]
+elems = VG.toList . valsVector . unVMap
+{-# INLINE elems #-}
+
+internMaybe :: (VG.Vector kv k, Ord k) => k -> VMap kv vv k v -> Maybe k
+internMaybe key = KV.internKVVectorMaybe key . unVMap
+{-# INLINE internMaybe #-}
+
+intern :: (VG.Vector kv k, Ord k) => k -> VMap kv vv k v -> k
+intern k = fromMaybe k . internMaybe k
+{-# INLINE intern #-}
+
+interns :: (VG.Vector kv k, Ord k) => k -> [VMap kv vv k v] -> k
+interns k = fromMaybe k . listToMaybe . Maybe.mapMaybe (internMaybe k)
+{-# INLINE interns #-}
diff --git a/libs/compact-map/test/Main.hs b/libs/compact-map/test/Main.hs
index 4535aa581f4..3563f360869 100644
--- a/libs/compact-map/test/Main.hs
+++ b/libs/compact-map/test/Main.hs
@@ -1,6 +1,7 @@
 module Main where
 
 import Test.Compact.KeyMap
+import Test.Compact.VMap
 import Test.Tasty
 
 -- ====================================================================================
@@ -9,7 +10,8 @@ tests :: TestTree
 tests =
   testGroup
     "compcat-map"
-    [ keyMapTests
+    [ keyMapTests,
+      vMapTests
     ]
 
 main :: IO ()
diff --git a/libs/compact-map/test/Test/Compact/VMap.hs b/libs/compact-map/test/Test/Compact/VMap.hs
new file mode 100644
index 00000000000..7853412fc46
--- /dev/null
+++ b/libs/compact-map/test/Test/Compact/VMap.hs
@@ -0,0 +1,91 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Test.Compact.VMap where
+
+import Data.Compact.VMap as VMap
+import qualified Data.List as List
+import qualified Data.Map.Strict as Map
+import Data.Proxy
+import Test.QuickCheck
+import Test.QuickCheck.Classes.Base
+import Test.Tasty
+import Test.Tasty.QuickCheck
+
+type MapT = Map.Map Char Int
+
+type VMapT = VMap VB VP Char Int
+
+instance
+  (Ord k, Vector kv k, Vector vv v, Arbitrary k, Arbitrary v) =>
+  Arbitrary (VMap kv vv k v)
+  where
+  arbitrary =
+    VMap.fromMap . Map.fromList <$> arbitrary
+
+testLawsGroup :: TestName -> [Laws] -> TestTree
+testLawsGroup name = testGroup name . fmap testLaws
+  where
+    testLaws Laws {..} =
+      testGroup lawsTypeclass $ fmap (uncurry testProperty) lawsProperties
+
+prop_Roundtrip :: (VMapT -> a) -> (a -> VMapT) -> VMapT -> Property
+prop_Roundtrip to from km = from (to km) === km
+
+prop_AsMapTo ::
+  (Show a, Eq a) => (VMapT -> a) -> (MapT -> a) -> VMapT -> Property
+prop_AsMapTo fromVM fromM vm = fromVM vm === fromM (toMap vm)
+
+prop_AsMapFrom :: (a -> VMapT) -> (a -> MapT) -> a -> Property
+prop_AsMapFrom mkVMap mkMap a = toMap (mkVMap a) === mkMap a
+
+vMapTests :: TestTree
+vMapTests =
+  testGroup
+    "VMap"
+    [ testGroup
+        "roundtrip"
+        [ testProperty "to/fromAscDistinctList" $
+            prop_Roundtrip VMap.toAscList VMap.fromDistinctAscList,
+          testProperty "to/fromAscList" $ prop_Roundtrip VMap.toAscList VMap.fromAscList,
+          testProperty "to/fromList" $ prop_Roundtrip VMap.toAscList VMap.fromList,
+          testProperty "to/fromMap" $ prop_Roundtrip VMap.toMap VMap.fromMap
+        ],
+      testGroup
+        "asMap"
+        [ testProperty "fromList" $ prop_AsMapFrom VMap.fromList Map.fromList,
+          testProperty "fromAscListWithKey" $ \xs f ->
+            prop_AsMapFrom
+              (VMap.fromAscListWithKey (applyFun3 f))
+              (Map.fromAscListWithKey (applyFun3 f))
+              (List.sortOn fst xs),
+          testProperty "fromAscListWithKeyN" $ \n xs f ->
+            prop_AsMapFrom
+              (VMap.fromAscListWithKeyN n (applyFun3 f))
+              (Map.fromAscListWithKey (applyFun3 f) . take n)
+              (List.sortOn fst xs),
+          testProperty "toAscList" $ prop_AsMapTo VMap.toAscList Map.toAscList,
+          testProperty "foldMapWithKey" $ \f ->
+            let f' k v = applyFun2 f k v :: String
+             in prop_AsMapTo (VMap.foldMapWithKey f') (Map.foldMapWithKey f'),
+          testProperty "lookup" $ \k -> prop_AsMapTo (VMap.lookup k) (Map.lookup k),
+          testProperty "lookup (existing)" $ \k v xs ->
+            let xs' = xs <> [(k, v)]
+             in (VMap.lookup k (VMap.fromList xs' :: VMapT) === Just v)
+                  .&&. (Map.lookup k (Map.fromList xs' :: MapT) === Just v),
+          testProperty "finsWithDefault" $ \d k ->
+            prop_AsMapTo (VMap.findWithDefault d k) (Map.findWithDefault d k),
+          testProperty "finsWithDefault (existing)" $ \k v xs ->
+            let xs' = xs <> [(k, v)]
+             in (VMap.findWithDefault undefined k (VMap.fromList xs' :: VMapT) === v)
+                  .&&. (Map.findWithDefault undefined k (Map.fromList xs' :: MapT) === v)
+        ],
+      testLawsGroup
+        "classes"
+        [ eqLaws (Proxy @VMapT),
+          semigroupLaws (Proxy @VMapT),
+          monoidLaws (Proxy @VMapT),
+          isListLaws (Proxy @VMapT)
+        ]
+    ]
diff --git a/libs/ledger-state/bench/Memory.hs b/libs/ledger-state/bench/Memory.hs
index be1235600cc..a26a7941d63 100644
--- a/libs/ledger-state/bench/Memory.hs
+++ b/libs/ledger-state/bench/Memory.hs
@@ -4,7 +4,7 @@
 module Main where
 
 import Cardano.Ledger.State.Query
-import Cardano.Ledger.State.UTxO
+--import Cardano.Ledger.State.UTxO
 import Control.Monad
 import qualified Data.Text as T
 import Options.Applicative as O
@@ -48,33 +48,36 @@ main = do
               (long "help" <> short 'h' <> help "Display this message.")
         )
         (header "ledger-state:memory - Tool for analyzing memory consumption of ledger state")
-  let cols = [Case, Max, MaxOS, Live, Allocated, GCs]
+  let cols = [Case, Max, MaxOS, Live, Allocated, GCs, WallTime]
   !mEpochStateEntity <- mapM (loadEpochStateEntity . T.pack) (optsSqliteDbFile opts)
   mainWith $ do
     setColumns cols
-    forM_ (optsLedgerStateBinaryFile opts) $ \binFp -> do
-      io "NewEpochState" loadNewEpochState binFp
+    -- forM_ (optsLedgerStateBinaryFile opts) $ \binFp -> do
+    --   io "NewEpochState" loadNewEpochState binFp
     forM_ (optsSqliteDbFile opts) $ \dbFpStr -> do
       let dbFp = T.pack dbFpStr
       forM_ mEpochStateEntity $ \ese ->
         wgroup "EpochState" $ do
+          io "SnapShots (Vector) - no sharing" (loadSnapShotsNoSharingM dbFp) ese
+          io "SnapShots (Vector) - with sharing" (loadSnapShotsWithSharingM dbFp) ese
           io "SnapShots - no sharing" (loadSnapShotsNoSharing dbFp) ese
           io "SnapShots - with sharing" (loadSnapShotsWithSharing dbFp) ese
-      wgroup "Baseline" $ do
-        io "DState" loadDStateNoSharing dbFp
-        io "UTxO" loadUTxONoSharing dbFp
-        io "LedgerState" getLedgerStateNoSharing dbFp
-      wgroup "UTxO (No TxOut)" $ do
-        io "IntMap (KeyMap TxId ())" (loadDbUTxO txIxSharingKeyMap_) dbFp
-        io "KeyMap TxId (IntMap TxId ())" (loadDbUTxO txIdSharingKeyMap_) dbFp
-        io "IntMap (Map TxId ())" (loadDbUTxO txIxSharing_) dbFp
-        io "Map TxIn ()" (loadDbUTxO noSharing_) dbFp
-      wgroup "LedgerState" $ do
-        wgroup "UTxO (Share DState)" $ do
-          io "IntMap (KeyMap TxId TxOut)" getLedgerStateDStateTxIxSharingKeyMap dbFp
-          io "KeyMap TxId (IntMap TxOut)" getLedgerStateDStateTxIdSharingKeyMap dbFp
-          io "IntMap (Map TxId TxOut)" getLedgerStateDStateTxIxSharing dbFp
-          io "Map TxIn TxOut" getLedgerStateDStateSharing dbFp
+
+-- wgroup "Baseline" $ do
+--   io "DState" loadDStateNoSharing dbFp
+--   io "UTxO" loadUTxONoSharing dbFp
+--   io "LedgerState" getLedgerStateNoSharing dbFp
+-- wgroup "UTxO (No TxOut)" $ do
+--   io "IntMap (KeyMap TxId ())" (loadDbUTxO txIxSharingKeyMap_) dbFp
+--   io "KeyMap TxId (IntMap TxId ())" (loadDbUTxO txIdSharingKeyMap_) dbFp
+--   io "IntMap (Map TxId ())" (loadDbUTxO txIxSharing_) dbFp
+--   io "Map TxIn ()" (loadDbUTxO noSharing_) dbFp
+-- wgroup "LedgerState" $ do
+--   wgroup "UTxO (Share DState)" $ do
+--     io "IntMap (KeyMap TxId TxOut)" getLedgerStateDStateTxIxSharingKeyMap dbFp
+--     io "KeyMap TxId (IntMap TxOut)" getLedgerStateDStateTxIdSharingKeyMap dbFp
+--     io "IntMap (Map TxId TxOut)" getLedgerStateDStateTxIxSharing dbFp
+--     io "Map TxIn TxOut" getLedgerStateDStateSharing dbFp
 
 --   wgroup "Share TxOut StakeCredential" $ do
 --     io "Map TxIn TxOut'" getLedgerStateDStateTxOutSharing dbFp
diff --git a/libs/ledger-state/ledger-state.cabal b/libs/ledger-state/ledger-state.cabal
index e86749422bc..ca1a3a41438 100644
--- a/libs/ledger-state/ledger-state.cabal
+++ b/libs/ledger-state/ledger-state.cabal
@@ -37,13 +37,13 @@ library
                     , cardano-ledger-alonzo
                     , cardano-ledger-shelley
                     , cardano-ledger-shelley-ma
-                    , cardano-protocol-tpraos
                     , cborg
                     , conduit
                     , containers
                     , compact-map
                     , deepseq
                     , foldl
+                    , vector
                     , persistent
                     , persistent-sqlite
                     , persistent-template
@@ -58,6 +58,7 @@ library
                     , Cardano.Ledger.State.Schema
                     , Cardano.Ledger.State.Transform
                     , Cardano.Ledger.State.Query
+                    , Cardano.Ledger.State.Vector
   hs-source-dirs:     src
 
 executable ledger-state
@@ -78,6 +79,7 @@ benchmark memory
   main-is:        Memory.hs
   hs-source-dirs: bench
   build-depends:  base
+                , deepseq
                 , weigh
                 , ledger-state
                 , optparse-applicative
@@ -85,5 +87,4 @@ benchmark memory
   ghc-options:   -Wall
                  -O2
                  -rtsopts
-                 -with-rtsopts=-T
   default-language:   Haskell2010
diff --git a/libs/ledger-state/src/Cardano/Ledger/State/Orphans.hs b/libs/ledger-state/src/Cardano/Ledger/State/Orphans.hs
index 32f33ddd755..8891096af33 100644
--- a/libs/ledger-state/src/Cardano/Ledger/State/Orphans.hs
+++ b/libs/ledger-state/src/Cardano/Ledger/State/Orphans.hs
@@ -61,6 +61,10 @@ instance PersistField (TxId C) where
 instance PersistFieldSql (TxId C) where
   sqlType _ = SqlBlob
 
+deriving instance PersistField (CompactForm Coin)
+
+deriving instance PersistFieldSql (CompactForm Coin)
+
 instance PersistField Coin where
   toPersistValue = PersistInt64 . fromIntegral . unCoin
   fromPersistValue (PersistInt64 i64) = Right $ Coin $ fromIntegral i64
diff --git a/libs/ledger-state/src/Cardano/Ledger/State/Query.hs b/libs/ledger-state/src/Cardano/Ledger/State/Query.hs
index 572d4dc75dd..b264bc16352 100644
--- a/libs/ledger-state/src/Cardano/Ledger/State/Query.hs
+++ b/libs/ledger-state/src/Cardano/Ledger/State/Query.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TypeFamilies #-}
 
@@ -17,6 +18,7 @@ import Cardano.Ledger.State.Orphans
 import Cardano.Ledger.State.Schema
 import Cardano.Ledger.State.Transform
 import Cardano.Ledger.State.UTxO
+import Cardano.Ledger.State.Vector
 import qualified Cardano.Ledger.TxIn as TxIn
 import Conduit
 import Control.Foldl (Fold (..))
@@ -24,10 +26,15 @@ import Control.Iterate.SetAlgebra
 import Control.Monad
 import Control.Monad.Trans.Reader
 import qualified Data.Compact.KeyMap as KeyMap
+import qualified Data.Compact.VMap as VMap
+import Data.Conduit.Internal (zipSources)
+import Data.Conduit.List (sourceList)
 import Data.Functor
 import qualified Data.IntMap.Strict as IntMap
 import qualified Data.Map.Strict as Map
-import Data.Text as T
+import qualified Data.Text as T
+import qualified Data.Vector.Generic as VG
+import qualified Data.Vector.Generic.Mutable as VGM
 import Database.Persist.Sqlite
 
 -- Populate database
@@ -136,14 +143,14 @@ insertSnapShot ::
   ReaderT SqlBackend m ()
 insertSnapShot snapShotEpochStateId snapShotType EpochBoundary.SnapShot {..} = do
   snapShotId <- insert $ SnapShot {snapShotType, snapShotEpochStateId}
-  forM_ (Map.toList (EpochBoundary.unStake _stake)) $ \(cred, c) -> do
+  VG.forM_ (VMap.unVMap (EpochBoundary.unStake _stake)) $ \(cred, c) -> do
     credId <- insertGetKey (Credential (Keys.asWitness cred))
     insert_ (SnapShotStake snapShotId credId c)
-  forM_ (Map.toList _delegations) $ \(cred, spKeyHash) -> do
+  VG.forM_ (VMap.unVMap _delegations) $ \(cred, spKeyHash) -> do
     credId <- insertGetKey (Credential (Keys.asWitness cred))
     keyHashId <- insertGetKey (KeyHash (Keys.asWitness spKeyHash))
     insert_ (SnapShotDelegation snapShotId credId keyHashId)
-  forM_ (Map.toList _poolParams) $ \(keyHash, pps) -> do
+  VG.forM_ (VMap.unVMap _poolParams) $ \(keyHash, pps) -> do
     keyHashId <- insertGetKey (KeyHash (Keys.asWitness keyHash))
     insert_ (SnapShotPool snapShotId keyHashId pps)
 
@@ -178,6 +185,127 @@ insertEpochState Shelley.EpochState {..} = do
 
 -- Query database
 
+-- Into vector
+
+selectVMap ::
+  ( Ord k,
+    PersistEntity record,
+    PersistEntityBackend record ~ SqlBackend,
+    VMap.Vector kv k,
+    VMap.Vector vv v,
+    MonadResource m
+  ) =>
+  [Filter record] ->
+  (record -> ReaderT SqlBackend m (k, v)) ->
+  ReaderT SqlBackend m (VMap.VMap kv vv k v)
+selectVMap fs f = do
+  n <- count fs
+  mv <- liftIO $ VGM.unsafeNew n
+  runConduit $
+    zipSources (sourceList [0 ..]) (selectSource fs [])
+      .| mapM_C (\(i, Entity _ a) -> liftIO . VGM.write mv i =<< f a)
+  VMap.VMap <$> liftIO (VG.unsafeFreeze =<< VMap.normalizeM mv)
+{-# INLINEABLE selectVMap #-}
+
+getSnapShotNoSharingM ::
+  MonadResource m =>
+  Key EpochState ->
+  SnapShotType ->
+  ReaderT SqlBackend m (SnapShotM C)
+getSnapShotNoSharingM epochStateId snapShotType = do
+  snapShotId <-
+    selectFirst
+      [SnapShotType ==. snapShotType, SnapShotEpochStateId ==. epochStateId]
+      []
+      <&> \case
+        Nothing -> error $ "Missing a snapshot: " ++ show snapShotType
+        Just (Entity snapShotId _) -> snapShotId
+  stake <-
+    selectMap [SnapShotStakeSnapShotId ==. snapShotId] $ \SnapShotStake {..} -> do
+      Credential credential <- getJust snapShotStakeCredentialId
+      pure (Keys.coerceKeyRole credential, snapShotStakeCoin)
+  delegations <-
+    selectMap [SnapShotDelegationSnapShotId ==. snapShotId] $ \SnapShotDelegation {..} -> do
+      Credential credential <- getJust snapShotDelegationCredentialId
+      KeyHash keyHash <- getJust snapShotDelegationKeyHash
+      --TODO ^ rename snapShotDelegationKeyHashId
+      pure (Keys.coerceKeyRole credential, Keys.coerceKeyRole keyHash)
+  poolParams <-
+    selectMap [SnapShotPoolSnapShotId ==. snapShotId] $ \SnapShotPool {..} -> do
+      KeyHash keyHash <- getJust snapShotPoolKeyHashId
+      pure (Keys.coerceKeyRole keyHash, snapShotPoolParams)
+  pure
+    SnapShotM
+      { ssStake = stake,
+        ssDelegations = delegations,
+        ssPoolParams = poolParams
+      }
+{-# INLINEABLE getSnapShotNoSharingM #-}
+
+getSnapShotWithSharingM ::
+  MonadResource m =>
+  [SnapShotM C] ->
+  Key EpochState ->
+  SnapShotType ->
+  ReaderT SqlBackend m (SnapShotM C)
+getSnapShotWithSharingM otherSnapShots epochStateId snapShotType = do
+  let otherStakes = ssStake <$> otherSnapShots
+  let otherPoolParams = ssPoolParams <$> otherSnapShots
+  let otherDelegations = ssDelegations <$> otherSnapShots
+  snapShotId <-
+    selectFirst
+      [SnapShotType ==. snapShotType, SnapShotEpochStateId ==. epochStateId]
+      []
+      <&> \case
+        Nothing -> error $ "Missing a snapshot: " ++ show snapShotType
+        Just (Entity snapShotId _) -> snapShotId
+  stake <-
+    selectMap [SnapShotStakeSnapShotId ==. snapShotId] $ \SnapShotStake {..} -> do
+      Credential credential <- getJust snapShotStakeCredentialId
+      pure
+        (interns (Keys.coerceKeyRole credential) otherStakes, snapShotStakeCoin)
+  poolParams <-
+    selectMap [SnapShotPoolSnapShotId ==. snapShotId] $ \SnapShotPool {..} -> do
+      KeyHash keyHash <- getJust snapShotPoolKeyHashId
+      pure
+        ( interns (Keys.coerceKeyRole keyHash) otherPoolParams,
+          snapShotPoolParams
+        )
+  delegations <-
+    selectMap [SnapShotDelegationSnapShotId ==. snapShotId] $ \SnapShotDelegation {..} -> do
+      Credential credential <- getJust snapShotDelegationCredentialId
+      KeyHash keyHash <- getJust snapShotDelegationKeyHash
+      pure
+        ( interns (Keys.coerceKeyRole credential) otherDelegations,
+          intern (Keys.coerceKeyRole keyHash) poolParams
+        )
+  pure
+    SnapShotM
+      { ssStake = stake,
+        ssDelegations = delegations,
+        ssPoolParams = poolParams
+      }
+{-# INLINEABLE getSnapShotWithSharingM #-}
+
+getSnapShotsWithSharingM ::
+  MonadResource m =>
+  Entity EpochState ->
+  ReaderT SqlBackend m (SnapShotsM C)
+getSnapShotsWithSharingM (Entity epochStateId EpochState {epochStateSnapShotsFee}) = do
+  mark <- getSnapShotWithSharingM [] epochStateId SnapShotMark
+  set <- getSnapShotWithSharingM [mark] epochStateId SnapShotSet
+  go <- getSnapShotWithSharingM [mark, set] epochStateId SnapShotGo
+  pure $
+    SnapShotsM
+      { ssPstakeMark = mark,
+        ssPstakeSet = set,
+        ssPstakeGo = go,
+        ssFeeSS = epochStateSnapShotsFee
+      }
+{-# INLINEABLE getSnapShotsWithSharingM #-}
+
+-- Into a Map structure
+
 selectMap ::
   ( MonadResource m,
     Ord k,
@@ -187,10 +315,11 @@ selectMap ::
   [Filter record] ->
   (record -> ReaderT SqlBackend m (k, a)) ->
   ReaderT SqlBackend m (Map.Map k a)
-selectMap fs f =
+selectMap fs f = do
   runConduit $
     selectSource fs [] .| mapMC (\(Entity _ a) -> f a)
       .| foldlC (\m (k, v) -> Map.insert k v m) mempty
+{-# INLINEABLE selectMap #-}
 
 getSnapShotNoSharing ::
   MonadResource m =>
@@ -206,17 +335,17 @@ getSnapShotNoSharing epochStateId snapShotType = do
         Nothing -> error $ "Missing a snapshot: " ++ show snapShotType
         Just (Entity snapShotId _) -> snapShotId
   stake <-
-    selectMap [SnapShotStakeSnapShotId ==. snapShotId] $ \SnapShotStake {..} -> do
+    selectVMap [SnapShotStakeSnapShotId ==. snapShotId] $ \SnapShotStake {..} -> do
       Credential credential <- getJust snapShotStakeCredentialId
       pure (Keys.coerceKeyRole credential, snapShotStakeCoin)
   delegations <-
-    selectMap [SnapShotDelegationSnapShotId ==. snapShotId] $ \SnapShotDelegation {..} -> do
+    selectVMap [SnapShotDelegationSnapShotId ==. snapShotId] $ \SnapShotDelegation {..} -> do
       Credential credential <- getJust snapShotDelegationCredentialId
       KeyHash keyHash <- getJust snapShotDelegationKeyHash
       --TODO ^ rename snapShotDelegationKeyHashId
       pure (Keys.coerceKeyRole credential, Keys.coerceKeyRole keyHash)
   poolParams <-
-    selectMap [SnapShotPoolSnapShotId ==. snapShotId] $ \SnapShotPool {..} -> do
+    selectVMap [SnapShotPoolSnapShotId ==. snapShotId] $ \SnapShotPool {..} -> do
       KeyHash keyHash <- getJust snapShotPoolKeyHashId
       pure (Keys.coerceKeyRole keyHash, snapShotPoolParams)
   pure
@@ -225,6 +354,7 @@ getSnapShotNoSharing epochStateId snapShotType = do
         _delegations = delegations,
         _poolParams = poolParams
       }
+{-# INLINEABLE getSnapShotNoSharing #-}
 
 getSnapShotsNoSharing ::
   MonadResource m =>
@@ -241,6 +371,24 @@ getSnapShotsNoSharing (Entity epochStateId EpochState {epochStateSnapShotsFee})
         _pstakeGo = go,
         _feeSS = epochStateSnapShotsFee
       }
+{-# INLINEABLE getSnapShotsNoSharing #-}
+
+getSnapShotsNoSharingM ::
+  MonadResource m =>
+  Entity EpochState ->
+  ReaderT SqlBackend m (SnapShotsM C)
+getSnapShotsNoSharingM (Entity epochStateId EpochState {epochStateSnapShotsFee}) = do
+  mark <- getSnapShotNoSharingM epochStateId SnapShotMark
+  set <- getSnapShotNoSharingM epochStateId SnapShotSet
+  go <- getSnapShotNoSharingM epochStateId SnapShotGo
+  pure $
+    SnapShotsM
+      { ssPstakeMark = mark,
+        ssPstakeSet = set,
+        ssPstakeGo = go,
+        ssFeeSS = epochStateSnapShotsFee
+      }
+{-# INLINEABLE getSnapShotsNoSharingM #-}
 
 getSnapShotWithSharing ::
   MonadResource m =>
@@ -261,24 +409,24 @@ getSnapShotWithSharing otherSnapShots epochStateId snapShotType = do
         Nothing -> error $ "Missing a snapshot: " ++ show snapShotType
         Just (Entity snapShotId _) -> snapShotId
   stake <-
-    selectMap [SnapShotStakeSnapShotId ==. snapShotId] $ \SnapShotStake {..} -> do
+    selectVMap [SnapShotStakeSnapShotId ==. snapShotId] $ \SnapShotStake {..} -> do
       Credential credential <- getJust snapShotStakeCredentialId
       pure
-        (interns (Keys.coerceKeyRole credential) otherStakes, snapShotStakeCoin)
+        (VMap.interns (Keys.coerceKeyRole credential) otherStakes, snapShotStakeCoin)
   poolParams <-
-    selectMap [SnapShotPoolSnapShotId ==. snapShotId] $ \SnapShotPool {..} -> do
+    selectVMap [SnapShotPoolSnapShotId ==. snapShotId] $ \SnapShotPool {..} -> do
       KeyHash keyHash <- getJust snapShotPoolKeyHashId
       pure
-        ( interns (Keys.coerceKeyRole keyHash) otherPoolParams,
+        ( VMap.interns (Keys.coerceKeyRole keyHash) otherPoolParams,
           snapShotPoolParams
         )
   delegations <-
-    selectMap [SnapShotDelegationSnapShotId ==. snapShotId] $ \SnapShotDelegation {..} -> do
+    selectVMap [SnapShotDelegationSnapShotId ==. snapShotId] $ \SnapShotDelegation {..} -> do
       Credential credential <- getJust snapShotDelegationCredentialId
       KeyHash keyHash <- getJust snapShotDelegationKeyHash
       pure
-        ( interns (Keys.coerceKeyRole credential) otherDelegations,
-          intern (Keys.coerceKeyRole keyHash) poolParams
+        ( VMap.interns (Keys.coerceKeyRole credential) otherDelegations,
+          VMap.intern (Keys.coerceKeyRole keyHash) poolParams
         )
   pure
     EpochBoundary.SnapShot
@@ -286,6 +434,7 @@ getSnapShotWithSharing otherSnapShots epochStateId snapShotType = do
         _delegations = delegations,
         _poolParams = poolParams
       }
+{-# INLINEABLE getSnapShotWithSharing #-}
 
 getSnapShotsWithSharing ::
   MonadResource m =>
@@ -302,6 +451,7 @@ getSnapShotsWithSharing (Entity epochStateId EpochState {epochStateSnapShotsFee}
         _pstakeGo = go,
         _feeSS = epochStateSnapShotsFee
       }
+{-# INLINEABLE getSnapShotsWithSharing #-}
 
 sourceUTxO ::
   MonadResource m =>
@@ -334,7 +484,7 @@ foldDbUTxO ::
   -- | Empty acc
   a ->
   -- | Path to Sqlite db
-  Text ->
+  T.Text ->
   m a
 foldDbUTxO f m fp = runSqlite fp (runConduit (sourceUTxO .| foldlC f m))
 
@@ -351,7 +501,7 @@ foldDbUTxO f m fp = runSqlite fp (runConduit (sourceUTxO .| foldlC f m))
 --   -> Int64
 --   -> (a -> (TxIn.TxIn C, Alonzo.TxOut CurrentEra) -> a) -- ^ Folding function
 --   -> a -- ^ Empty acc
---   -> Text -- ^ Path to Sqlite db
+--   -> T.Text -- ^ Path to Sqlite db
 --   -> m a
 -- foldDbUTxOr b t f m fp = runSqlite fp (runConduit (sourceUTxOr b t .| foldlC f m))
 
@@ -488,17 +638,17 @@ getDStateWithSharing dstateId = do
             }
       }
 
-loadDStateNoSharing :: MonadUnliftIO m => Text -> m (Shelley.DState C)
+loadDStateNoSharing :: MonadUnliftIO m => T.Text -> m (Shelley.DState C)
 loadDStateNoSharing fp =
   runSqlite fp $ getDStateNoSharing (DStateKey (SqlBackendKey 1))
 
 loadUTxONoSharing ::
-  MonadUnliftIO m => Text -> m (Shelley.UTxO CurrentEra)
+  MonadUnliftIO m => T.Text -> m (Shelley.UTxO CurrentEra)
 loadUTxONoSharing fp =
   runSqlite fp (Shelley.UTxO <$> runConduitFold sourceUTxO noSharing)
 
 getLedgerStateNoSharing ::
-  MonadUnliftIO m => Text -> m (Shelley.LedgerState CurrentEra)
+  MonadUnliftIO m => T.Text -> m (Shelley.LedgerState CurrentEra)
 getLedgerStateNoSharing fp =
   runSqlite fp $ do
     ledgerState@LedgerState {..} <- getJust lsId
@@ -507,7 +657,7 @@ getLedgerStateNoSharing fp =
     getLedgerState (Shelley.UTxO m) ledgerState dstate
 
 getLedgerStateDStateSharing ::
-  MonadUnliftIO m => Text -> m (Shelley.LedgerState CurrentEra)
+  MonadUnliftIO m => T.Text -> m (Shelley.LedgerState CurrentEra)
 getLedgerStateDStateSharing fp =
   runSqlite fp $ do
     ledgerState@LedgerState {..} <- getJust lsId
@@ -517,7 +667,7 @@ getLedgerStateDStateSharing fp =
 
 getLedgerStateDStateTxIxSharing ::
   MonadUnliftIO m =>
-  Text ->
+  T.Text ->
   m
     ( Shelley.LedgerState CurrentEra,
       IntMap.IntMap (Map.Map (TxIn.TxId C) (Alonzo.TxOut CurrentEra))
@@ -532,7 +682,7 @@ getLedgerStateDStateTxIxSharing fp =
 
 getLedgerStateDStateTxIxSharingKeyMap ::
   MonadUnliftIO m =>
-  Text ->
+  T.Text ->
   m
     ( Shelley.LedgerState CurrentEra,
       IntMap.IntMap (KeyMap.KeyMap (Alonzo.TxOut CurrentEra))
@@ -547,7 +697,7 @@ getLedgerStateDStateTxIxSharingKeyMap fp =
 
 getLedgerStateDStateTxIdSharingKeyMap ::
   MonadUnliftIO m =>
-  Text ->
+  T.Text ->
   m
     ( Shelley.LedgerState CurrentEra,
       KeyMap.KeyMap (IntMap.IntMap (Alonzo.TxOut CurrentEra))
@@ -561,39 +711,49 @@ getLedgerStateDStateTxIdSharingKeyMap fp =
     pure (ls, m)
 
 -- storeLedgerState ::
---      MonadUnliftIO m => Text -> Shelley.LedgerState CurrentEra -> m ()
+--      MonadUnliftIO m => T.Text -> Shelley.LedgerState CurrentEra -> m ()
 -- storeLedgerState fp ls =
 --   runSqlite fp $ do
 --     runMigration migrateAll
 --     insertLedgerState ls
 
 storeEpochState ::
-  MonadUnliftIO m => Text -> Shelley.EpochState CurrentEra -> m ()
+  MonadUnliftIO m => T.Text -> Shelley.EpochState CurrentEra -> m ()
 storeEpochState fp es =
   runSqlite fp $ do
     runMigration migrateAll
     insertEpochState es
 
-loadDbUTxO :: UTxOFold a -> Text -> IO a
+loadDbUTxO :: UTxOFold a -> T.Text -> IO a
 loadDbUTxO (Fold f e g) fp = runSqlite fp (g <$> runConduit (sourceUTxO .| foldlC f e))
 
 esId :: Key EpochState
 esId = EpochStateKey (SqlBackendKey 1)
 
-loadEpochStateEntity :: MonadUnliftIO m => Text -> m (Entity EpochState)
+loadEpochStateEntity :: MonadUnliftIO m => T.Text -> m (Entity EpochState)
 loadEpochStateEntity fp = runSqlite fp (getJustEntity esId)
 
 loadSnapShotsNoSharing ::
-  MonadUnliftIO m => Text -> Entity EpochState -> m (EpochBoundary.SnapShots C)
+  MonadUnliftIO m => T.Text -> Entity EpochState -> m (EpochBoundary.SnapShots C)
 loadSnapShotsNoSharing fp = runSqlite fp . getSnapShotsNoSharing
+{-# INLINEABLE loadSnapShotsNoSharing #-}
 
 loadSnapShotsWithSharing ::
-  MonadUnliftIO m => Text -> Entity EpochState -> m (EpochBoundary.SnapShots C)
+  MonadUnliftIO m => T.Text -> Entity EpochState -> m (EpochBoundary.SnapShots C)
 loadSnapShotsWithSharing fp = runSqlite fp . getSnapShotsWithSharing
+{-# INLINEABLE loadSnapShotsWithSharing #-}
+
+loadSnapShotsNoSharingM :: T.Text -> Entity EpochState -> IO (SnapShotsM C)
+loadSnapShotsNoSharingM fp = runSqlite fp . getSnapShotsNoSharingM
+{-# INLINEABLE loadSnapShotsNoSharingM #-}
+
+loadSnapShotsWithSharingM :: T.Text -> Entity EpochState -> IO (SnapShotsM C)
+loadSnapShotsWithSharingM fp = runSqlite fp . getSnapShotsWithSharingM
+{-# INLINEABLE loadSnapShotsWithSharingM #-}
 
 -- getLedgerStateWithSharing ::
 --      MonadUnliftIO m
---   => Text
+--   => T.Text
 --   -> m (Shelley.LedgerState CurrentEra, IntMap.IntMap (Map.Map (TxIn.TxId C) TxOut'))
 -- getLedgerStateWithSharing fp =
 --   runSqlite fp $ do
@@ -606,7 +766,7 @@ loadSnapShotsWithSharing fp = runSqlite fp . getSnapShotsWithSharing
 
 -- getLedgerStateDStateTxOutSharing ::
 --      MonadUnliftIO m
---   => Text
+--   => T.Text
 --   -> m (Shelley.LedgerState CurrentEra, Map.Map (TxIn.TxIn C) TxOut')
 -- getLedgerStateDStateTxOutSharing fp =
 --   runSqlite fp $ do
@@ -619,7 +779,7 @@ loadSnapShotsWithSharing fp = runSqlite fp . getSnapShotsWithSharing
 
 -- getLedgerStateTxOutSharing ::
 --      MonadUnliftIO m
---   => Text
+--   => T.Text
 --   -> m (Shelley.LedgerState CurrentEra, Map.Map (TxIn.TxIn C) TxOut')
 -- getLedgerStateTxOutSharing fp =
 --   runSqlite fp $ do
@@ -632,7 +792,7 @@ loadSnapShotsWithSharing fp = runSqlite fp . getSnapShotsWithSharing
 
 -- getLedgerStateWithSharingKeyMap ::
 --      MonadUnliftIO m
---   => Text
+--   => T.Text
 --   -> m (Shelley.LedgerState CurrentEra, IntMap.IntMap (KeyMap.KeyMap TxOut'))
 -- getLedgerStateWithSharingKeyMap fp =
 --   runSqlite fp $ do
diff --git a/libs/ledger-state/src/Cardano/Ledger/State/Schema.hs b/libs/ledger-state/src/Cardano/Ledger/State/Schema.hs
index 834bd1bed1b..5e7fd2e705a 100644
--- a/libs/ledger-state/src/Cardano/Ledger/State/Schema.hs
+++ b/libs/ledger-state/src/Cardano/Ledger/State/Schema.hs
@@ -52,7 +52,7 @@ SnapShot
 SnapShotStake
   snapShotId SnapShotId
   credentialId CredentialId
-  coin Coin
+  coin (CompactForm Coin)
   UniqueSnapShotStake snapShotId credentialId
 SnapShotDelegation
   snapShotId SnapShotId
diff --git a/libs/ledger-state/src/Cardano/Ledger/State/UTxO.hs b/libs/ledger-state/src/Cardano/Ledger/State/UTxO.hs
index 5a7829de9f6..c5803cf09ee 100644
--- a/libs/ledger-state/src/Cardano/Ledger/State/UTxO.hs
+++ b/libs/ledger-state/src/Cardano/Ledger/State/UTxO.hs
@@ -34,6 +34,7 @@ import Control.Monad
 import qualified Data.ByteString.Lazy as LBS
 import Data.Compact.HashMap (toKey)
 import Data.Compact.KeyMap as KeyMap hiding (Stat)
+import qualified Data.Compact.VMap as VMap
 import Data.Foldable as F
 import Data.Functor
 import qualified Data.IntMap.Strict as IntMap
@@ -275,11 +276,11 @@ instance AggregateStat SnapShotStats where
 countSnapShotStat :: SnapShot C -> SnapShotStats
 countSnapShotStat SnapShot {..} =
   SnapShotStats
-    { sssStake = statMapKeys (unStake _stake),
-      sssDelegationCredential = statMapKeys _delegations,
-      sssDelegationStakePool = statFoldable _delegations,
-      sssPoolParams = statMapKeys _poolParams,
-      sssPoolParamsStats = foldMap countPoolParamsStats _poolParams
+    { sssStake = statMapKeys (VMap.toMap (unStake _stake)),
+      sssDelegationCredential = statMapKeys (VMap.toMap _delegations),
+      sssDelegationStakePool = statFoldable (VMap.toMap _delegations),
+      sssPoolParams = statMapKeys (VMap.toMap _poolParams),
+      sssPoolParamsStats = VMap.foldMap countPoolParamsStats _poolParams
     }
 
 data PoolParamsStats = PoolParamsStats
diff --git a/libs/ledger-state/src/Cardano/Ledger/State/Vector.hs b/libs/ledger-state/src/Cardano/Ledger/State/Vector.hs
new file mode 100644
index 00000000000..16156f8d7f2
--- /dev/null
+++ b/libs/ledger-state/src/Cardano/Ledger/State/Vector.hs
@@ -0,0 +1,41 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Cardano.Ledger.State.Vector where
+
+import Cardano.Ledger.Coin
+import Cardano.Ledger.Credential
+import Cardano.Ledger.Keys as Keys
+import Cardano.Ledger.Shelley.TxBody hiding (TxId, TxIn)
+import Cardano.Ledger.State.UTxO
+import Control.DeepSeq
+import Data.Map.Strict as Map
+
+data SnapShotM crypto = SnapShotM
+  { ssStake :: !(Map (Credential 'Staking crypto) (CompactForm Coin)),
+    ssDelegations :: !(Map (Credential 'Staking crypto) (KeyHash 'StakePool crypto)),
+    ssPoolParams :: !(Map (KeyHash 'StakePool crypto) (PoolParams crypto))
+  }
+
+instance NFData (SnapShotM C) where
+  rnf (SnapShotM s d p) = s `deepseq` d `deepseq` rnf p
+
+data SnapShotsM crypto = SnapShotsM
+  { ssPstakeMark :: !(SnapShotM crypto),
+    ssPstakeSet :: !(SnapShotM crypto),
+    ssPstakeGo :: !(SnapShotM crypto),
+    ssFeeSS :: !Coin
+  }
+
+instance NFData (SnapShotsM C) where
+  rnf (SnapShotsM r s g f) = r `deepseq` s `deepseq` g `deepseq` rnf f
diff --git a/libs/small-steps/small-steps.cabal b/libs/small-steps/small-steps.cabal
index 9bcacbc07a8..f2adef83c1e 100644
--- a/libs/small-steps/small-steps.cabal
+++ b/libs/small-steps/small-steps.cabal
@@ -56,6 +56,7 @@ library
                      , bytestring
                      , cborg
                      , containers
+                     , compact-map
                      , cryptonite
                      , data-default-class
                      , deepseq
diff --git a/libs/small-steps/src/Data/Coders.hs b/libs/small-steps/src/Data/Coders.hs
index ce6632e3721..4ea009f04ce 100644
--- a/libs/small-steps/src/Data/Coders.hs
+++ b/libs/small-steps/src/Data/Coders.hs
@@ -21,8 +21,6 @@
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
 
--- {-# OPTIONS_GHC  -fno-warn-orphans #-}
-
 -- | MemoBytes is an abstration for a datetype that encodes its own seriialization.
 --   The idea is to use a newtype around a MemoBytes non-memoizing version.
 --   For example:   newtype Foo = Foo(MemoBytes NonMemoizingFoo)
@@ -65,8 +63,10 @@ module Data.Coders
     decodeCollection,
     encodeFoldableEncoder,
     encodeMap,
+    encodeVMap,
     wrapCBORMap,
     decodeMap,
+    decodeVMap,
     decodeMapByKey,
     decodeMapContents,
     decodeMapTraverse,
@@ -89,6 +89,8 @@ module Data.Coders
     mapEncode,
     mapDecode,
     mapDecodeA,
+    vMapEncode,
+    vMapDecode,
     setEncode,
     setDecode,
     setDecodeA,
@@ -127,6 +129,7 @@ import Codec.CBOR.Decoding (Decoder, decodeTag, decodeTag64)
 import Codec.CBOR.Encoding (Encoding, encodeTag)
 import Control.Applicative (liftA2)
 import Control.Monad (replicateM, unless, when)
+import qualified Data.Compact.VMap as VMap
 import Data.Foldable (foldl')
 import Data.Functor.Compose (Compose (..))
 import qualified Data.Map as Map
@@ -140,6 +143,7 @@ import qualified Data.Text as Text
 import Data.Typeable
 import Formatting (build, formatToString)
 import Formatting.Buildable (Buildable)
+import qualified GHC.Exts as Exts
 import Numeric.Natural (Natural)
 
 -- ====================================================================
@@ -273,6 +277,17 @@ wrapCBORArray len contents =
 -- Era, which are not always cannonical. We want to make these
 -- cannonical improvements easy to use.
 
+encodeVMap ::
+  (VMap.Vector vk k, VMap.Vector vv v) =>
+  (k -> Encoding) ->
+  (v -> Encoding) ->
+  VMap.VMap vk vv k v ->
+  Encoding
+encodeVMap encodeKey encodeValue vmap =
+  let l = fromIntegral $ VMap.size vmap
+      contents = VMap.foldMapWithKey (\k v -> encodeKey k <> encodeValue v) vmap
+   in wrapCBORMap l contents
+
 encodeMap :: (a -> Encoding) -> (b -> Encoding) -> Map.Map a b -> Encoding
 encodeMap encodeKey encodeValue m =
   let l = fromIntegral $ Map.size m
@@ -285,12 +300,23 @@ wrapCBORMap len contents =
     then encodeMapLen len <> contents
     else encodeMapLenIndef <> contents <> encodeBreak
 
+decodeVMap ::
+  (VMap.Vector kv k, VMap.Vector vv v, Ord k) =>
+  Decoder s k ->
+  Decoder s v ->
+  Decoder s (VMap.VMap kv vv k v)
+decodeVMap decodeKey decodeValue = decodeMapByKey decodeKey (const decodeValue)
+
 decodeMap :: Ord a => Decoder s a -> Decoder s b -> Decoder s (Map.Map a b)
 decodeMap decodeKey decodeValue = decodeMapByKey decodeKey (const decodeValue)
 
-decodeMapByKey :: Ord a => Decoder s a -> (a -> Decoder s b) -> Decoder s (Map.Map a b)
+decodeMapByKey ::
+  (Exts.IsList t, Exts.Item t ~ (k, v)) =>
+  Decoder s k ->
+  (k -> Decoder s v) ->
+  Decoder s t
 decodeMapByKey decodeKey decodeValueFor =
-  Map.fromList
+  Exts.fromList
     <$> decodeMapContents decodeInlinedPair
   where
     decodeInlinedPair = do
@@ -765,6 +791,20 @@ mapEncode x = E (encodeMap toCBOR toCBOR) x
 mapDecode :: (Ord k, FromCBOR k, FromCBOR v) => Decode ('Closed 'Dense) (Map.Map k v)
 mapDecode = D (decodeMap fromCBOR fromCBOR)
 
+-- | (vMapEncode x) is self-documenting, correct way to encode VMap. use
+-- vMapDecode as its dual
+vMapEncode ::
+  (VMap.Vector kv k, VMap.Vector vv v, ToCBOR k, ToCBOR v) =>
+  VMap.VMap kv vv k v ->
+  Encode ('Closed 'Dense) (VMap.VMap kv vv k v)
+vMapEncode = E (encodeVMap toCBOR toCBOR)
+
+-- | (vMapDecode) is the Dual for (vMapEncode x)
+vMapDecode ::
+  (VMap.Vector kv k, VMap.Vector vv v, Ord k, FromCBOR k, FromCBOR v) =>
+  Decode ('Closed 'Dense) (VMap.VMap kv vv k v)
+vMapDecode = D (decodeVMap fromCBOR fromCBOR)
+
 -- | (setEncode x) is self-documenting (E encodeFoldable x), use setDecode as its dual
 setEncode :: (ToCBOR v) => Set.Set v -> Encode ('Closed 'Dense) (Set.Set v)
 setEncode x = E encodeFoldable x