Modules: Types (#13009)

Update Haddock submodule

Metric Increase:
   haddock.compiler

6 files changed, 1602 insertions, 0 deletions

diff --git a/compiler/GHC/Types/Unique/DFM.hs b/compiler/GHC/Types/Unique/DFM.hs
new file mode 100644
index 0000000000..21e2f8249b
--- /dev/null
+++ b/compiler/GHC/Types/Unique/DFM.hs
@@ -0,0 +1,420 @@
+{-
+(c) Bartosz Nitka, Facebook, 2015
+
+UniqDFM: Specialised deterministic finite maps, for things with @Uniques@.
+
+Basically, the things need to be in class @Uniquable@, and we use the
+@getUnique@ method to grab their @Uniques@.
+
+This is very similar to @UniqFM@, the major difference being that the order of
+folding is not dependent on @Unique@ ordering, giving determinism.
+Currently the ordering is determined by insertion order.
+
+See Note [Unique Determinism] in GHC.Types.Unique for explanation why @Unique@ ordering
+is not deterministic.
+-}
+
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TupleSections #-}
+{-# OPTIONS_GHC -Wall #-}
+
+module GHC.Types.Unique.DFM (
+        -- * Unique-keyed deterministic mappings
+        UniqDFM,       -- abstract type
+
+        -- ** Manipulating those mappings
+        emptyUDFM,
+        unitUDFM,
+        addToUDFM,
+        addToUDFM_C,
+        addListToUDFM,
+        delFromUDFM,
+        delListFromUDFM,
+        adjustUDFM,
+        alterUDFM,
+        mapUDFM,
+        plusUDFM,
+        plusUDFM_C,
+        lookupUDFM, lookupUDFM_Directly,
+        elemUDFM,
+        foldUDFM,
+        eltsUDFM,
+        filterUDFM, filterUDFM_Directly,
+        isNullUDFM,
+        sizeUDFM,
+        intersectUDFM, udfmIntersectUFM,
+        intersectsUDFM,
+        disjointUDFM, disjointUdfmUfm,
+        equalKeysUDFM,
+        minusUDFM,
+        listToUDFM,
+        udfmMinusUFM,
+        partitionUDFM,
+        anyUDFM, allUDFM,
+        pprUniqDFM, pprUDFM,
+
+        udfmToList,
+        udfmToUfm,
+        nonDetFoldUDFM,
+        alwaysUnsafeUfmToUdfm,
+    ) where
+
+import GhcPrelude
+
+import GHC.Types.Unique ( Uniquable(..), Unique, getKey )
+import Outputable
+
+import qualified Data.IntMap as M
+import Data.Data
+import Data.Functor.Classes (Eq1 (..))
+import Data.List (sortBy)
+import Data.Function (on)
+import qualified Data.Semigroup as Semi
+import GHC.Types.Unique.FM (UniqFM, listToUFM_Directly, nonDetUFMToList, ufmToIntMap)
+
+-- Note [Deterministic UniqFM]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- A @UniqDFM@ is just like @UniqFM@ with the following additional
+-- property: the function `udfmToList` returns the elements in some
+-- deterministic order not depending on the Unique key for those elements.
+--
+-- If the client of the map performs operations on the map in deterministic
+-- order then `udfmToList` returns them in deterministic order.
+--
+-- There is an implementation cost: each element is given a serial number
+-- as it is added, and `udfmToList` sorts it's result by this serial
+-- number. So you should only use `UniqDFM` if you need the deterministic
+-- property.
+--
+-- `foldUDFM` also preserves determinism.
+--
+-- Normal @UniqFM@ when you turn it into a list will use
+-- Data.IntMap.toList function that returns the elements in the order of
+-- the keys. The keys in @UniqFM@ are always @Uniques@, so you end up with
+-- with a list ordered by @Uniques@.
+-- The order of @Uniques@ is known to be not stable across rebuilds.
+-- See Note [Unique Determinism] in GHC.Types.Unique.
+--
+--
+-- There's more than one way to implement this. The implementation here tags
+-- every value with the insertion time that can later be used to sort the
+-- values when asked to convert to a list.
+--
+-- An alternative would be to have
+--
+--   data UniqDFM ele = UDFM (M.IntMap ele) [ele]
+--
+-- where the list determines the order. This makes deletion tricky as we'd
+-- only accumulate elements in that list, but makes merging easier as you
+-- can just merge both structures independently.
+-- Deletion can probably be done in amortized fashion when the size of the
+-- list is twice the size of the set.
+
+-- | A type of values tagged with insertion time
+data TaggedVal val =
+  TaggedVal
+    val
+    {-# UNPACK #-} !Int -- ^ insertion time
+  deriving (Data, Functor)
+
+taggedFst :: TaggedVal val -> val
+taggedFst (TaggedVal v _) = v
+
+taggedSnd :: TaggedVal val -> Int
+taggedSnd (TaggedVal _ i) = i
+
+instance Eq val => Eq (TaggedVal val) where
+  (TaggedVal v1 _) == (TaggedVal v2 _) = v1 == v2
+
+-- | Type of unique deterministic finite maps
+data UniqDFM ele =
+  UDFM
+    !(M.IntMap (TaggedVal ele)) -- A map where keys are Unique's values and
+                                -- values are tagged with insertion time.
+                                -- The invariant is that all the tags will
+                                -- be distinct within a single map
+    {-# UNPACK #-} !Int         -- Upper bound on the values' insertion
+                                -- time. See Note [Overflow on plusUDFM]
+  deriving (Data, Functor)
+
+-- | Deterministic, in O(n log n).
+instance Foldable UniqDFM where
+  foldr = foldUDFM
+
+-- | Deterministic, in O(n log n).
+instance Traversable UniqDFM where
+  traverse f = fmap listToUDFM_Directly
+             . traverse (\(u,a) -> (u,) <$> f a)
+             . udfmToList
+
+emptyUDFM :: UniqDFM elt
+emptyUDFM = UDFM M.empty 0
+
+unitUDFM :: Uniquable key => key -> elt -> UniqDFM elt
+unitUDFM k v = UDFM (M.singleton (getKey $ getUnique k) (TaggedVal v 0)) 1
+
+-- The new binding always goes to the right of existing ones
+addToUDFM :: Uniquable key => UniqDFM elt -> key -> elt  -> UniqDFM elt
+addToUDFM m k v = addToUDFM_Directly m (getUnique k) v
+
+-- The new binding always goes to the right of existing ones
+addToUDFM_Directly :: UniqDFM elt -> Unique -> elt -> UniqDFM elt
+addToUDFM_Directly (UDFM m i) u v
+  = UDFM (M.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1)
+  where
+    tf (TaggedVal new_v _) (TaggedVal _ old_i) = TaggedVal new_v old_i
+      -- Keep the old tag, but insert the new value
+      -- This means that udfmToList typically returns elements
+      -- in the order of insertion, rather than the reverse
+
+addToUDFM_Directly_C
+  :: (elt -> elt -> elt)   -- old -> new -> result
+  -> UniqDFM elt
+  -> Unique -> elt
+  -> UniqDFM elt
+addToUDFM_Directly_C f (UDFM m i) u v
+  = UDFM (M.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1)
+    where
+      tf (TaggedVal new_v _) (TaggedVal old_v old_i)
+         = TaggedVal (f old_v new_v) old_i
+          -- Flip the arguments, because M.insertWith uses  (new->old->result)
+          --                         but f            needs (old->new->result)
+          -- Like addToUDFM_Directly, keep the old tag
+
+addToUDFM_C
+  :: Uniquable key => (elt -> elt -> elt) -- old -> new -> result
+  -> UniqDFM elt -- old
+  -> key -> elt -- new
+  -> UniqDFM elt -- result
+addToUDFM_C f m k v = addToUDFM_Directly_C f m (getUnique k) v
+
+addListToUDFM :: Uniquable key => UniqDFM elt -> [(key,elt)] -> UniqDFM elt
+addListToUDFM = foldl' (\m (k, v) -> addToUDFM m k v)
+
+addListToUDFM_Directly :: UniqDFM elt -> [(Unique,elt)] -> UniqDFM elt
+addListToUDFM_Directly = foldl' (\m (k, v) -> addToUDFM_Directly m k v)
+
+addListToUDFM_Directly_C
+  :: (elt -> elt -> elt) -> UniqDFM elt -> [(Unique,elt)] -> UniqDFM elt
+addListToUDFM_Directly_C f = foldl' (\m (k, v) -> addToUDFM_Directly_C f m k v)
+
+delFromUDFM :: Uniquable key => UniqDFM elt -> key -> UniqDFM elt
+delFromUDFM (UDFM m i) k = UDFM (M.delete (getKey $ getUnique k) m) i
+
+plusUDFM_C :: (elt -> elt -> elt) -> UniqDFM elt -> UniqDFM elt -> UniqDFM elt
+plusUDFM_C f udfml@(UDFM _ i) udfmr@(UDFM _ j)
+  -- we will use the upper bound on the tag as a proxy for the set size,
+  -- to insert the smaller one into the bigger one
+  | i > j = insertUDFMIntoLeft_C f udfml udfmr
+  | otherwise = insertUDFMIntoLeft_C f udfmr udfml
+
+-- Note [Overflow on plusUDFM]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- There are multiple ways of implementing plusUDFM.
+-- The main problem that needs to be solved is overlap on times of
+-- insertion between different keys in two maps.
+-- Consider:
+--
+-- A = fromList [(a, (x, 1))]
+-- B = fromList [(b, (y, 1))]
+--
+-- If you merge them naively you end up with:
+--
+-- C = fromList [(a, (x, 1)), (b, (y, 1))]
+--
+-- Which loses information about ordering and brings us back into
+-- non-deterministic world.
+--
+-- The solution I considered before would increment the tags on one of the
+-- sets by the upper bound of the other set. The problem with this approach
+-- is that you'll run out of tags for some merge patterns.
+-- Say you start with A with upper bound 1, you merge A with A to get A' and
+-- the upper bound becomes 2. You merge A' with A' and the upper bound
+-- doubles again. After 64 merges you overflow.
+-- This solution would have the same time complexity as plusUFM, namely O(n+m).
+--
+-- The solution I ended up with has time complexity of
+-- O(m log m + m * min (n+m, W)) where m is the smaller set.
+-- It simply inserts the elements of the smaller set into the larger
+-- set in the order that they were inserted into the smaller set. That's
+-- O(m log m) for extracting the elements from the smaller set in the
+-- insertion order and O(m * min(n+m, W)) to insert them into the bigger
+-- set.
+
+plusUDFM :: UniqDFM elt -> UniqDFM elt -> UniqDFM elt
+plusUDFM udfml@(UDFM _ i) udfmr@(UDFM _ j)
+  -- we will use the upper bound on the tag as a proxy for the set size,
+  -- to insert the smaller one into the bigger one
+  | i > j = insertUDFMIntoLeft udfml udfmr
+  | otherwise = insertUDFMIntoLeft udfmr udfml
+
+insertUDFMIntoLeft :: UniqDFM elt -> UniqDFM elt -> UniqDFM elt
+insertUDFMIntoLeft udfml udfmr = addListToUDFM_Directly udfml $ udfmToList udfmr
+
+insertUDFMIntoLeft_C
+  :: (elt -> elt -> elt) -> UniqDFM elt -> UniqDFM elt -> UniqDFM elt
+insertUDFMIntoLeft_C f udfml udfmr =
+  addListToUDFM_Directly_C f udfml $ udfmToList udfmr
+
+lookupUDFM :: Uniquable key => UniqDFM elt -> key -> Maybe elt
+lookupUDFM (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey $ getUnique k) m
+
+lookupUDFM_Directly :: UniqDFM elt -> Unique -> Maybe elt
+lookupUDFM_Directly (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey k) m
+
+elemUDFM :: Uniquable key => key -> UniqDFM elt -> Bool
+elemUDFM k (UDFM m _i) = M.member (getKey $ getUnique k) m
+
+-- | Performs a deterministic fold over the UniqDFM.
+-- It's O(n log n) while the corresponding function on `UniqFM` is O(n).
+foldUDFM :: (elt -> a -> a) -> a -> UniqDFM elt -> a
+foldUDFM k z m = foldr k z (eltsUDFM m)
+
+-- | Performs a nondeterministic fold over the UniqDFM.
+-- It's O(n), same as the corresponding function on `UniqFM`.
+-- If you use this please provide a justification why it doesn't introduce
+-- nondeterminism.
+nonDetFoldUDFM :: (elt -> a -> a) -> a -> UniqDFM elt -> a
+nonDetFoldUDFM k z (UDFM m _i) = foldr k z $ map taggedFst $ M.elems m
+
+eltsUDFM :: UniqDFM elt -> [elt]
+eltsUDFM (UDFM m _i) =
+  map taggedFst $ sortBy (compare `on` taggedSnd) $ M.elems m
+
+filterUDFM :: (elt -> Bool) -> UniqDFM elt -> UniqDFM elt
+filterUDFM p (UDFM m i) = UDFM (M.filter (\(TaggedVal v _) -> p v) m) i
+
+filterUDFM_Directly :: (Unique -> elt -> Bool) -> UniqDFM elt -> UniqDFM elt
+filterUDFM_Directly p (UDFM m i) = UDFM (M.filterWithKey p' m) i
+  where
+  p' k (TaggedVal v _) = p (getUnique k) v
+
+-- | Converts `UniqDFM` to a list, with elements in deterministic order.
+-- It's O(n log n) while the corresponding function on `UniqFM` is O(n).
+udfmToList :: UniqDFM elt -> [(Unique, elt)]
+udfmToList (UDFM m _i) =
+  [ (getUnique k, taggedFst v)
+  | (k, v) <- sortBy (compare `on` (taggedSnd . snd)) $ M.toList m ]
+
+-- Determines whether two 'UniqDFM's contain the same keys.
+equalKeysUDFM :: UniqDFM a -> UniqDFM b -> Bool
+equalKeysUDFM (UDFM m1 _) (UDFM m2 _) = liftEq (\_ _ -> True) m1 m2
+
+isNullUDFM :: UniqDFM elt -> Bool
+isNullUDFM (UDFM m _) = M.null m
+
+sizeUDFM :: UniqDFM elt -> Int
+sizeUDFM (UDFM m _i) = M.size m
+
+intersectUDFM :: UniqDFM elt -> UniqDFM elt -> UniqDFM elt
+intersectUDFM (UDFM x i) (UDFM y _j) = UDFM (M.intersection x y) i
+  -- M.intersection is left biased, that means the result will only have
+  -- a subset of elements from the left set, so `i` is a good upper bound.
+
+udfmIntersectUFM :: UniqDFM elt1 -> UniqFM elt2 -> UniqDFM elt1
+udfmIntersectUFM (UDFM x i) y = UDFM (M.intersection x (ufmToIntMap y)) i
+  -- M.intersection is left biased, that means the result will only have
+  -- a subset of elements from the left set, so `i` is a good upper bound.
+
+intersectsUDFM :: UniqDFM elt -> UniqDFM elt -> Bool
+intersectsUDFM x y = isNullUDFM (x `intersectUDFM` y)
+
+disjointUDFM :: UniqDFM elt -> UniqDFM elt -> Bool
+disjointUDFM (UDFM x _i) (UDFM y _j) = M.null (M.intersection x y)
+
+disjointUdfmUfm :: UniqDFM elt -> UniqFM elt2 -> Bool
+disjointUdfmUfm (UDFM x _i) y = M.null (M.intersection x (ufmToIntMap y))
+
+minusUDFM :: UniqDFM elt1 -> UniqDFM elt2 -> UniqDFM elt1
+minusUDFM (UDFM x i) (UDFM y _j) = UDFM (M.difference x y) i
+  -- M.difference returns a subset of a left set, so `i` is a good upper
+  -- bound.
+
+udfmMinusUFM :: UniqDFM elt1 -> UniqFM elt2 -> UniqDFM elt1
+udfmMinusUFM (UDFM x i) y = UDFM (M.difference x (ufmToIntMap y)) i
+  -- M.difference returns a subset of a left set, so `i` is a good upper
+  -- bound.
+
+-- | Partition UniqDFM into two UniqDFMs according to the predicate
+partitionUDFM :: (elt -> Bool) -> UniqDFM elt -> (UniqDFM elt, UniqDFM elt)
+partitionUDFM p (UDFM m i) =
+  case M.partition (p . taggedFst) m of
+    (left, right) -> (UDFM left i, UDFM right i)
+
+-- | Delete a list of elements from a UniqDFM
+delListFromUDFM  :: Uniquable key => UniqDFM elt -> [key] -> UniqDFM elt
+delListFromUDFM = foldl' delFromUDFM
+
+-- | This allows for lossy conversion from UniqDFM to UniqFM
+udfmToUfm :: UniqDFM elt -> UniqFM elt
+udfmToUfm (UDFM m _i) =
+  listToUFM_Directly [(getUnique k, taggedFst tv) | (k, tv) <- M.toList m]
+
+listToUDFM :: Uniquable key => [(key,elt)] -> UniqDFM elt
+listToUDFM = foldl' (\m (k, v) -> addToUDFM m k v) emptyUDFM
+
+listToUDFM_Directly :: [(Unique, elt)] -> UniqDFM elt
+listToUDFM_Directly = foldl' (\m (u, v) -> addToUDFM_Directly m u v) emptyUDFM
+
+-- | Apply a function to a particular element
+adjustUDFM :: Uniquable key => (elt -> elt) -> UniqDFM elt -> key -> UniqDFM elt
+adjustUDFM f (UDFM m i) k = UDFM (M.adjust (fmap f) (getKey $ getUnique k) m) i
+
+-- | The expression (alterUDFM f k map) alters value x at k, or absence
+-- thereof. alterUDFM can be used to insert, delete, or update a value in
+-- UniqDFM. Use addToUDFM, delFromUDFM or adjustUDFM when possible, they are
+-- more efficient.
+alterUDFM
+  :: Uniquable key
+  => (Maybe elt -> Maybe elt)  -- How to adjust
+  -> UniqDFM elt               -- old
+  -> key                       -- new
+  -> UniqDFM elt               -- result
+alterUDFM f (UDFM m i) k =
+  UDFM (M.alter alterf (getKey $ getUnique k) m) (i + 1)
+  where
+  alterf Nothing = inject $ f Nothing
+  alterf (Just (TaggedVal v _)) = inject $ f (Just v)
+  inject Nothing = Nothing
+  inject (Just v) = Just $ TaggedVal v i
+
+-- | Map a function over every value in a UniqDFM
+mapUDFM :: (elt1 -> elt2) -> UniqDFM elt1 -> UniqDFM elt2
+mapUDFM f (UDFM m i) = UDFM (M.map (fmap f) m) i
+
+anyUDFM :: (elt -> Bool) -> UniqDFM elt -> Bool
+anyUDFM p (UDFM m _i) = M.foldr ((||) . p . taggedFst) False m
+
+allUDFM :: (elt -> Bool) -> UniqDFM elt -> Bool
+allUDFM p (UDFM m _i) = M.foldr ((&&) . p . taggedFst) True m
+
+instance Semi.Semigroup (UniqDFM a) where
+  (<>) = plusUDFM
+
+instance Monoid (UniqDFM a) where
+  mempty = emptyUDFM
+  mappend = (Semi.<>)
+
+-- This should not be used in committed code, provided for convenience to
+-- make ad-hoc conversions when developing
+alwaysUnsafeUfmToUdfm :: UniqFM elt -> UniqDFM elt
+alwaysUnsafeUfmToUdfm = listToUDFM_Directly . nonDetUFMToList
+
+-- Output-ery
+
+instance Outputable a => Outputable (UniqDFM a) where
+    ppr ufm = pprUniqDFM ppr ufm
+
+pprUniqDFM :: (a -> SDoc) -> UniqDFM a -> SDoc
+pprUniqDFM ppr_elt ufm
+  = brackets $ fsep $ punctuate comma $
+    [ ppr uq <+> text ":->" <+> ppr_elt elt
+    | (uq, elt) <- udfmToList ufm ]
+
+pprUDFM :: UniqDFM a    -- ^ The things to be pretty printed
+       -> ([a] -> SDoc) -- ^ The pretty printing function to use on the elements
+       -> SDoc          -- ^ 'SDoc' where the things have been pretty
+                        -- printed
+pprUDFM ufm pp = pp (eltsUDFM ufm)
diff --git a/compiler/GHC/Types/Unique/DSet.hs b/compiler/GHC/Types/Unique/DSet.hs
new file mode 100644
index 0000000000..32d32536df
--- /dev/null
+++ b/compiler/GHC/Types/Unique/DSet.hs
@@ -0,0 +1,141 @@
+-- (c) Bartosz Nitka, Facebook, 2015
+
+-- |
+-- Specialised deterministic sets, for things with @Uniques@
+--
+-- Based on 'UniqDFM's (as you would expect).
+-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why we need it.
+--
+-- Basically, the things need to be in class 'Uniquable'.
+
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module GHC.Types.Unique.DSet (
+        -- * Unique set type
+        UniqDSet,    -- type synonym for UniqFM a
+        getUniqDSet,
+        pprUniqDSet,
+
+        -- ** Manipulating these sets
+        delOneFromUniqDSet, delListFromUniqDSet,
+        emptyUniqDSet,
+        unitUniqDSet,
+        mkUniqDSet,
+        addOneToUniqDSet, addListToUniqDSet,
+        unionUniqDSets, unionManyUniqDSets,
+        minusUniqDSet, uniqDSetMinusUniqSet,
+        intersectUniqDSets, uniqDSetIntersectUniqSet,
+        foldUniqDSet,
+        elementOfUniqDSet,
+        filterUniqDSet,
+        sizeUniqDSet,
+        isEmptyUniqDSet,
+        lookupUniqDSet,
+        uniqDSetToList,
+        partitionUniqDSet,
+        mapUniqDSet
+    ) where
+
+import GhcPrelude
+
+import Outputable
+import GHC.Types.Unique.DFM
+import GHC.Types.Unique.Set
+import GHC.Types.Unique
+
+import Data.Coerce
+import Data.Data
+import qualified Data.Semigroup as Semi
+
+-- See Note [UniqSet invariant] in GHC.Types.Unique.Set for why we want a newtype here.
+-- Beyond preserving invariants, we may also want to 'override' typeclass
+-- instances.
+
+newtype UniqDSet a = UniqDSet {getUniqDSet' :: UniqDFM a}
+                   deriving (Data, Semi.Semigroup, Monoid)
+
+emptyUniqDSet :: UniqDSet a
+emptyUniqDSet = UniqDSet emptyUDFM
+
+unitUniqDSet :: Uniquable a => a -> UniqDSet a
+unitUniqDSet x = UniqDSet (unitUDFM x x)
+
+mkUniqDSet :: Uniquable a => [a] -> UniqDSet a
+mkUniqDSet = foldl' addOneToUniqDSet emptyUniqDSet
+
+-- The new element always goes to the right of existing ones.
+addOneToUniqDSet :: Uniquable a => UniqDSet a -> a -> UniqDSet a
+addOneToUniqDSet (UniqDSet set) x = UniqDSet (addToUDFM set x x)
+
+addListToUniqDSet :: Uniquable a => UniqDSet a -> [a] -> UniqDSet a
+addListToUniqDSet = foldl' addOneToUniqDSet
+
+delOneFromUniqDSet :: Uniquable a => UniqDSet a -> a -> UniqDSet a
+delOneFromUniqDSet (UniqDSet s) = UniqDSet . delFromUDFM s
+
+delListFromUniqDSet :: Uniquable a => UniqDSet a -> [a] -> UniqDSet a
+delListFromUniqDSet (UniqDSet s) = UniqDSet . delListFromUDFM s
+
+unionUniqDSets :: UniqDSet a -> UniqDSet a -> UniqDSet a
+unionUniqDSets (UniqDSet s) (UniqDSet t) = UniqDSet (plusUDFM s t)
+
+unionManyUniqDSets :: [UniqDSet a] -> UniqDSet a
+unionManyUniqDSets [] = emptyUniqDSet
+unionManyUniqDSets sets = foldr1 unionUniqDSets sets
+
+minusUniqDSet :: UniqDSet a -> UniqDSet a -> UniqDSet a
+minusUniqDSet (UniqDSet s) (UniqDSet t) = UniqDSet (minusUDFM s t)
+
+uniqDSetMinusUniqSet :: UniqDSet a -> UniqSet b -> UniqDSet a
+uniqDSetMinusUniqSet xs ys
+  = UniqDSet (udfmMinusUFM (getUniqDSet xs) (getUniqSet ys))
+
+intersectUniqDSets :: UniqDSet a -> UniqDSet a -> UniqDSet a
+intersectUniqDSets (UniqDSet s) (UniqDSet t) = UniqDSet (intersectUDFM s t)
+
+uniqDSetIntersectUniqSet :: UniqDSet a -> UniqSet b -> UniqDSet a
+uniqDSetIntersectUniqSet xs ys
+  = UniqDSet (udfmIntersectUFM (getUniqDSet xs) (getUniqSet ys))
+
+foldUniqDSet :: (a -> b -> b) -> b -> UniqDSet a -> b
+foldUniqDSet c n (UniqDSet s) = foldUDFM c n s
+
+elementOfUniqDSet :: Uniquable a => a -> UniqDSet a -> Bool
+elementOfUniqDSet k = elemUDFM k . getUniqDSet
+
+filterUniqDSet :: (a -> Bool) -> UniqDSet a -> UniqDSet a
+filterUniqDSet p (UniqDSet s) = UniqDSet (filterUDFM p s)
+
+sizeUniqDSet :: UniqDSet a -> Int
+sizeUniqDSet = sizeUDFM . getUniqDSet
+
+isEmptyUniqDSet :: UniqDSet a -> Bool
+isEmptyUniqDSet = isNullUDFM . getUniqDSet
+
+lookupUniqDSet :: Uniquable a => UniqDSet a -> a -> Maybe a
+lookupUniqDSet = lookupUDFM . getUniqDSet
+
+uniqDSetToList :: UniqDSet a -> [a]
+uniqDSetToList = eltsUDFM . getUniqDSet
+
+partitionUniqDSet :: (a -> Bool) -> UniqDSet a -> (UniqDSet a, UniqDSet a)
+partitionUniqDSet p = coerce . partitionUDFM p . getUniqDSet
+
+-- See Note [UniqSet invariant] in GHC.Types.Unique.Set
+mapUniqDSet :: Uniquable b => (a -> b) -> UniqDSet a -> UniqDSet b
+mapUniqDSet f = mkUniqDSet . map f . uniqDSetToList
+
+-- Two 'UniqDSet's are considered equal if they contain the same
+-- uniques.
+instance Eq (UniqDSet a) where
+  UniqDSet a == UniqDSet b = equalKeysUDFM a b
+
+getUniqDSet :: UniqDSet a -> UniqDFM a
+getUniqDSet = getUniqDSet'
+
+instance Outputable a => Outputable (UniqDSet a) where
+  ppr = pprUniqDSet ppr
+
+pprUniqDSet :: (a -> SDoc) -> UniqDSet a -> SDoc
+pprUniqDSet f = braces . pprWithCommas f . uniqDSetToList
diff --git a/compiler/GHC/Types/Unique/FM.hs b/compiler/GHC/Types/Unique/FM.hs
new file mode 100644
index 0000000000..01ab645783
--- /dev/null
+++ b/compiler/GHC/Types/Unique/FM.hs
@@ -0,0 +1,416 @@
+{-
+(c) The University of Glasgow 2006
+(c) The AQUA Project, Glasgow University, 1994-1998
+
+
+UniqFM: Specialised finite maps, for things with @Uniques@.
+
+Basically, the things need to be in class @Uniquable@, and we use the
+@getUnique@ method to grab their @Uniques@.
+
+(A similar thing to @UniqSet@, as opposed to @Set@.)
+
+The interface is based on @FiniteMap@s, but the implementation uses
+@Data.IntMap@, which is both maintained and faster than the past
+implementation (see commit log).
+
+The @UniqFM@ interface maps directly to Data.IntMap, only
+``Data.IntMap.union'' is left-biased and ``plusUFM'' right-biased
+and ``addToUFM\_C'' and ``Data.IntMap.insertWith'' differ in the order
+of arguments of combining function.
+-}
+
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# OPTIONS_GHC -Wall #-}
+
+module GHC.Types.Unique.FM (
+        -- * Unique-keyed mappings
+        UniqFM,           -- abstract type
+        NonDetUniqFM(..), -- wrapper for opting into nondeterminism
+
+        -- ** Manipulating those mappings
+        emptyUFM,
+        unitUFM,
+        unitDirectlyUFM,
+        listToUFM,
+        listToUFM_Directly,
+        listToUFM_C,
+        addToUFM,addToUFM_C,addToUFM_Acc,
+        addListToUFM,addListToUFM_C,
+        addToUFM_Directly,
+        addListToUFM_Directly,
+        adjustUFM, alterUFM,
+        adjustUFM_Directly,
+        delFromUFM,
+        delFromUFM_Directly,
+        delListFromUFM,
+        delListFromUFM_Directly,
+        plusUFM,
+        plusUFM_C,
+        plusUFM_CD,
+        plusMaybeUFM_C,
+        plusUFMList,
+        minusUFM,
+        intersectUFM,
+        intersectUFM_C,
+        disjointUFM,
+        equalKeysUFM,
+        nonDetFoldUFM, foldUFM, nonDetFoldUFM_Directly,
+        anyUFM, allUFM, seqEltsUFM,
+        mapUFM, mapUFM_Directly,
+        elemUFM, elemUFM_Directly,
+        filterUFM, filterUFM_Directly, partitionUFM,
+        sizeUFM,
+        isNullUFM,
+        lookupUFM, lookupUFM_Directly,
+        lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,
+        nonDetEltsUFM, eltsUFM, nonDetKeysUFM,
+        ufmToSet_Directly,
+        nonDetUFMToList, ufmToIntMap,
+        pprUniqFM, pprUFM, pprUFMWithKeys, pluralUFM
+    ) where
+
+import GhcPrelude
+
+import GHC.Types.Unique ( Uniquable(..), Unique, getKey )
+import Outputable
+
+import qualified Data.IntMap as M
+import qualified Data.IntSet as S
+import Data.Data
+import qualified Data.Semigroup as Semi
+import Data.Functor.Classes (Eq1 (..))
+
+
+newtype UniqFM ele = UFM (M.IntMap ele)
+  deriving (Data, Eq, Functor)
+  -- Nondeterministic Foldable and Traversable instances are accessible through
+  -- use of the 'NonDetUniqFM' wrapper.
+  -- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM to learn about determinism.
+
+emptyUFM :: UniqFM elt
+emptyUFM = UFM M.empty
+
+isNullUFM :: UniqFM elt -> Bool
+isNullUFM (UFM m) = M.null m
+
+unitUFM :: Uniquable key => key -> elt -> UniqFM elt
+unitUFM k v = UFM (M.singleton (getKey $ getUnique k) v)
+
+-- when you've got the Unique already
+unitDirectlyUFM :: Unique -> elt -> UniqFM elt
+unitDirectlyUFM u v = UFM (M.singleton (getKey u) v)
+
+listToUFM :: Uniquable key => [(key,elt)] -> UniqFM elt
+listToUFM = foldl' (\m (k, v) -> addToUFM m k v) emptyUFM
+
+listToUFM_Directly :: [(Unique, elt)] -> UniqFM elt
+listToUFM_Directly = foldl' (\m (u, v) -> addToUFM_Directly m u v) emptyUFM
+
+listToUFM_C
+  :: Uniquable key
+  => (elt -> elt -> elt)
+  -> [(key, elt)]
+  -> UniqFM elt
+listToUFM_C f = foldl' (\m (k, v) -> addToUFM_C f m k v) emptyUFM
+
+addToUFM :: Uniquable key => UniqFM elt -> key -> elt  -> UniqFM elt
+addToUFM (UFM m) k v = UFM (M.insert (getKey $ getUnique k) v m)
+
+addListToUFM :: Uniquable key => UniqFM elt -> [(key,elt)] -> UniqFM elt
+addListToUFM = foldl' (\m (k, v) -> addToUFM m k v)
+
+addListToUFM_Directly :: UniqFM elt -> [(Unique,elt)] -> UniqFM elt
+addListToUFM_Directly = foldl' (\m (k, v) -> addToUFM_Directly m k v)
+
+addToUFM_Directly :: UniqFM elt -> Unique -> elt -> UniqFM elt
+addToUFM_Directly (UFM m) u v = UFM (M.insert (getKey u) v m)
+
+addToUFM_C
+  :: Uniquable key
+  => (elt -> elt -> elt)  -- old -> new -> result
+  -> UniqFM elt           -- old
+  -> key -> elt           -- new
+  -> UniqFM elt           -- result
+-- Arguments of combining function of M.insertWith and addToUFM_C are flipped.
+addToUFM_C f (UFM m) k v =
+  UFM (M.insertWith (flip f) (getKey $ getUnique k) v m)
+
+addToUFM_Acc
+  :: Uniquable key
+  => (elt -> elts -> elts)  -- Add to existing
+  -> (elt -> elts)          -- New element
+  -> UniqFM elts            -- old
+  -> key -> elt             -- new
+  -> UniqFM elts            -- result
+addToUFM_Acc exi new (UFM m) k v =
+  UFM (M.insertWith (\_new old -> exi v old) (getKey $ getUnique k) (new v) m)
+
+alterUFM
+  :: Uniquable key
+  => (Maybe elt -> Maybe elt)  -- How to adjust
+  -> UniqFM elt                -- old
+  -> key                       -- new
+  -> UniqFM elt                -- result
+alterUFM f (UFM m) k = UFM (M.alter f (getKey $ getUnique k) m)
+
+addListToUFM_C
+  :: Uniquable key
+  => (elt -> elt -> elt)
+  -> UniqFM elt -> [(key,elt)]
+  -> UniqFM elt
+addListToUFM_C f = foldl' (\m (k, v) -> addToUFM_C f m k v)
+
+adjustUFM :: Uniquable key => (elt -> elt) -> UniqFM elt -> key -> UniqFM elt
+adjustUFM f (UFM m) k = UFM (M.adjust f (getKey $ getUnique k) m)
+
+adjustUFM_Directly :: (elt -> elt) -> UniqFM elt -> Unique -> UniqFM elt
+adjustUFM_Directly f (UFM m) u = UFM (M.adjust f (getKey u) m)
+
+delFromUFM :: Uniquable key => UniqFM elt -> key    -> UniqFM elt
+delFromUFM (UFM m) k = UFM (M.delete (getKey $ getUnique k) m)
+
+delListFromUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt
+delListFromUFM = foldl' delFromUFM
+
+delListFromUFM_Directly :: UniqFM elt -> [Unique] -> UniqFM elt
+delListFromUFM_Directly = foldl' delFromUFM_Directly
+
+delFromUFM_Directly :: UniqFM elt -> Unique -> UniqFM elt
+delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m)
+
+-- Bindings in right argument shadow those in the left
+plusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
+-- M.union is left-biased, plusUFM should be right-biased.
+plusUFM (UFM x) (UFM y) = UFM (M.union y x)
+     -- Note (M.union y x), with arguments flipped
+     -- M.union is left-biased, plusUFM should be right-biased.
+
+plusUFM_C :: (elt -> elt -> elt) -> UniqFM elt -> UniqFM elt -> UniqFM elt
+plusUFM_C f (UFM x) (UFM y) = UFM (M.unionWith f x y)
+
+-- | `plusUFM_CD f m1 d1 m2 d2` merges the maps using `f` as the
+-- combinding function and `d1` resp. `d2` as the default value if
+-- there is no entry in `m1` reps. `m2`. The domain is the union of
+-- the domains of `m1` and `m2`.
+--
+-- Representative example:
+--
+-- @
+-- plusUFM_CD f {A: 1, B: 2} 23 {B: 3, C: 4} 42
+--    == {A: f 1 42, B: f 2 3, C: f 23 4 }
+-- @
+plusUFM_CD
+  :: (elt -> elt -> elt)
+  -> UniqFM elt  -- map X
+  -> elt         -- default for X
+  -> UniqFM elt  -- map Y
+  -> elt         -- default for Y
+  -> UniqFM elt
+plusUFM_CD f (UFM xm) dx (UFM ym) dy
+  = UFM $ M.mergeWithKey
+      (\_ x y -> Just (x `f` y))
+      (M.map (\x -> x `f` dy))
+      (M.map (\y -> dx `f` y))
+      xm ym
+
+plusMaybeUFM_C :: (elt -> elt -> Maybe elt)
+               -> UniqFM elt -> UniqFM elt -> UniqFM elt
+plusMaybeUFM_C f (UFM xm) (UFM ym)
+    = UFM $ M.mergeWithKey
+        (\_ x y -> x `f` y)
+        id
+        id
+        xm ym
+
+plusUFMList :: [UniqFM elt] -> UniqFM elt
+plusUFMList = foldl' plusUFM emptyUFM
+
+minusUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1
+minusUFM (UFM x) (UFM y) = UFM (M.difference x y)
+
+intersectUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1
+intersectUFM (UFM x) (UFM y) = UFM (M.intersection x y)
+
+intersectUFM_C
+  :: (elt1 -> elt2 -> elt3)
+  -> UniqFM elt1
+  -> UniqFM elt2
+  -> UniqFM elt3
+intersectUFM_C f (UFM x) (UFM y) = UFM (M.intersectionWith f x y)
+
+disjointUFM :: UniqFM elt1 -> UniqFM elt2 -> Bool
+disjointUFM (UFM x) (UFM y) = M.null (M.intersection x y)
+
+foldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a
+foldUFM k z (UFM m) = M.foldr k z m
+
+mapUFM :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2
+mapUFM f (UFM m) = UFM (M.map f m)
+
+mapUFM_Directly :: (Unique -> elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2
+mapUFM_Directly f (UFM m) = UFM (M.mapWithKey (f . getUnique) m)
+
+filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt
+filterUFM p (UFM m) = UFM (M.filter p m)
+
+filterUFM_Directly :: (Unique -> elt -> Bool) -> UniqFM elt -> UniqFM elt
+filterUFM_Directly p (UFM m) = UFM (M.filterWithKey (p . getUnique) m)
+
+partitionUFM :: (elt -> Bool) -> UniqFM elt -> (UniqFM elt, UniqFM elt)
+partitionUFM p (UFM m) =
+  case M.partition p m of
+    (left, right) -> (UFM left, UFM right)
+
+sizeUFM :: UniqFM elt -> Int
+sizeUFM (UFM m) = M.size m
+
+elemUFM :: Uniquable key => key -> UniqFM elt -> Bool
+elemUFM k (UFM m) = M.member (getKey $ getUnique k) m
+
+elemUFM_Directly :: Unique -> UniqFM elt -> Bool
+elemUFM_Directly u (UFM m) = M.member (getKey u) m
+
+lookupUFM :: Uniquable key => UniqFM elt -> key -> Maybe elt
+lookupUFM (UFM m) k = M.lookup (getKey $ getUnique k) m
+
+-- when you've got the Unique already
+lookupUFM_Directly :: UniqFM elt -> Unique -> Maybe elt
+lookupUFM_Directly (UFM m) u = M.lookup (getKey u) m
+
+lookupWithDefaultUFM :: Uniquable key => UniqFM elt -> elt -> key -> elt
+lookupWithDefaultUFM (UFM m) v k = M.findWithDefault v (getKey $ getUnique k) m
+
+lookupWithDefaultUFM_Directly :: UniqFM elt -> elt -> Unique -> elt
+lookupWithDefaultUFM_Directly (UFM m) v u = M.findWithDefault v (getKey u) m
+
+eltsUFM :: UniqFM elt -> [elt]
+eltsUFM (UFM m) = M.elems m
+
+ufmToSet_Directly :: UniqFM elt -> S.IntSet
+ufmToSet_Directly (UFM m) = M.keysSet m
+
+anyUFM :: (elt -> Bool) -> UniqFM elt -> Bool
+anyUFM p (UFM m) = M.foldr ((||) . p) False m
+
+allUFM :: (elt -> Bool) -> UniqFM elt -> Bool
+allUFM p (UFM m) = M.foldr ((&&) . p) True m
+
+seqEltsUFM :: ([elt] -> ()) -> UniqFM elt -> ()
+seqEltsUFM seqList = seqList . nonDetEltsUFM
+  -- It's OK to use nonDetEltsUFM here because the type guarantees that
+  -- the only interesting thing this function can do is to force the
+  -- elements.
+
+-- See Note [Deterministic UniqFM] to learn about nondeterminism.
+-- If you use this please provide a justification why it doesn't introduce
+-- nondeterminism.
+nonDetEltsUFM :: UniqFM elt -> [elt]
+nonDetEltsUFM (UFM m) = M.elems m
+
+-- See Note [Deterministic UniqFM] to learn about nondeterminism.
+-- If you use this please provide a justification why it doesn't introduce
+-- nondeterminism.
+nonDetKeysUFM :: UniqFM elt -> [Unique]
+nonDetKeysUFM (UFM m) = map getUnique $ M.keys m
+
+-- See Note [Deterministic UniqFM] to learn about nondeterminism.
+-- If you use this please provide a justification why it doesn't introduce
+-- nondeterminism.
+nonDetFoldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a
+nonDetFoldUFM k z (UFM m) = M.foldr k z m
+
+-- See Note [Deterministic UniqFM] to learn about nondeterminism.
+-- If you use this please provide a justification why it doesn't introduce
+-- nondeterminism.
+nonDetFoldUFM_Directly:: (Unique -> elt -> a -> a) -> a -> UniqFM elt -> a
+nonDetFoldUFM_Directly k z (UFM m) = M.foldrWithKey (k . getUnique) z m
+
+-- See Note [Deterministic UniqFM] to learn about nondeterminism.
+-- If you use this please provide a justification why it doesn't introduce
+-- nondeterminism.
+nonDetUFMToList :: UniqFM elt -> [(Unique, elt)]
+nonDetUFMToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m
+
+-- | A wrapper around 'UniqFM' with the sole purpose of informing call sites
+-- that the provided 'Foldable' and 'Traversable' instances are
+-- nondeterministic.
+-- If you use this please provide a justification why it doesn't introduce
+-- nondeterminism.
+-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM to learn about determinism.
+newtype NonDetUniqFM ele = NonDetUniqFM { getNonDet :: UniqFM ele }
+  deriving (Functor)
+
+-- | Inherently nondeterministic.
+-- If you use this please provide a justification why it doesn't introduce
+-- nondeterminism.
+-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM to learn about determinism.
+instance Foldable NonDetUniqFM where
+  foldr f z (NonDetUniqFM (UFM m)) = foldr f z m
+
+-- | Inherently nondeterministic.
+-- If you use this please provide a justification why it doesn't introduce
+-- nondeterminism.
+-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM to learn about determinism.
+instance Traversable NonDetUniqFM where
+  traverse f (NonDetUniqFM (UFM m)) = NonDetUniqFM . UFM <$> traverse f m
+
+ufmToIntMap :: UniqFM elt -> M.IntMap elt
+ufmToIntMap (UFM m) = m
+
+-- Determines whether two 'UniqFM's contain the same keys.
+equalKeysUFM :: UniqFM a -> UniqFM b -> Bool
+equalKeysUFM (UFM m1) (UFM m2) = liftEq (\_ _ -> True) m1 m2
+
+-- Instances
+
+instance Semi.Semigroup (UniqFM a) where
+  (<>) = plusUFM
+
+instance Monoid (UniqFM a) where
+    mempty = emptyUFM
+    mappend = (Semi.<>)
+
+-- Output-ery
+
+instance Outputable a => Outputable (UniqFM a) where
+    ppr ufm = pprUniqFM ppr ufm
+
+pprUniqFM :: (a -> SDoc) -> UniqFM a -> SDoc
+pprUniqFM ppr_elt ufm
+  = brackets $ fsep $ punctuate comma $
+    [ ppr uq <+> text ":->" <+> ppr_elt elt
+    | (uq, elt) <- nonDetUFMToList ufm ]
+  -- It's OK to use nonDetUFMToList here because we only use it for
+  -- pretty-printing.
+
+-- | Pretty-print a non-deterministic set.
+-- The order of variables is non-deterministic and for pretty-printing that
+-- shouldn't be a problem.
+-- Having this function helps contain the non-determinism created with
+-- nonDetEltsUFM.
+pprUFM :: UniqFM a      -- ^ The things to be pretty printed
+       -> ([a] -> SDoc) -- ^ The pretty printing function to use on the elements
+       -> SDoc          -- ^ 'SDoc' where the things have been pretty
+                        -- printed
+pprUFM ufm pp = pp (nonDetEltsUFM ufm)
+
+-- | Pretty-print a non-deterministic set.
+-- The order of variables is non-deterministic and for pretty-printing that
+-- shouldn't be a problem.
+-- Having this function helps contain the non-determinism created with
+-- nonDetUFMToList.
+pprUFMWithKeys
+       :: UniqFM a                -- ^ The things to be pretty printed
+       -> ([(Unique, a)] -> SDoc) -- ^ The pretty printing function to use on the elements
+       -> SDoc                    -- ^ 'SDoc' where the things have been pretty
+                                  -- printed
+pprUFMWithKeys ufm pp = pp (nonDetUFMToList ufm)
+
+-- | Determines the pluralisation suffix appropriate for the length of a set
+-- in the same way that plural from Outputable does for lists.
+pluralUFM :: UniqFM a -> SDoc
+pluralUFM ufm
+  | sizeUFM ufm == 1 = empty
+  | otherwise = char 's'
diff --git a/compiler/GHC/Types/Unique/Map.hs b/compiler/GHC/Types/Unique/Map.hs
new file mode 100644
index 0000000000..5b06864629
--- /dev/null
+++ b/compiler/GHC/Types/Unique/Map.hs
@@ -0,0 +1,206 @@
+{-# LANGUAGE RoleAnnotations #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# OPTIONS_GHC -Wall #-}
+
+-- Like 'UniqFM', these are maps for keys which are Uniquable.
+-- Unlike 'UniqFM', these maps also remember their keys, which
+-- makes them a much better drop in replacement for 'Data.Map.Map'.
+--
+-- Key preservation is right-biased.
+module GHC.Types.Unique.Map (
+    UniqMap,
+    emptyUniqMap,
+    isNullUniqMap,
+    unitUniqMap,
+    listToUniqMap,
+    listToUniqMap_C,
+    addToUniqMap,
+    addListToUniqMap,
+    addToUniqMap_C,
+    addToUniqMap_Acc,
+    alterUniqMap,
+    addListToUniqMap_C,
+    adjustUniqMap,
+    delFromUniqMap,
+    delListFromUniqMap,
+    plusUniqMap,
+    plusUniqMap_C,
+    plusMaybeUniqMap_C,
+    plusUniqMapList,
+    minusUniqMap,
+    intersectUniqMap,
+    disjointUniqMap,
+    mapUniqMap,
+    filterUniqMap,
+    partitionUniqMap,
+    sizeUniqMap,
+    elemUniqMap,
+    lookupUniqMap,
+    lookupWithDefaultUniqMap,
+    anyUniqMap,
+    allUniqMap,
+    -- Non-deterministic functions omitted
+) where
+
+import GhcPrelude
+
+import GHC.Types.Unique.FM
+
+import GHC.Types.Unique
+import Outputable
+
+import Data.Semigroup as Semi ( Semigroup(..) )
+import Data.Coerce
+import Data.Maybe
+import Data.Data
+
+-- | Maps indexed by 'Uniquable' keys
+newtype UniqMap k a = UniqMap (UniqFM (k, a))
+    deriving (Data, Eq, Functor)
+type role UniqMap nominal representational
+
+instance Semigroup (UniqMap k a) where
+  (<>) = plusUniqMap
+
+instance Monoid (UniqMap k a) where
+    mempty = emptyUniqMap
+    mappend = (Semi.<>)
+
+instance (Outputable k, Outputable a) => Outputable (UniqMap k a) where
+    ppr (UniqMap m) =
+        brackets $ fsep $ punctuate comma $
+        [ ppr k <+> text "->" <+> ppr v
+        | (k, v) <- eltsUFM m ]
+
+liftC :: (a -> a -> a) -> (k, a) -> (k, a) -> (k, a)
+liftC f (_, v) (k', v') = (k', f v v')
+
+emptyUniqMap :: UniqMap k a
+emptyUniqMap = UniqMap emptyUFM
+
+isNullUniqMap :: UniqMap k a -> Bool
+isNullUniqMap (UniqMap m) = isNullUFM m
+
+unitUniqMap :: Uniquable k => k -> a -> UniqMap k a
+unitUniqMap k v = UniqMap (unitUFM k (k, v))
+
+listToUniqMap :: Uniquable k => [(k,a)] -> UniqMap k a
+listToUniqMap kvs = UniqMap (listToUFM [ (k,(k,v)) | (k,v) <- kvs])
+
+listToUniqMap_C :: Uniquable k => (a -> a -> a) -> [(k,a)] -> UniqMap k a
+listToUniqMap_C f kvs = UniqMap $
+    listToUFM_C (liftC f) [ (k,(k,v)) | (k,v) <- kvs]
+
+addToUniqMap :: Uniquable k => UniqMap k a -> k -> a -> UniqMap k a
+addToUniqMap (UniqMap m) k v = UniqMap $ addToUFM m k (k, v)
+
+addListToUniqMap :: Uniquable k => UniqMap k a -> [(k,a)] -> UniqMap k a
+addListToUniqMap (UniqMap m) kvs = UniqMap $
+    addListToUFM m [(k,(k,v)) | (k,v) <- kvs]
+
+addToUniqMap_C :: Uniquable k
+               => (a -> a -> a)
+               -> UniqMap k a
+               -> k
+               -> a
+               -> UniqMap k a
+addToUniqMap_C f (UniqMap m) k v = UniqMap $
+    addToUFM_C (liftC f) m k (k, v)
+
+addToUniqMap_Acc :: Uniquable k
+                 => (b -> a -> a)
+                 -> (b -> a)
+                 -> UniqMap k a
+                 -> k
+                 -> b
+                 -> UniqMap k a
+addToUniqMap_Acc exi new (UniqMap m) k0 v0 = UniqMap $
+    addToUFM_Acc (\b (k, v) -> (k, exi b v))
+                 (\b -> (k0, new b))
+                 m k0 v0
+
+alterUniqMap :: Uniquable k
+             => (Maybe a -> Maybe a)
+             -> UniqMap k a
+             -> k
+             -> UniqMap k a
+alterUniqMap f (UniqMap m) k = UniqMap $
+    alterUFM (fmap (k,) . f . fmap snd) m k
+
+addListToUniqMap_C
+    :: Uniquable k
+    => (a -> a -> a)
+    -> UniqMap k a
+    -> [(k, a)]
+    -> UniqMap k a
+addListToUniqMap_C f (UniqMap m) kvs = UniqMap $
+    addListToUFM_C (liftC f) m
+        [(k,(k,v)) | (k,v) <- kvs]
+
+adjustUniqMap
+    :: Uniquable k
+    => (a -> a)
+    -> UniqMap k a
+    -> k
+    -> UniqMap k a
+adjustUniqMap f (UniqMap m) k = UniqMap $
+    adjustUFM (\(_,v) -> (k,f v)) m k
+
+delFromUniqMap :: Uniquable k => UniqMap k a -> k -> UniqMap k a
+delFromUniqMap (UniqMap m) k = UniqMap $ delFromUFM m k
+
+delListFromUniqMap :: Uniquable k => UniqMap k a -> [k] -> UniqMap k a
+delListFromUniqMap (UniqMap m) ks = UniqMap $ delListFromUFM m ks
+
+plusUniqMap :: UniqMap k a -> UniqMap k a -> UniqMap k a
+plusUniqMap (UniqMap m1) (UniqMap m2) = UniqMap $ plusUFM m1 m2
+
+plusUniqMap_C :: (a -> a -> a) -> UniqMap k a -> UniqMap k a -> UniqMap k a
+plusUniqMap_C f (UniqMap m1) (UniqMap m2) = UniqMap $
+    plusUFM_C (liftC f) m1 m2
+
+plusMaybeUniqMap_C :: (a -> a -> Maybe a) -> UniqMap k a -> UniqMap k a -> UniqMap k a
+plusMaybeUniqMap_C f (UniqMap m1) (UniqMap m2) = UniqMap $
+    plusMaybeUFM_C (\(_, v) (k', v') -> fmap (k',) (f v v')) m1 m2
+
+plusUniqMapList :: [UniqMap k a] -> UniqMap k a
+plusUniqMapList xs = UniqMap $ plusUFMList (coerce xs)
+
+minusUniqMap :: UniqMap k a -> UniqMap k b -> UniqMap k a
+minusUniqMap (UniqMap m1) (UniqMap m2) = UniqMap $ minusUFM m1 m2
+
+intersectUniqMap :: UniqMap k a -> UniqMap k b -> UniqMap k a
+intersectUniqMap (UniqMap m1) (UniqMap m2) = UniqMap $ intersectUFM m1 m2
+
+disjointUniqMap :: UniqMap k a -> UniqMap k b -> Bool
+disjointUniqMap (UniqMap m1) (UniqMap m2) = disjointUFM m1 m2
+
+mapUniqMap :: (a -> b) -> UniqMap k a -> UniqMap k b
+mapUniqMap f (UniqMap m) = UniqMap $ mapUFM (fmap f) m -- (,) k instance
+
+filterUniqMap :: (a -> Bool) -> UniqMap k a -> UniqMap k a
+filterUniqMap f (UniqMap m) = UniqMap $ filterUFM (f . snd) m
+
+partitionUniqMap :: (a -> Bool) -> UniqMap k a -> (UniqMap k a, UniqMap k a)
+partitionUniqMap f (UniqMap m) =
+    coerce $ partitionUFM (f . snd) m
+
+sizeUniqMap :: UniqMap k a -> Int
+sizeUniqMap (UniqMap m) = sizeUFM m
+
+elemUniqMap :: Uniquable k => k -> UniqMap k a -> Bool
+elemUniqMap k (UniqMap m) = elemUFM k m
+
+lookupUniqMap :: Uniquable k => UniqMap k a -> k -> Maybe a
+lookupUniqMap (UniqMap m) k = fmap snd (lookupUFM m k)
+
+lookupWithDefaultUniqMap :: Uniquable k => UniqMap k a -> a -> k -> a
+lookupWithDefaultUniqMap (UniqMap m) a k = fromMaybe a (fmap snd (lookupUFM m k))
+
+anyUniqMap :: (a -> Bool) -> UniqMap k a -> Bool
+anyUniqMap f (UniqMap m) = anyUFM (f . snd) m
+
+allUniqMap :: (a -> Bool) -> UniqMap k a -> Bool
+allUniqMap f (UniqMap m) = allUFM (f . snd) m
diff --git a/compiler/GHC/Types/Unique/Set.hs b/compiler/GHC/Types/Unique/Set.hs
new file mode 100644
index 0000000000..1c52a66732
--- /dev/null
+++ b/compiler/GHC/Types/Unique/Set.hs
@@ -0,0 +1,195 @@
+{-
+(c) The University of Glasgow 2006
+(c) The AQUA Project, Glasgow University, 1994-1998
+
+\section[UniqSet]{Specialised sets, for things with @Uniques@}
+
+Based on @UniqFMs@ (as you would expect).
+
+Basically, the things need to be in class @Uniquable@.
+-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module GHC.Types.Unique.Set (
+        -- * Unique set type
+        UniqSet,    -- type synonym for UniqFM a
+        getUniqSet,
+        pprUniqSet,
+
+        -- ** Manipulating these sets
+        emptyUniqSet,
+        unitUniqSet,
+        mkUniqSet,
+        addOneToUniqSet, addListToUniqSet,
+        delOneFromUniqSet, delOneFromUniqSet_Directly, delListFromUniqSet,
+        delListFromUniqSet_Directly,
+        unionUniqSets, unionManyUniqSets,
+        minusUniqSet, uniqSetMinusUFM,
+        intersectUniqSets,
+        restrictUniqSetToUFM,
+        uniqSetAny, uniqSetAll,
+        elementOfUniqSet,
+        elemUniqSet_Directly,
+        filterUniqSet,
+        filterUniqSet_Directly,
+        sizeUniqSet,
+        isEmptyUniqSet,
+        lookupUniqSet,
+        lookupUniqSet_Directly,
+        partitionUniqSet,
+        mapUniqSet,
+        unsafeUFMToUniqSet,
+        nonDetEltsUniqSet,
+        nonDetKeysUniqSet,
+        nonDetFoldUniqSet,
+        nonDetFoldUniqSet_Directly
+    ) where
+
+import GhcPrelude
+
+import GHC.Types.Unique.FM
+import GHC.Types.Unique
+import Data.Coerce
+import Outputable
+import Data.Data
+import qualified Data.Semigroup as Semi
+
+-- Note [UniqSet invariant]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~
+-- UniqSet has the following invariant:
+--   The keys in the map are the uniques of the values
+-- It means that to implement mapUniqSet you have to update
+-- both the keys and the values.
+
+newtype UniqSet a = UniqSet {getUniqSet' :: UniqFM a}
+                  deriving (Data, Semi.Semigroup, Monoid)
+
+emptyUniqSet :: UniqSet a
+emptyUniqSet = UniqSet emptyUFM
+
+unitUniqSet :: Uniquable a => a -> UniqSet a
+unitUniqSet x = UniqSet $ unitUFM x x
+
+mkUniqSet :: Uniquable a => [a]  -> UniqSet a
+mkUniqSet = foldl' addOneToUniqSet emptyUniqSet
+
+addOneToUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a
+addOneToUniqSet (UniqSet set) x = UniqSet (addToUFM set x x)
+
+addListToUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a
+addListToUniqSet = foldl' addOneToUniqSet
+
+delOneFromUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a
+delOneFromUniqSet (UniqSet s) a = UniqSet (delFromUFM s a)
+
+delOneFromUniqSet_Directly :: UniqSet a -> Unique -> UniqSet a
+delOneFromUniqSet_Directly (UniqSet s) u = UniqSet (delFromUFM_Directly s u)
+
+delListFromUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a
+delListFromUniqSet (UniqSet s) l = UniqSet (delListFromUFM s l)
+
+delListFromUniqSet_Directly :: UniqSet a -> [Unique] -> UniqSet a
+delListFromUniqSet_Directly (UniqSet s) l =
+    UniqSet (delListFromUFM_Directly s l)
+
+unionUniqSets :: UniqSet a -> UniqSet a -> UniqSet a
+unionUniqSets (UniqSet s) (UniqSet t) = UniqSet (plusUFM s t)
+
+unionManyUniqSets :: [UniqSet a] -> UniqSet a
+unionManyUniqSets = foldl' (flip unionUniqSets) emptyUniqSet
+
+minusUniqSet  :: UniqSet a -> UniqSet a -> UniqSet a
+minusUniqSet (UniqSet s) (UniqSet t) = UniqSet (minusUFM s t)
+
+intersectUniqSets :: UniqSet a -> UniqSet a -> UniqSet a
+intersectUniqSets (UniqSet s) (UniqSet t) = UniqSet (intersectUFM s t)
+
+restrictUniqSetToUFM :: UniqSet a -> UniqFM b -> UniqSet a
+restrictUniqSetToUFM (UniqSet s) m = UniqSet (intersectUFM s m)
+
+uniqSetMinusUFM :: UniqSet a -> UniqFM b -> UniqSet a
+uniqSetMinusUFM (UniqSet s) t = UniqSet (minusUFM s t)
+
+elementOfUniqSet :: Uniquable a => a -> UniqSet a -> Bool
+elementOfUniqSet a (UniqSet s) = elemUFM a s
+
+elemUniqSet_Directly :: Unique -> UniqSet a -> Bool
+elemUniqSet_Directly a (UniqSet s) = elemUFM_Directly a s
+
+filterUniqSet :: (a -> Bool) -> UniqSet a -> UniqSet a
+filterUniqSet p (UniqSet s) = UniqSet (filterUFM p s)
+
+filterUniqSet_Directly :: (Unique -> elt -> Bool) -> UniqSet elt -> UniqSet elt
+filterUniqSet_Directly f (UniqSet s) = UniqSet (filterUFM_Directly f s)
+
+partitionUniqSet :: (a -> Bool) -> UniqSet a -> (UniqSet a, UniqSet a)
+partitionUniqSet p (UniqSet s) = coerce (partitionUFM p s)
+
+uniqSetAny :: (a -> Bool) -> UniqSet a -> Bool
+uniqSetAny p (UniqSet s) = anyUFM p s
+
+uniqSetAll :: (a -> Bool) -> UniqSet a -> Bool
+uniqSetAll p (UniqSet s) = allUFM p s
+
+sizeUniqSet :: UniqSet a -> Int
+sizeUniqSet (UniqSet s) = sizeUFM s
+
+isEmptyUniqSet :: UniqSet a -> Bool
+isEmptyUniqSet (UniqSet s) = isNullUFM s
+
+lookupUniqSet :: Uniquable a => UniqSet b -> a -> Maybe b
+lookupUniqSet (UniqSet s) k = lookupUFM s k
+
+lookupUniqSet_Directly :: UniqSet a -> Unique -> Maybe a
+lookupUniqSet_Directly (UniqSet s) k = lookupUFM_Directly s k
+
+-- See Note [Deterministic UniqFM] to learn about nondeterminism.
+-- If you use this please provide a justification why it doesn't introduce
+-- nondeterminism.
+nonDetEltsUniqSet :: UniqSet elt -> [elt]
+nonDetEltsUniqSet = nonDetEltsUFM . getUniqSet'
+
+-- See Note [Deterministic UniqFM] to learn about nondeterminism.
+-- If you use this please provide a justification why it doesn't introduce
+-- nondeterminism.
+nonDetKeysUniqSet :: UniqSet elt -> [Unique]
+nonDetKeysUniqSet = nonDetKeysUFM . getUniqSet'
+
+-- See Note [Deterministic UniqFM] to learn about nondeterminism.
+-- If you use this please provide a justification why it doesn't introduce
+-- nondeterminism.
+nonDetFoldUniqSet :: (elt -> a -> a) -> a -> UniqSet elt -> a
+nonDetFoldUniqSet c n (UniqSet s) = nonDetFoldUFM c n s
+
+-- See Note [Deterministic UniqFM] to learn about nondeterminism.
+-- If you use this please provide a justification why it doesn't introduce
+-- nondeterminism.
+nonDetFoldUniqSet_Directly:: (Unique -> elt -> a -> a) -> a -> UniqSet elt -> a
+nonDetFoldUniqSet_Directly f n (UniqSet s) = nonDetFoldUFM_Directly f n s
+
+-- See Note [UniqSet invariant]
+mapUniqSet :: Uniquable b => (a -> b) -> UniqSet a -> UniqSet b
+mapUniqSet f = mkUniqSet . map f . nonDetEltsUniqSet
+
+-- Two 'UniqSet's are considered equal if they contain the same
+-- uniques.
+instance Eq (UniqSet a) where
+  UniqSet a == UniqSet b = equalKeysUFM a b
+
+getUniqSet :: UniqSet a -> UniqFM a
+getUniqSet = getUniqSet'
+
+-- | 'unsafeUFMToUniqSet' converts a @'UniqFM' a@ into a @'UniqSet' a@
+-- assuming, without checking, that it maps each 'Unique' to a value
+-- that has that 'Unique'. See Note [UniqSet invariant].
+unsafeUFMToUniqSet :: UniqFM a -> UniqSet a
+unsafeUFMToUniqSet = UniqSet
+
+instance Outputable a => Outputable (UniqSet a) where
+    ppr = pprUniqSet ppr
+
+pprUniqSet :: (a -> SDoc) -> UniqSet a -> SDoc
+-- It's OK to use nonDetUFMToList here because we only use it for
+-- pretty-printing.
+pprUniqSet f = braces . pprWithCommas f . nonDetEltsUniqSet
diff --git a/compiler/GHC/Types/Unique/Supply.hs b/compiler/GHC/Types/Unique/Supply.hs
new file mode 100644
index 0000000000..56c85efcce
--- /dev/null
+++ b/compiler/GHC/Types/Unique/Supply.hs
@@ -0,0 +1,224 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE BangPatterns #-}
+
+#if !defined(GHC_LOADED_INTO_GHCI)
+{-# LANGUAGE UnboxedTuples #-}
+#endif
+
+module GHC.Types.Unique.Supply (
+        -- * Main data type
+        UniqSupply, -- Abstractly
+
+        -- ** Operations on supplies
+        uniqFromSupply, uniqsFromSupply, -- basic ops
+        takeUniqFromSupply, uniqFromMask,
+
+        mkSplitUniqSupply,
+        splitUniqSupply, listSplitUniqSupply,
+
+        -- * Unique supply monad and its abstraction
+        UniqSM, MonadUnique(..),
+
+        -- ** Operations on the monad
+        initUs, initUs_,
+
+        -- * Set supply strategy
+        initUniqSupply
+  ) where
+
+import GhcPrelude
+
+import GHC.Types.Unique
+import PlainPanic (panic)
+
+import GHC.IO
+
+import MonadUtils
+import Control.Monad
+import Data.Bits
+import Data.Char
+import Control.Monad.Fail as Fail
+
+#include "Unique.h"
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Splittable Unique supply: @UniqSupply@}
+*                                                                      *
+************************************************************************
+-}
+
+-- | Unique Supply
+--
+-- A value of type 'UniqSupply' is unique, and it can
+-- supply /one/ distinct 'Unique'.  Also, from the supply, one can
+-- also manufacture an arbitrary number of further 'UniqueSupply' values,
+-- which will be distinct from the first and from all others.
+data UniqSupply
+  = MkSplitUniqSupply {-# UNPACK #-} !Int -- make the Unique with this
+                   UniqSupply UniqSupply
+                                -- when split => these two supplies
+
+mkSplitUniqSupply :: Char -> IO UniqSupply
+-- ^ Create a unique supply out of thin air. The character given must
+-- be distinct from those of all calls to this function in the compiler
+-- for the values generated to be truly unique.
+
+splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply)
+-- ^ Build two 'UniqSupply' from a single one, each of which
+-- can supply its own 'Unique'.
+listSplitUniqSupply :: UniqSupply -> [UniqSupply]
+-- ^ Create an infinite list of 'UniqSupply' from a single one
+uniqFromSupply  :: UniqSupply -> Unique
+-- ^ Obtain the 'Unique' from this particular 'UniqSupply'
+uniqsFromSupply :: UniqSupply -> [Unique] -- Infinite
+-- ^ Obtain an infinite list of 'Unique' that can be generated by constant splitting of the supply
+takeUniqFromSupply :: UniqSupply -> (Unique, UniqSupply)
+-- ^ Obtain the 'Unique' from this particular 'UniqSupply', and a new supply
+
+uniqFromMask :: Char -> IO Unique
+uniqFromMask mask
+  = do { uqNum <- genSym
+       ; return $! mkUnique mask uqNum }
+
+mkSplitUniqSupply c
+  = case ord c `shiftL` uNIQUE_BITS of
+     !mask -> let
+        -- here comes THE MAGIC:
+
+        -- This is one of the most hammered bits in the whole compiler
+        mk_supply
+          -- NB: Use unsafeInterleaveIO for thread-safety.
+          = unsafeInterleaveIO (
+                genSym      >>= \ u ->
+                mk_supply   >>= \ s1 ->
+                mk_supply   >>= \ s2 ->
+                return (MkSplitUniqSupply (mask .|. u) s1 s2)
+            )
+       in
+       mk_supply
+
+foreign import ccall unsafe "genSym" genSym :: IO Int
+foreign import ccall unsafe "initGenSym" initUniqSupply :: Int -> Int -> IO ()
+
+splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2)
+listSplitUniqSupply  (MkSplitUniqSupply _ s1 s2) = s1 : listSplitUniqSupply s2
+
+uniqFromSupply  (MkSplitUniqSupply n _ _)  = mkUniqueGrimily n
+uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily n : uniqsFromSupply s2
+takeUniqFromSupply (MkSplitUniqSupply n s1 _) = (mkUniqueGrimily n, s1)
+
+{-
+************************************************************************
+*                                                                      *
+\subsubsection[UniqSupply-monad]{@UniqSupply@ monad: @UniqSM@}
+*                                                                      *
+************************************************************************
+-}
+
+-- Avoids using unboxed tuples when loading into GHCi
+#if !defined(GHC_LOADED_INTO_GHCI)
+
+type UniqResult result = (# result, UniqSupply #)
+
+pattern UniqResult :: a -> b -> (# a, b #)
+pattern UniqResult x y = (# x, y #)
+{-# COMPLETE UniqResult #-}
+
+#else
+
+data UniqResult result = UniqResult !result {-# UNPACK #-} !UniqSupply
+  deriving (Functor)
+
+#endif
+
+-- | A monad which just gives the ability to obtain 'Unique's
+newtype UniqSM result = USM { unUSM :: UniqSupply -> UniqResult result }
+    deriving (Functor)
+
+instance Monad UniqSM where
+  (>>=) = thenUs
+  (>>)  = (*>)
+
+instance Applicative UniqSM where
+    pure = returnUs
+    (USM f) <*> (USM x) = USM $ \us0 -> case f us0 of
+                            UniqResult ff us1 -> case x us1 of
+                              UniqResult xx us2 -> UniqResult (ff xx) us2
+    (*>) = thenUs_
+
+-- TODO: try to get rid of this instance
+instance Fail.MonadFail UniqSM where
+    fail = panic
+
+-- | Run the 'UniqSM' action, returning the final 'UniqSupply'
+initUs :: UniqSupply -> UniqSM a -> (a, UniqSupply)
+initUs init_us m = case unUSM m init_us of { UniqResult r us -> (r, us) }
+
+-- | Run the 'UniqSM' action, discarding the final 'UniqSupply'
+initUs_ :: UniqSupply -> UniqSM a -> a
+initUs_ init_us m = case unUSM m init_us of { UniqResult r _ -> r }
+
+{-# INLINE thenUs #-}
+{-# INLINE returnUs #-}
+{-# INLINE splitUniqSupply #-}
+
+-- @thenUs@ is where we split the @UniqSupply@.
+
+liftUSM :: UniqSM a -> UniqSupply -> (a, UniqSupply)
+liftUSM (USM m) us0 = case m us0 of UniqResult a us1 -> (a, us1)
+
+instance MonadFix UniqSM where
+    mfix m = USM (\us0 -> let (r,us1) = liftUSM (m r) us0 in UniqResult r us1)
+
+thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b
+thenUs (USM expr) cont
+  = USM (\us0 -> case (expr us0) of
+                   UniqResult result us1 -> unUSM (cont result) us1)
+
+thenUs_ :: UniqSM a -> UniqSM b -> UniqSM b
+thenUs_ (USM expr) (USM cont)
+  = USM (\us0 -> case (expr us0) of { UniqResult _ us1 -> cont us1 })
+
+returnUs :: a -> UniqSM a
+returnUs result = USM (\us -> UniqResult result us)
+
+getUs :: UniqSM UniqSupply
+getUs = USM (\us0 -> case splitUniqSupply us0 of (us1,us2) -> UniqResult us1 us2)
+
+-- | A monad for generating unique identifiers
+class Monad m => MonadUnique m where
+    -- | Get a new UniqueSupply
+    getUniqueSupplyM :: m UniqSupply
+    -- | Get a new unique identifier
+    getUniqueM  :: m Unique
+    -- | Get an infinite list of new unique identifiers
+    getUniquesM :: m [Unique]
+
+    -- This default definition of getUniqueM, while correct, is not as
+    -- efficient as it could be since it needlessly generates and throws away
+    -- an extra Unique. For your instances consider providing an explicit
+    -- definition for 'getUniqueM' which uses 'takeUniqFromSupply' directly.
+    getUniqueM  = liftM uniqFromSupply  getUniqueSupplyM
+    getUniquesM = liftM uniqsFromSupply getUniqueSupplyM
+
+instance MonadUnique UniqSM where
+    getUniqueSupplyM = getUs
+    getUniqueM  = getUniqueUs
+    getUniquesM = getUniquesUs
+
+getUniqueUs :: UniqSM Unique
+getUniqueUs = USM (\us0 -> case takeUniqFromSupply us0 of
+                           (u,us1) -> UniqResult u us1)
+
+getUniquesUs :: UniqSM [Unique]
+getUniquesUs = USM (\us0 -> case splitUniqSupply us0 of
+                            (us1,us2) -> UniqResult (uniqsFromSupply us1) us2)