diff --git a/compiler/GHC/Builtin/Uniques.hs b/compiler/GHC/Builtin/Uniques.hs
index 7b95c5d11e39f00f23cec8b5b6640ea470899d1d..aae6f127466b461d5c78a24bf991d204d777ac46 100644
--- a/compiler/GHC/Builtin/Uniques.hs
+++ b/compiler/GHC/Builtin/Uniques.hs
@@ -66,8 +66,10 @@ import GHC.Data.FastString
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain (assert)
import Data.Maybe
+import GHC.Utils.Word64 (word64ToInt)
-- | Get the 'Name' associated with a known-key 'Unique'.
knownUniqueName :: Unique -> Maybe Name
@@ -83,7 +85,9 @@ knownUniqueName u =
'm' -> Just $ getCTupleDataConName n
_ -> Nothing
where
- (tag, n) = unpkUnique u
+ (tag, n') = unpkUnique u
+ -- Known unique names are guaranteed to fit in Int, so we don't need the whole Word64.
+ n = assert (isValidKnownKeyUnique u) (word64ToInt n')
{-
Note [Unique layout for unboxed sums]
@@ -115,14 +119,14 @@ mkSumTyConUnique arity =
assertPpr (arity <= 0x3f) (ppr arity) $
-- 0x3f since we only have 6 bits to encode the
-- alternative
- mkUnique 'z' (arity `shiftL` 8 .|. 0xfc)
+ mkUniqueInt 'z' (arity `shiftL` 8 .|. 0xfc)
mkSumDataConUnique :: ConTagZ -> Arity -> Unique
mkSumDataConUnique alt arity
| alt >= arity
= panic ("mkSumDataConUnique: " ++ show alt ++ " >= " ++ show arity)
| otherwise
- = mkUnique 'z' (arity `shiftL` 8 + alt `shiftL` 2) {- skip the tycon -}
+ = mkUniqueInt 'z' (arity `shiftL` 8 + alt `shiftL` 2) {- skip the tycon -}
getUnboxedSumName :: Int -> Name
getUnboxedSumName n
@@ -209,17 +213,17 @@ selector Uniques takes inspiration from the encoding for unboxed sum Uniques.
-}
mkCTupleTyConUnique :: Arity -> Unique
-mkCTupleTyConUnique a = mkUnique 'k' (2*a)
+mkCTupleTyConUnique a = mkUniqueInt 'k' (2*a)
mkCTupleDataConUnique :: Arity -> Unique
-mkCTupleDataConUnique a = mkUnique 'm' (3*a)
+mkCTupleDataConUnique a = mkUniqueInt 'm' (3*a)
mkCTupleSelIdUnique :: ConTagZ -> Arity -> Unique
mkCTupleSelIdUnique sc_pos arity
| sc_pos >= arity
= panic ("mkCTupleSelIdUnique: " ++ show sc_pos ++ " >= " ++ show arity)
| otherwise
- = mkUnique 'j' (arity `shiftL` cTupleSelIdArityBits + sc_pos)
+ = mkUniqueInt 'j' (arity `shiftL` cTupleSelIdArityBits + sc_pos)
getCTupleTyConName :: Int -> Name
getCTupleTyConName n =
@@ -262,12 +266,12 @@ cTupleSelIdPosBitmask = 0xff
-- Normal tuples
mkTupleDataConUnique :: Boxity -> Arity -> Unique
-mkTupleDataConUnique Boxed a = mkUnique '7' (3*a) -- may be used in C labels
-mkTupleDataConUnique Unboxed a = mkUnique '8' (3*a)
+mkTupleDataConUnique Boxed a = mkUniqueInt '7' (3*a) -- may be used in C labels
+mkTupleDataConUnique Unboxed a = mkUniqueInt '8' (3*a)
mkTupleTyConUnique :: Boxity -> Arity -> Unique
-mkTupleTyConUnique Boxed a = mkUnique '4' (2*a)
-mkTupleTyConUnique Unboxed a = mkUnique '5' (2*a)
+mkTupleTyConUnique Boxed a = mkUniqueInt '4' (2*a)
+mkTupleTyConUnique Unboxed a = mkUniqueInt '5' (2*a)
-- | This function is an inverse of `mkTupleTyConUnique`
isTupleTyConUnique :: Unique -> Maybe (Boxity, Arity)
@@ -278,7 +282,8 @@ isTupleTyConUnique u =
_ -> Nothing
where
(tag, n) = unpkUnique u
- (arity, i) = quotRem n 2
+ (arity', i) = quotRem n 2
+ arity = word64ToInt arity'
getTupleTyConName :: Boxity -> Int -> Name
getTupleTyConName boxity n =
@@ -298,7 +303,7 @@ getTupleDataConName boxity n =
_ -> panic "getTupleDataConName: impossible"
{-
-Note [Uniques for wired-in prelude things and known masks]
+Note [Uniques for wired-in prelude things and known tags]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Allocation of unique supply characters:
v,u: for renumbering value-, and usage- vars.
@@ -358,27 +363,27 @@ mkPrimOpIdUnique :: Int -> Unique
mkPrimOpWrapperUnique :: Int -> Unique
mkPreludeMiscIdUnique :: Int -> Unique
-mkAlphaTyVarUnique i = mkUnique '1' i
-mkPreludeClassUnique i = mkUnique '2' i
+mkAlphaTyVarUnique i = mkUniqueInt '1' i
+mkPreludeClassUnique i = mkUniqueInt '2' i
--------------------------------------------------
-mkPrimOpIdUnique op = mkUnique '9' (2*op)
-mkPrimOpWrapperUnique op = mkUnique '9' (2*op+1)
-mkPreludeMiscIdUnique i = mkUnique '0' i
+mkPrimOpIdUnique op = mkUniqueInt '9' (2*op)
+mkPrimOpWrapperUnique op = mkUniqueInt '9' (2*op+1)
+mkPreludeMiscIdUnique i = mkUniqueInt '0' i
mkPseudoUniqueE, mkBuiltinUnique :: Int -> Unique
-mkBuiltinUnique i = mkUnique 'B' i
-mkPseudoUniqueE i = mkUnique 'E' i -- used in NCG spiller to create spill VirtualRegs
+mkBuiltinUnique i = mkUniqueInt 'B' i
+mkPseudoUniqueE i = mkUniqueInt 'E' i -- used in NCG spiller to create spill VirtualRegs
mkRegSingleUnique, mkRegPairUnique, mkRegSubUnique, mkRegClassUnique :: Int -> Unique
-mkRegSingleUnique = mkUnique 'R'
-mkRegSubUnique = mkUnique 'S'
-mkRegPairUnique = mkUnique 'P'
-mkRegClassUnique = mkUnique 'L'
+mkRegSingleUnique = mkUniqueInt 'R'
+mkRegSubUnique = mkUniqueInt 'S'
+mkRegPairUnique = mkUniqueInt 'P'
+mkRegClassUnique = mkUniqueInt 'L'
mkCostCentreUnique :: Int -> Unique
-mkCostCentreUnique = mkUnique 'C'
+mkCostCentreUnique = mkUniqueInt 'C'
varNSUnique, dataNSUnique, tvNSUnique, tcNSUnique :: Unique
varNSUnique = mkUnique 'i' 0
@@ -387,7 +392,7 @@ tvNSUnique = mkUnique 'v' 0
tcNSUnique = mkUnique 'c' 0
mkFldNSUnique :: FastString -> Unique
-mkFldNSUnique fs = mkUnique 'f' (uniqueOfFS fs)
+mkFldNSUnique fs = mkUniqueInt 'f' (uniqueOfFS fs)
isFldNSUnique :: Unique -> Bool
isFldNSUnique uniq = case unpkUnique uniq of
@@ -401,7 +406,7 @@ initExitJoinUnique = mkUnique 's' 0
-- See Note [Related uniques for wired-in things]
mkPreludeTyConUnique :: Int -> Unique
-mkPreludeTyConUnique i = mkUnique '3' (2*i)
+mkPreludeTyConUnique i = mkUniqueInt '3' (2*i)
tyConRepNameUnique :: Unique -> Unique
tyConRepNameUnique u = incrUnique u
@@ -411,7 +416,7 @@ tyConRepNameUnique u = incrUnique u
-- See Note [Related uniques for wired-in things]
mkPreludeDataConUnique :: Int -> Unique
-mkPreludeDataConUnique i = mkUnique '6' (3*i) -- Must be alphabetic
+mkPreludeDataConUnique i = mkUniqueInt '6' (3*i) -- Must be alphabetic
dataConTyRepNameUnique, dataConWorkerUnique :: Unique -> Unique
dataConWorkerUnique u = incrUnique u
@@ -437,7 +442,7 @@ dataConTyRepNameUnique u = stepUnique u 2
-- A little delicate!
mkBoxingTyConUnique :: Int -> Unique
-mkBoxingTyConUnique i = mkUnique 'b' (5*i)
+mkBoxingTyConUnique i = mkUniqueInt 'b' (5*i)
boxingDataConUnique :: Unique -> Unique
boxingDataConUnique u = stepUnique u 2
diff --git a/compiler/GHC/Cmm/CommonBlockElim.hs b/compiler/GHC/Cmm/CommonBlockElim.hs
index ed6240e780a6400c711e0b17d981690dc01c4502..da9477b3390e5a0ec2dc49ec8dece3b5af977495 100644
--- a/compiler/GHC/Cmm/CommonBlockElim.hs
+++ b/compiler/GHC/Cmm/CommonBlockElim.hs
@@ -26,6 +26,7 @@ import qualified Data.Map as M
import qualified GHC.Data.TrieMap as TM
import GHC.Types.Unique.FM
import GHC.Types.Unique
+import GHC.Utils.Word64 (truncateWord64ToWord32)
import Control.Arrow (first, second)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
@@ -182,8 +183,10 @@ hash_block block =
cvt = fromInteger . toInteger
+ -- Since we are hashing, we can savely downcast Word64 to Word32 here.
+ -- Although a different hashing function may be more effective.
hash_unique :: Uniquable a => a -> Word32
- hash_unique = cvt . getKey . getUnique
+ hash_unique = truncateWord64ToWord32 . getKey . getUnique
-- | Ignore these node types for equality
dont_care :: CmmNode O x -> Bool
diff --git a/compiler/GHC/Cmm/Dataflow/Collections.hs b/compiler/GHC/Cmm/Dataflow/Collections.hs
index a7aa2716c9440c3b4aa24a441a2f8ec3e91f35b2..ae1db537e1f276eda65a7d5eb1d1943c95ef2ad3 100644
--- a/compiler/GHC/Cmm/Dataflow/Collections.hs
+++ b/compiler/GHC/Cmm/Dataflow/Collections.hs
@@ -12,10 +12,11 @@ module GHC.Cmm.Dataflow.Collections
import GHC.Prelude
-import qualified Data.IntMap.Strict as M
-import qualified Data.IntSet as S
+import qualified GHC.Data.Word64Map.Strict as M
+import qualified GHC.Data.Word64Set as S
import Data.List (foldl1')
+import Data.Word (Word64)
class IsSet set where
type ElemOf set
@@ -107,10 +108,10 @@ mapUnions maps = foldl1' mapUnion maps
-- Basic instances
-----------------------------------------------------------------------------
-newtype UniqueSet = US S.IntSet deriving (Eq, Ord, Show, Semigroup, Monoid)
+newtype UniqueSet = US S.Word64Set deriving (Eq, Ord, Show, Semigroup, Monoid)
instance IsSet UniqueSet where
- type ElemOf UniqueSet = Int
+ type ElemOf UniqueSet = Word64
setNull (US s) = S.null s
setSize (US s) = S.size s
@@ -133,11 +134,11 @@ instance IsSet UniqueSet where
setElems (US s) = S.elems s
setFromList ks = US (S.fromList ks)
-newtype UniqueMap v = UM (M.IntMap v)
+newtype UniqueMap v = UM (M.Word64Map v)
deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
instance IsMap UniqueMap where
- type KeyOf UniqueMap = Int
+ type KeyOf UniqueMap = Word64
mapNull (UM m) = M.null m
mapSize (UM m) = M.size m
diff --git a/compiler/GHC/Cmm/Dataflow/Label.hs b/compiler/GHC/Cmm/Dataflow/Label.hs
index 978a65eb61d5f7bed0766b054971a2f6cc691960..fcd1a57a5e9b4831404b35071c0b09e2b6a984fb 100644
--- a/compiler/GHC/Cmm/Dataflow/Label.hs
+++ b/compiler/GHC/Cmm/Dataflow/Label.hs
@@ -20,25 +20,26 @@ import GHC.Utils.Outputable
-- TODO: This should really just use GHC's Unique and Uniq{Set,FM}
import GHC.Cmm.Dataflow.Collections
-import GHC.Types.Unique (Uniquable(..))
+import GHC.Types.Unique (Uniquable(..), mkUniqueGrimily)
import GHC.Data.TrieMap
+import Data.Word (Word64)
-----------------------------------------------------------------------------
-- Label
-----------------------------------------------------------------------------
-newtype Label = Label { lblToUnique :: Int }
+newtype Label = Label { lblToUnique :: Word64 }
deriving (Eq, Ord)
-mkHooplLabel :: Int -> Label
+mkHooplLabel :: Word64 -> Label
mkHooplLabel = Label
instance Show Label where
show (Label n) = "L" ++ show n
instance Uniquable Label where
- getUnique label = getUnique (lblToUnique label)
+ getUnique label = mkUniqueGrimily (lblToUnique label)
instance Outputable Label where
ppr label = ppr (getUnique label)
diff --git a/compiler/GHC/Cmm/Dominators.hs b/compiler/GHC/Cmm/Dominators.hs
index 8321211e895cde59e96d55bfd094b5a64b7d1448..3b6a64b4a12c760d15702a453f18ec754d9cf89c 100644
--- a/compiler/GHC/Cmm/Dominators.hs
+++ b/compiler/GHC/Cmm/Dominators.hs
@@ -26,8 +26,7 @@ import Data.Array.IArray
import Data.Foldable()
import qualified Data.Tree as Tree
-import qualified Data.IntMap.Strict as IM
-import qualified Data.IntSet as IS
+import Data.Word
import qualified GHC.CmmToAsm.CFG.Dominators as LT
@@ -41,6 +40,9 @@ import GHC.Cmm
import GHC.Utils.Outputable( Outputable(..), text, int, hcat, (<+>))
import GHC.Utils.Misc
import GHC.Utils.Panic
+import GHC.Utils.Word64 (intToWord64)
+import qualified GHC.Data.Word64Map as WM
+import qualified GHC.Data.Word64Set as WS
-- | =Dominator sets
@@ -129,33 +131,37 @@ graphWithDominators :: forall node .
-- The implementation uses the Lengauer-Tarjan algorithm from the x86
-- back end.
+-- Technically, we do not need Word64 here, however the dominators code
+-- has to accomodate Word64 for other uses.
+
graphWithDominators g = GraphWithDominators (reachable rpblocks g) dmap rpmap
where rpblocks = revPostorderFrom (graphMap g) (g_entry g)
rplabels' = map entryLabel rpblocks
- rplabels :: Array Int Label
+ rplabels :: Array Word64 Label
rplabels = listArray bounds rplabels'
rpmap :: LabelMap RPNum
rpmap = mapFromList $ zipWith kvpair rpblocks [0..]
where kvpair block i = (entryLabel block, RPNum i)
- labelIndex :: Label -> Int
+ labelIndex :: Label -> Word64
labelIndex = flip findLabelIn imap
- where imap :: LabelMap Int
+ where imap :: LabelMap Word64
imap = mapFromList $ zip rplabels' [0..]
blockIndex = labelIndex . entryLabel
- bounds = (0, length rpblocks - 1)
+ bounds :: (Word64, Word64)
+ bounds = (0, intToWord64 (length rpblocks - 1))
ltGraph :: [Block node C C] -> LT.Graph
- ltGraph [] = IM.empty
+ ltGraph [] = WM.empty
ltGraph (block:blocks) =
- IM.insert
+ WM.insert
(blockIndex block)
- (IS.fromList $ map labelIndex $ successors block)
+ (WS.fromList $ map labelIndex $ successors block)
(ltGraph blocks)
- idom_array :: Array Int LT.Node
+ idom_array :: Array Word64 LT.Node
idom_array = array bounds $ LT.idom (0, ltGraph rpblocks)
domSet 0 = EntryNode
diff --git a/compiler/GHC/Cmm/LRegSet.hs b/compiler/GHC/Cmm/LRegSet.hs
index ed495623f13738df0838f9f3ba5877676b7009f2..fd771b3019cfc6f5c928ef00985435e62e06ab47 100644
--- a/compiler/GHC/Cmm/LRegSet.hs
+++ b/compiler/GHC/Cmm/LRegSet.hs
@@ -20,34 +20,35 @@ module GHC.Cmm.LRegSet (
import GHC.Prelude
import GHC.Types.Unique
import GHC.Cmm.Expr
+import GHC.Word
-import Data.IntSet as IntSet
+import GHC.Data.Word64Set as Word64Set
-- Compact sets for membership tests of local variables.
-type LRegSet = IntSet.IntSet
-type LRegKey = Int
+type LRegSet = Word64Set.Word64Set
+type LRegKey = Word64
emptyLRegSet :: LRegSet
-emptyLRegSet = IntSet.empty
+emptyLRegSet = Word64Set.empty
nullLRegSet :: LRegSet -> Bool
-nullLRegSet = IntSet.null
+nullLRegSet = Word64Set.null
insertLRegSet :: LocalReg -> LRegSet -> LRegSet
-insertLRegSet l = IntSet.insert (getKey (getUnique l))
+insertLRegSet l = Word64Set.insert (getKey (getUnique l))
elemLRegSet :: LocalReg -> LRegSet -> Bool
-elemLRegSet l = IntSet.member (getKey (getUnique l))
+elemLRegSet l = Word64Set.member (getKey (getUnique l))
deleteFromLRegSet :: LRegSet -> LocalReg -> LRegSet
-deleteFromLRegSet set reg = IntSet.delete (getKey . getUnique $ reg) set
+deleteFromLRegSet set reg = Word64Set.delete (getKey . getUnique $ reg) set
-sizeLRegSet :: IntSet -> Int
-sizeLRegSet = IntSet.size
+sizeLRegSet :: Word64Set -> Int
+sizeLRegSet = Word64Set.size
-plusLRegSet :: IntSet -> IntSet -> IntSet
-plusLRegSet = IntSet.union
+plusLRegSet :: Word64Set -> Word64Set -> Word64Set
+plusLRegSet = Word64Set.union
-elemsLRegSet :: IntSet -> [Int]
-elemsLRegSet = IntSet.toList
+elemsLRegSet :: Word64Set -> [Word64]
+elemsLRegSet = Word64Set.toList
diff --git a/compiler/GHC/Cmm/Sink.hs b/compiler/GHC/Cmm/Sink.hs
index 7addd439095699bbf98a29901c6d7b79800dcc93..e479e67d3638792eee251aea817b923dc2923f4d 100644
--- a/compiler/GHC/Cmm/Sink.hs
+++ b/compiler/GHC/Cmm/Sink.hs
@@ -21,7 +21,7 @@ import GHC.Platform.Regs
import GHC.Platform
import GHC.Types.Unique.FM
-import qualified Data.IntSet as IntSet
+import qualified GHC.Data.Word64Set as Word64Set
import Data.List (partition)
import Data.Maybe
@@ -175,7 +175,7 @@ cmmSink platform graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
-- Annotate the middle nodes with the registers live *after*
-- the node. This will help us decide whether we can inline
-- an assignment in the current node or not.
- live = IntSet.unions (map getLive succs)
+ live = Word64Set.unions (map getLive succs)
live_middle = gen_killL platform last live
ann_middles = annotate platform live_middle (blockToList middle)
@@ -188,7 +188,7 @@ cmmSink platform graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
-- one predecessor), so identify the join points and the set
-- of registers live in them.
(joins, nonjoins) = partition (`mapMember` join_pts) succs
- live_in_joins = IntSet.unions (map getLive joins)
+ live_in_joins = Word64Set.unions (map getLive joins)
-- We do not want to sink an assignment into multiple branches,
-- so identify the set of registers live in multiple successors.
@@ -215,7 +215,7 @@ cmmSink platform graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
live_sets' | should_drop = live_sets
| otherwise = map upd live_sets
- upd set | r `elemLRegSet` set = set `IntSet.union` live_rhs
+ upd set | r `elemLRegSet` set = set `Word64Set.union` live_rhs
| otherwise = set
live_rhs = foldRegsUsed platform (flip insertLRegSet) emptyLRegSet rhs
diff --git a/compiler/GHC/CmmToAsm/CFG.hs b/compiler/GHC/CmmToAsm/CFG.hs
index 7da070d1b5c5592c5a34c515d893b7f3a8099b0c..b1e6f83306cc9afb9a0fd379383d7de6e9d6d7ec 100644
--- a/compiler/GHC/CmmToAsm/CFG.hs
+++ b/compiler/GHC/CmmToAsm/CFG.hs
@@ -60,12 +60,16 @@ import GHC.Data.Maybe
import GHC.Types.Unique
import qualified GHC.CmmToAsm.CFG.Dominators as Dom
import GHC.CmmToAsm.CFG.Weight
+import GHC.Data.Word64Map.Strict (Word64Map)
+import GHC.Data.Word64Set (Word64Set)
import Data.IntMap.Strict (IntMap)
import Data.IntSet (IntSet)
import qualified Data.IntMap.Strict as IM
+import qualified GHC.Data.Word64Map.Strict as WM
import qualified Data.Map as M
import qualified Data.IntSet as IS
+import qualified GHC.Data.Word64Set as WS
import qualified Data.Set as S
import Data.Tree
import Data.Bifunctor
@@ -90,6 +94,7 @@ import Data.Array.Base (unsafeRead, unsafeWrite)
import Control.Monad
import GHC.Data.UnionFind
+import Data.Word
type Prob = Double
@@ -851,7 +856,7 @@ loopInfo cfg root = LoopInfo { liBackEdges = backEdges
--TODO - This should be a no op: Export constructors? Use unsafeCoerce? ...
rooted = ( fromBlockId root
- , toIntMap $ fmap toIntSet graph) :: (Int, IntMap IntSet)
+ , toWord64Map $ fmap toWord64Set graph) :: (Word64, Word64Map Word64Set)
tree = fmap toBlockId $ Dom.domTree rooted :: Tree BlockId
-- Map from Nodes to their dominators
@@ -898,10 +903,10 @@ loopInfo cfg root = LoopInfo { liBackEdges = backEdges
loopCount n = length $ nub . map fst . filter (setMember n . snd) $ bodies
in map (\n -> (n, loopCount n)) $ nodes :: [(BlockId, Int)]
- toIntSet :: LabelSet -> IntSet
- toIntSet s = IS.fromList . map fromBlockId . setElems $ s
- toIntMap :: LabelMap a -> IntMap a
- toIntMap m = IM.fromList $ map (\(x,y) -> (fromBlockId x,y)) $ mapToList m
+ toWord64Set :: LabelSet -> Word64Set
+ toWord64Set s = WS.fromList . map fromBlockId . setElems $ s
+ toWord64Map :: LabelMap a -> Word64Map a
+ toWord64Map m = WM.fromList $ map (\(x,y) -> (fromBlockId x,y)) $ mapToList m
mkDomMap :: Tree BlockId -> LabelMap LabelSet
mkDomMap root = mapFromList $ go setEmpty root
@@ -916,10 +921,10 @@ loopInfo cfg root = LoopInfo { liBackEdges = backEdges
(\n -> go (setInsert (rootLabel n) parents) n)
leaves
- fromBlockId :: BlockId -> Int
+ fromBlockId :: BlockId -> Word64
fromBlockId = getKey . getUnique
- toBlockId :: Int -> BlockId
+ toBlockId :: Word64 -> BlockId
toBlockId = mkBlockId . mkUniqueGrimily
-- We make the CFG a Hoopl Graph, so we can reuse revPostOrder.
diff --git a/compiler/GHC/CmmToAsm/CFG/Dominators.hs b/compiler/GHC/CmmToAsm/CFG/Dominators.hs
index a24e9528f357f5945a1380cd6e430130229b47f6..a3e1855055fb05bce65ac165945585bf89b29c23 100644
--- a/compiler/GHC/CmmToAsm/CFG/Dominators.hs
+++ b/compiler/GHC/CmmToAsm/CFG/Dominators.hs
@@ -21,8 +21,8 @@
/Advanced Compiler Design and Implementation/, 1997.
\[3\] Brisk, Sarrafzadeh,
- /Interference Graphs for Procedures in Static Single/
- /Information Form are Interval Graphs/, 2007.
+ /Interference CGraphs for Procedures in Static Single/
+ /Information Form are Interval CGraphs/, 2007.
* Strictness
@@ -40,7 +40,7 @@ module GHC.CmmToAsm.CFG.Dominators (
,pddfs,rpddfs
,fromAdj,fromEdges
,toAdj,toEdges
- ,asTree,asGraph
+ ,asTree,asCGraph
,parents,ancestors
) where
@@ -61,14 +61,23 @@ import Data.Array.ST
import Data.Array.Base
(unsafeNewArray_
,unsafeWrite,unsafeRead)
+import GHC.Data.Word64Set (Word64Set)
+import qualified GHC.Data.Word64Set as WS
+import GHC.Data.Word64Map (Word64Map)
+import qualified GHC.Data.Word64Map as WM
+import Data.Word
-----------------------------------------------------------------------------
-type Node = Int
-type Path = [Node]
-type Edge = (Node,Node)
-type Graph = IntMap IntSet
-type Rooted = (Node, Graph)
+-- Compacted nodes; these can be stored in contiguous arrays
+type CNode = Int
+type CGraph = IntMap IntSet
+
+type Node = Word64
+type Path = [Node]
+type Edge = (Node, Node)
+type Graph = Word64Map Word64Set
+type Rooted = (Node, Graph)
-----------------------------------------------------------------------------
@@ -111,7 +120,7 @@ idom rg = runST (evalS idomM =<< initEnv (pruneReach rg))
-- | /Immediate post-dominators/.
-- Complexity as for @idom@.
ipdom :: Rooted -> [(Node,Node)]
-ipdom rg = runST (evalS idomM =<< initEnv (pruneReach (second predG rg)))
+ipdom rg = runST (evalS idomM =<< initEnv (pruneReach (second predGW rg)))
-----------------------------------------------------------------------------
@@ -126,24 +135,24 @@ rpddfs = concat . levels . pdomTree
-----------------------------------------------------------------------------
type Dom s a = S s (Env s) a
-type NodeSet = IntSet
-type NodeMap a = IntMap a
+type NodeSet = Word64Set
+type NodeMap a = Word64Map a
data Env s = Env
- {succE :: !Graph
- ,predE :: !Graph
- ,bucketE :: !Graph
+ {succE :: !CGraph
+ ,predE :: !CGraph
+ ,bucketE :: !CGraph
,dfsE :: {-# UNPACK #-}!Int
- ,zeroE :: {-# UNPACK #-}!Node
- ,rootE :: {-# UNPACK #-}!Node
- ,labelE :: {-# UNPACK #-}!(Arr s Node)
- ,parentE :: {-# UNPACK #-}!(Arr s Node)
- ,ancestorE :: {-# UNPACK #-}!(Arr s Node)
- ,childE :: {-# UNPACK #-}!(Arr s Node)
- ,ndfsE :: {-# UNPACK #-}!(Arr s Node)
+ ,zeroE :: {-# UNPACK #-}!CNode
+ ,rootE :: {-# UNPACK #-}!CNode
+ ,labelE :: {-# UNPACK #-}!(Arr s CNode)
+ ,parentE :: {-# UNPACK #-}!(Arr s CNode)
+ ,ancestorE :: {-# UNPACK #-}!(Arr s CNode)
+ ,childE :: {-# UNPACK #-}!(Arr s CNode)
+ ,ndfsE :: {-# UNPACK #-}!(Arr s CNode)
,dfnE :: {-# UNPACK #-}!(Arr s Int)
,sdnoE :: {-# UNPACK #-}!(Arr s Int)
,sizeE :: {-# UNPACK #-}!(Arr s Int)
- ,domE :: {-# UNPACK #-}!(Arr s Node)
+ ,domE :: {-# UNPACK #-}!(Arr s CNode)
,rnE :: {-# UNPACK #-}!(Arr s Node)}
-----------------------------------------------------------------------------
@@ -188,7 +197,7 @@ idomM = do
-----------------------------------------------------------------------------
-eval :: Node -> Dom s Node
+eval :: CNode -> Dom s CNode
eval v = do
n0 <- zeroM
a <- ancestorM v
@@ -205,7 +214,7 @@ eval v = do
True-> return l
False-> return la
-compress :: Node -> Dom s ()
+compress :: CNode -> Dom s ()
compress v = do
n0 <- zeroM
a <- ancestorM v
@@ -224,7 +233,7 @@ compress v = do
-----------------------------------------------------------------------------
-link :: Node -> Node -> Dom s ()
+link :: CNode -> CNode -> Dom s ()
link v w = do
n0 <- zeroM
lw <- labelM w
@@ -268,7 +277,7 @@ link v w = do
-----------------------------------------------------------------------------
-dfsDom :: Node -> Dom s ()
+dfsDom :: CNode -> Dom s ()
dfsDom i = do
_ <- go i
n0 <- zeroM
@@ -293,10 +302,10 @@ dfsDom i = do
initEnv :: Rooted -> ST s (Env s)
initEnv (r0,g0) = do
- -- Graph renumbered to indices from 1 to |V|
+ -- CGraph renumbered to indices from 1 to |V|
let (g,rnmap) = renum 1 g0
pred = predG g -- reverse graph
- root = rnmap IM.! r0 -- renamed root
+ root = rnmap WM.! r0 -- renamed root
n = IM.size g
ns = [0..n]
m = n+1
@@ -304,9 +313,9 @@ initEnv (r0,g0) = do
let bucket = IM.fromList
(zip ns (repeat mempty))
- rna <- newI m
+ rna <- newW m
writes rna (fmap swap
- (IM.toList rnmap))
+ (WM.toList rnmap))
doms <- newI m
sdno <- newI m
@@ -361,33 +370,33 @@ fromEnv = do
-----------------------------------------------------------------------------
-zeroM :: Dom s Node
+zeroM :: Dom s CNode
zeroM = gets zeroE
-domM :: Node -> Dom s Node
+domM :: CNode -> Dom s CNode
domM = fetch domE
-rootM :: Dom s Node
+rootM :: Dom s CNode
rootM = gets rootE
-succsM :: Node -> Dom s [Node]
+succsM :: CNode -> Dom s [CNode]
succsM i = gets (IS.toList . (! i) . succE)
-predsM :: Node -> Dom s [Node]
+predsM :: CNode -> Dom s [CNode]
predsM i = gets (IS.toList . (! i) . predE)
-bucketM :: Node -> Dom s [Node]
+bucketM :: CNode -> Dom s [CNode]
bucketM i = gets (IS.toList . (! i) . bucketE)
-sizeM :: Node -> Dom s Int
+sizeM :: CNode -> Dom s Int
sizeM = fetch sizeE
-sdnoM :: Node -> Dom s Int
+sdnoM :: CNode -> Dom s Int
sdnoM = fetch sdnoE
--- dfnM :: Node -> Dom s Int
+-- dfnM :: CNode -> Dom s Int
-- dfnM = fetch dfnE
-ndfsM :: Int -> Dom s Node
+ndfsM :: Int -> Dom s CNode
ndfsM = fetch ndfsE
-childM :: Node -> Dom s Node
+childM :: CNode -> Dom s CNode
childM = fetch childE
-ancestorM :: Node -> Dom s Node
+ancestorM :: CNode -> Dom s CNode
ancestorM = fetch ancestorE
-parentM :: Node -> Dom s Node
+parentM :: CNode -> Dom s CNode
parentM = fetch parentE
-labelM :: Node -> Dom s Node
+labelM :: CNode -> Dom s CNode
labelM = fetch labelE
nextM :: Dom s Int
nextM = do
@@ -422,6 +431,9 @@ new n = unsafeNewArray_ (0,n-1)
newI :: Int -> ST s (Arr s Int)
newI = new
+newW :: Int -> ST s (Arr s Node)
+newW = new
+
writes :: (MArray (A s) a (ST s))
=> Arr s a -> [(Int,a)] -> ST s ()
writes a xs = forM_ xs (\(i,x) -> (a.=x) i)
@@ -431,18 +443,18 @@ writes a xs = forM_ xs (\(i,x) -> (a.=x) i)
(!) g n = maybe mempty id (IM.lookup n g)
fromAdj :: [(Node, [Node])] -> Graph
-fromAdj = IM.fromList . fmap (second IS.fromList)
+fromAdj = WM.fromList . fmap (second WS.fromList)
fromEdges :: [Edge] -> Graph
-fromEdges = collectI IS.union fst (IS.singleton . snd)
+fromEdges = collectW WS.union fst (WS.singleton . snd)
toAdj :: Graph -> [(Node, [Node])]
-toAdj = fmap (second IS.toList) . IM.toList
+toAdj = fmap (second WS.toList) . WM.toList
toEdges :: Graph -> [Edge]
toEdges = concatMap (uncurry (fmap . (,))) . toAdj
-predG :: Graph -> Graph
+predG :: CGraph -> CGraph
predG g = IM.unionWith IS.union (go g) g0
where g0 = fmap (const mempty) g
go = flip IM.foldrWithKey mempty (\i a m ->
@@ -451,15 +463,24 @@ predG g = IM.unionWith IS.union (go g) g0
m
(IS.toList a))
+predGW :: Graph -> Graph
+predGW g = WM.unionWith WS.union (go g) g0
+ where g0 = fmap (const mempty) g
+ go = flip WM.foldrWithKey mempty (\i a m ->
+ foldl' (\m p -> WM.insertWith mappend p
+ (WS.singleton i) m)
+ m
+ (WS.toList a))
+
pruneReach :: Rooted -> Rooted
pruneReach (r,g) = (r,g2)
where is = reachable
(maybe mempty id
- . flip IM.lookup g) $ r
- g2 = IM.fromList
- . fmap (second (IS.filter (`IS.member`is)))
- . filter ((`IS.member`is) . fst)
- . IM.toList $ g
+ . flip WM.lookup g) $ r
+ g2 = WM.fromList
+ . fmap (second (WS.filter (`WS.member`is)))
+ . filter ((`WS.member`is) . fst)
+ . WM.toList $ g
tip :: Tree a -> (a, [Tree a])
tip (Node a ts) = (a, ts)
@@ -476,26 +497,28 @@ ancestors = go []
in p acc' xs ++ concatMap (go acc') xs
p is = fmap (flip (,) is . rootLabel)
-asGraph :: Tree Node -> Rooted
-asGraph t@(Node a _) = let g = go t in (a, fromAdj g)
+asCGraph :: Tree Node -> Rooted
+asCGraph t@(Node a _) = let g = go t in (a, fromAdj g)
where go (Node a ts) = let as = (fst . unzip . fmap tip) ts
in (a, as) : concatMap go ts
asTree :: Rooted -> Tree Node
-asTree (r,g) = let go a = Node a (fmap go ((IS.toList . f) a))
+asTree (r,g) = let go a = Node a (fmap go ((WS.toList . f) a))
f = (g !)
in go r
+ where (!) g n = maybe mempty id (WM.lookup n g)
+
reachable :: (Node -> NodeSet) -> (Node -> NodeSet)
-reachable f a = go (IS.singleton a) a
+reachable f a = go (WS.singleton a) a
where go seen a = let s = f a
- as = IS.toList (s `IS.difference` seen)
- in foldl' go (s `IS.union` seen) as
+ as = WS.toList (s `WS.difference` seen)
+ in foldl' go (s `WS.union` seen) as
-collectI :: (c -> c -> c)
- -> (a -> Int) -> (a -> c) -> [a] -> IntMap c
-collectI (<>) f g
- = foldl' (\m a -> IM.insertWith (<>)
+collectW :: (c -> c -> c)
+ -> (a -> Node) -> (a -> c) -> [a] -> Word64Map c
+collectW (<>) f g
+ = foldl' (\m a -> WM.insertWith (<>)
(f a)
(g a) m) mempty
@@ -504,12 +527,12 @@ collectI (<>) f g
-- Gives nodes sequential names starting at n.
-- Returns the new graph and a mapping.
-- (renamed, old -> new)
-renum :: Int -> Graph -> (Graph, NodeMap Node)
+renum :: Int -> Graph -> (CGraph, NodeMap CNode)
renum from = (\(_,m,g)->(g,m))
- . IM.foldrWithKey
+ . WM.foldrWithKey
(\i ss (!n,!env,!new)->
let (j,n2,env2) = go n env i
- (n3,env3,ss2) = IS.fold
+ (n3,env3,ss2) = WS.fold
(\k (!n,!env,!new)->
case go n env k of
(l,n2,env2)-> (n2,env2,l `IS.insert` new))
@@ -517,13 +540,13 @@ renum from = (\(_,m,g)->(g,m))
new2 = IM.insertWith IS.union j ss2 new
in (n3,env3,new2)) (from,mempty,mempty)
where go :: Int
- -> NodeMap Node
+ -> NodeMap CNode
-> Node
- -> (Node,Int,NodeMap Node)
+ -> (CNode,Int,NodeMap CNode)
go !n !env i =
- case IM.lookup i env of
+ case WM.lookup i env of
Just j -> (j,n,env)
- Nothing -> (n,n+1,IM.insert i n env)
+ Nothing -> (n,n+1,WM.insert i n env)
-----------------------------------------------------------------------------
diff --git a/compiler/GHC/CmmToAsm/Wasm/Asm.hs b/compiler/GHC/CmmToAsm/Wasm/Asm.hs
index d7acc0e4595edafb22d710e496f117d572e11433..6ee754ff7b413d3c6d177ffa41f75be448f54739 100644
--- a/compiler/GHC/CmmToAsm/Wasm/Asm.hs
+++ b/compiler/GHC/CmmToAsm/Wasm/Asm.hs
@@ -14,7 +14,7 @@ import qualified Data.ByteString as BS
import Data.ByteString.Builder
import Data.Coerce
import Data.Foldable
-import qualified Data.IntSet as IS
+import qualified GHC.Data.Word64Set as WS
import Data.Maybe
import Data.Semigroup
import GHC.Cmm
@@ -181,9 +181,9 @@ asmTellSectionHeader :: Builder -> WasmAsmM ()
asmTellSectionHeader k = asmTellTabLine $ ".section " <> k <> ",\"\",@"
asmTellDataSection ::
- WasmTypeTag w -> IS.IntSet -> SymName -> DataSection -> WasmAsmM ()
+ WasmTypeTag w -> WS.Word64Set -> SymName -> DataSection -> WasmAsmM ()
asmTellDataSection ty_word def_syms sym DataSection {..} = do
- when (getKey (getUnique sym) `IS.member` def_syms) $ asmTellDefSym sym
+ when (getKey (getUnique sym) `WS.member` def_syms) $ asmTellDefSym sym
asmTellSectionHeader sec_name
asmTellAlign dataSectionAlignment
asmTellTabLine asm_size
@@ -420,12 +420,12 @@ asmTellWasmControl ty_word c = case c of
asmTellFunc ::
WasmTypeTag w ->
- IS.IntSet ->
+ WS.Word64Set ->
SymName ->
(([SomeWasmType], [SomeWasmType]), FuncBody w) ->
WasmAsmM ()
asmTellFunc ty_word def_syms sym (func_ty, FuncBody {..}) = do
- when (getKey (getUnique sym) `IS.member` def_syms) $ asmTellDefSym sym
+ when (getKey (getUnique sym) `WS.member` def_syms) $ asmTellDefSym sym
asmTellSectionHeader $ ".text." <> asm_sym
asmTellLine $ asm_sym <> ":"
asmTellFuncType sym func_ty
diff --git a/compiler/GHC/CmmToAsm/Wasm/FromCmm.hs b/compiler/GHC/CmmToAsm/Wasm/FromCmm.hs
index 3d655f307a38014958ce2f034e8223bff977df4b..dd7fcdabf7aaa7ce4babe1f37476992ea8683890 100644
--- a/compiler/GHC/CmmToAsm/Wasm/FromCmm.hs
+++ b/compiler/GHC/CmmToAsm/Wasm/FromCmm.hs
@@ -26,7 +26,7 @@ import Control.Monad
import qualified Data.ByteString as BS
import Data.Foldable
import Data.Functor
-import qualified Data.IntSet as IS
+import qualified GHC.Data.Word64Set as WS
import Data.Semigroup
import Data.String
import Data.Traversable
@@ -1553,7 +1553,7 @@ onTopSym lbl = case sym_vis of
SymDefault -> wasmModifyM $ \s ->
s
{ defaultSyms =
- IS.insert
+ WS.insert
(getKey $ getUnique sym)
$ defaultSyms s
}
diff --git a/compiler/GHC/CmmToAsm/Wasm/Types.hs b/compiler/GHC/CmmToAsm/Wasm/Types.hs
index cef1cf61654a2565af24df96b42622a938db6165..e00c03526017281533f2371d0bc3008325e482da 100644
--- a/compiler/GHC/CmmToAsm/Wasm/Types.hs
+++ b/compiler/GHC/CmmToAsm/Wasm/Types.hs
@@ -52,7 +52,7 @@ import Control.Applicative
import Data.ByteString (ByteString)
import Data.Coerce
import Data.Functor
-import qualified Data.IntSet as IS
+import qualified GHC.Data.Word64Set as WS
import Data.Kind
import Data.String
import Data.Type.Equality
@@ -197,7 +197,7 @@ data DataSection = DataSection
type SymMap = UniqMap SymName
-- | No need to remember the symbols.
-type SymSet = IS.IntSet
+type SymSet = WS.Word64Set
type GlobalInfo = (SymName, SomeWasmType)
@@ -427,7 +427,7 @@ initialWasmCodeGenState platform us =
WasmCodeGenState
{ wasmPlatform =
platform,
- defaultSyms = IS.empty,
+ defaultSyms = WS.empty,
funcTypes = emptyUniqMap,
funcBodies =
emptyUniqMap,
diff --git a/compiler/GHC/CmmToLlvm/Base.hs b/compiler/GHC/CmmToLlvm/Base.hs
index 039008b1922dec6cb150f2550374a321b8414709..43c9ef5ba0cdc1e1afb696eda73c607dd0e296c5 100644
--- a/compiler/GHC/CmmToLlvm/Base.hs
+++ b/compiler/GHC/CmmToLlvm/Base.hs
@@ -260,7 +260,7 @@ data LlvmEnv = LlvmEnv
, envConfig :: !LlvmCgConfig -- ^ Configuration for LLVM code gen
, envLogger :: !Logger -- ^ Logger
, envOutput :: BufHandle -- ^ Output buffer
- , envMask :: !Char -- ^ Mask for creating unique values
+ , envTag :: !Char -- ^ Tag for creating unique values
, envFreshMeta :: MetaId -- ^ Supply of fresh metadata IDs
, envUniqMeta :: UniqFM Unique MetaId -- ^ Global metadata nodes
, envFunMap :: LlvmEnvMap -- ^ Global functions so far, with type
@@ -292,12 +292,12 @@ getConfig = LlvmM $ \env -> return (envConfig env, env)
instance MonadUnique LlvmM where
getUniqueSupplyM = do
- mask <- getEnv envMask
- liftIO $! mkSplitUniqSupply mask
+ tag <- getEnv envTag
+ liftIO $! mkSplitUniqSupply tag
getUniqueM = do
- mask <- getEnv envMask
- liftIO $! uniqFromMask mask
+ tag <- getEnv envTag
+ liftIO $! uniqFromTag tag
-- | Lifting of IO actions. Not exported, as we want to encapsulate IO.
liftIO :: IO a -> LlvmM a
@@ -318,7 +318,7 @@ runLlvm logger cfg ver out m = do
, envConfig = cfg
, envLogger = logger
, envOutput = out
- , envMask = 'n'
+ , envTag = 'n'
, envFreshMeta = MetaId 0
, envUniqMeta = emptyUFM
}
diff --git a/compiler/GHC/Core/Opt/Monad.hs b/compiler/GHC/Core/Opt/Monad.hs
index 6199472897d654424e13d1cccac4430cb46649b0..5493e0c567473e447e15fafb474fd631b0682d89 100644
--- a/compiler/GHC/Core/Opt/Monad.hs
+++ b/compiler/GHC/Core/Opt/Monad.hs
@@ -20,7 +20,7 @@ module GHC.Core.Opt.Monad (
initRuleEnv, getExternalRuleBase,
getDynFlags, getPackageFamInstEnv,
getInteractiveContext,
- getUniqMask,
+ getUniqTag,
getNamePprCtx, getSrcSpanM,
-- ** Writing to the monad
@@ -117,7 +117,7 @@ data CoreReader = CoreReader {
cr_name_ppr_ctx :: NamePprCtx,
cr_loc :: SrcSpan, -- Use this for log/error messages so they
-- are at least tagged with the right source file
- cr_uniq_mask :: !Char -- Mask for creating unique values
+ cr_uniq_tag :: !Char -- Tag for creating unique values
}
-- Note: CoreWriter used to be defined with data, rather than newtype. If it
@@ -167,12 +167,12 @@ instance MonadPlus CoreM
instance MonadUnique CoreM where
getUniqueSupplyM = do
- mask <- read cr_uniq_mask
- liftIO $! mkSplitUniqSupply mask
+ tag <- read cr_uniq_tag
+ liftIO $! mkSplitUniqSupply tag
getUniqueM = do
- mask <- read cr_uniq_mask
- liftIO $! uniqFromMask mask
+ tag <- read cr_uniq_tag
+ liftIO $! uniqFromTag tag
runCoreM :: HscEnv
-> RuleBase
@@ -182,7 +182,7 @@ runCoreM :: HscEnv
-> SrcSpan
-> CoreM a
-> IO (a, SimplCount)
-runCoreM hsc_env rule_base mask mod name_ppr_ctx loc m
+runCoreM hsc_env rule_base tag mod name_ppr_ctx loc m
= liftM extract $ runIOEnv reader $ unCoreM m
where
reader = CoreReader {
@@ -191,7 +191,7 @@ runCoreM hsc_env rule_base mask mod name_ppr_ctx loc m
cr_module = mod,
cr_name_ppr_ctx = name_ppr_ctx,
cr_loc = loc,
- cr_uniq_mask = mask
+ cr_uniq_tag = tag
}
extract :: (a, CoreWriter) -> (a, SimplCount)
@@ -261,8 +261,8 @@ getSrcSpanM = read cr_loc
addSimplCount :: SimplCount -> CoreM ()
addSimplCount count = write (CoreWriter { cw_simpl_count = count })
-getUniqMask :: CoreM Char
-getUniqMask = read cr_uniq_mask
+getUniqTag :: CoreM Char
+getUniqTag = read cr_uniq_tag
-- Convenience accessors for useful fields of HscEnv
diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs
index 17c18fff9d7808166c8d81aecc3c1b6219dd709a..651d5a11bdcbb959ab19a9a29b7a0a4e0778adb0 100644
--- a/compiler/GHC/Core/Opt/Pipeline.hs
+++ b/compiler/GHC/Core/Opt/Pipeline.hs
@@ -77,9 +77,9 @@ core2core hsc_env guts@(ModGuts { mg_module = mod
, mg_loc = loc
, mg_rdr_env = rdr_env })
= do { let builtin_passes = getCoreToDo dflags hpt_rule_base extra_vars
- uniq_mask = 's'
+ uniq_tag = 's'
- ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_mask mod
+ ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_tag mod
name_ppr_ctx loc $
do { hsc_env' <- getHscEnv
; all_passes <- withPlugins (hsc_plugins hsc_env')
diff --git a/compiler/GHC/Core/Opt/Simplify/Monad.hs b/compiler/GHC/Core/Opt/Simplify/Monad.hs
index 826c11f335f97e3caf29ed40287e6f6bbcd7d6e4..58d7f4eb7548d0f71cf9b329c285774757122c2b 100644
--- a/compiler/GHC/Core/Opt/Simplify/Monad.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Monad.hs
@@ -180,13 +180,13 @@ traceSmpl herald doc
************************************************************************
-}
--- See Note [Uniques for wired-in prelude things and known masks] in GHC.Builtin.Uniques
-simplMask :: Char
-simplMask = 's'
+-- See Note [Uniques for wired-in prelude things and known tags] in GHC.Builtin.Uniques
+simplTag :: Char
+simplTag = 's'
instance MonadUnique SimplM where
- getUniqueSupplyM = liftIO $ mkSplitUniqSupply simplMask
- getUniqueM = liftIO $ uniqFromMask simplMask
+ getUniqueSupplyM = liftIO $ mkSplitUniqSupply simplTag
+ getUniqueM = liftIO $ uniqFromTag simplTag
instance HasLogger SimplM where
getLogger = gets st_logger
diff --git a/compiler/GHC/Data/Graph/UnVar.hs b/compiler/GHC/Data/Graph/UnVar.hs
index 371d8f545dfb2ba13aa10f18e29da7013bcc47ef..4d731979cf3171fb33c3dbd421c3a6381e7da7ff 100644
--- a/compiler/GHC/Data/Graph/UnVar.hs
+++ b/compiler/GHC/Data/Graph/UnVar.hs
@@ -35,8 +35,9 @@ import GHC.Types.Unique.FM( UniqFM, ufmToSet_Directly )
import GHC.Types.Var
import GHC.Utils.Outputable
import GHC.Types.Unique
+import GHC.Word
-import qualified Data.IntSet as S
+import qualified GHC.Data.Word64Set as S
-- We need a type for sets of variables (UnVarSet).
-- We do not use VarSet, because for that we need to have the actual variable
@@ -44,10 +45,10 @@ import qualified Data.IntSet as S
-- Therefore, use a IntSet directly (which is likely also a bit more efficient).
-- Set of uniques, i.e. for adjacent nodes
-newtype UnVarSet = UnVarSet (S.IntSet)
+newtype UnVarSet = UnVarSet S.Word64Set
deriving Eq
-k :: Var -> Int
+k :: Var -> Word64
k v = getKey (getUnique v)
domUFMUnVarSet :: UniqFM key elt -> UnVarSet
@@ -92,7 +93,7 @@ unionUnVarSets = foldl' (flip unionUnVarSet) emptyUnVarSet
instance Outputable UnVarSet where
ppr (UnVarSet s) = braces $
- hcat $ punctuate comma [ ppr (getUnique i) | i <- S.toList s]
+ hcat $ punctuate comma [ ppr (mkUniqueGrimily i) | i <- S.toList s]
data UnVarGraph = CBPG !UnVarSet !UnVarSet -- ^ complete bipartite graph
| CG !UnVarSet -- ^ complete graph
diff --git a/compiler/GHC/Data/Word64Map.hs b/compiler/GHC/Data/Word64Map.hs
new file mode 100644
index 0000000000000000000000000000000000000000..3893313b5e9e79748f7595ecc1cb03c6536fa54f
--- /dev/null
+++ b/compiler/GHC/Data/Word64Map.hs
@@ -0,0 +1,62 @@
+{-# LANGUAGE CPP #-}
+#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)
+{-# LANGUAGE Safe #-}
+#endif
+#ifdef __GLASGOW_HASKELL__
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MonoLocalBinds #-}
+#endif
+
+#include "containers.h"
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Data.Word64Map
+-- Copyright : (c) Daan Leijen 2002
+-- (c) Andriy Palamarchuk 2008
+-- License : BSD-style
+-- Maintainer : libraries@haskell.org
+-- Portability : portable
+--
+-- An efficient implementation of maps from integer keys to values
+-- (dictionaries).
+--
+-- This module re-exports the value lazy "Data.Word64Map.Lazy" API, plus
+-- several deprecated value strict functions. Please note that these functions
+-- have different strictness properties than those in "Data.Word64Map.Strict":
+-- they only evaluate the result of the combining function. For example, the
+-- default value to 'insertWith'' is only evaluated if the combining function
+-- is called and uses it.
+--
+-- These modules are intended to be imported qualified, to avoid name
+-- clashes with Prelude functions, e.g.
+--
+-- > import Data.Word64Map (Word64Map)
+-- > import qualified Data.Word64Map as Word64Map
+--
+-- The implementation is based on /big-endian patricia trees/. This data
+-- structure performs especially well on binary operations like 'union'
+-- and 'intersection'. However, my benchmarks show that it is also
+-- (much) faster on insertions and deletions when compared to a generic
+-- size-balanced map implementation (see "Data.Map").
+--
+-- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\",
+-- Workshop on ML, September 1998, pages 77-86,
+-- <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.37.5452>
+--
+-- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",
+-- Journal of the ACM, 15(4), October 1968, pages 514-534.
+--
+-- Operation comments contain the operation time complexity in
+-- the Big-O notation <http://en.wikipedia.org/wiki/Big_O_notation>.
+-- Many operations have a worst-case complexity of \(O(\min(n,64))\).
+-- This means that the operation can become linear in the number of
+-- elements with a maximum of \(64\)
+-----------------------------------------------------------------------------
+
+module GHC.Data.Word64Map
+ ( module GHC.Data.Word64Map.Lazy
+ ) where
+
+import GHC.Data.Word64Map.Lazy
\ No newline at end of file
diff --git a/compiler/GHC/Data/Word64Map/Internal.hs b/compiler/GHC/Data/Word64Map/Internal.hs
new file mode 100644
index 0000000000000000000000000000000000000000..6e60b7f5464aba8f4971ab876ccc698c2415b997
--- /dev/null
+++ b/compiler/GHC/Data/Word64Map/Internal.hs
@@ -0,0 +1,3607 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE PatternGuards #-}
+#ifdef __GLASGOW_HASKELL__
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+#endif
+#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)
+{-# LANGUAGE Trustworthy #-}
+#endif
+
+{-# OPTIONS_HADDOCK not-home #-}
+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
+
+#include "containers.h"
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Data.Word64Map.Internal
+-- Copyright : (c) Daan Leijen 2002
+-- (c) Andriy Palamarchuk 2008
+-- (c) wren romano 2016
+-- License : BSD-style
+-- Maintainer : libraries@haskell.org
+-- Portability : portable
+--
+-- = WARNING
+--
+-- This module is considered __internal__.
+--
+-- The Package Versioning Policy __does not apply__.
+--
+-- The contents of this module may change __in any way whatsoever__
+-- and __without any warning__ between minor versions of this package.
+--
+-- Authors importing this module are expected to track development
+-- closely.
+--
+-- = Description
+--
+-- This defines the data structures and core (hidden) manipulations
+-- on representations.
+--
+-- @since 0.5.9
+-----------------------------------------------------------------------------
+
+-- [Note: INLINE bit fiddling]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- It is essential that the bit fiddling functions like mask, zero, branchMask
+-- etc are inlined. If they do not, the memory allocation skyrockets. The GHC
+-- usually gets it right, but it is disastrous if it does not. Therefore we
+-- explicitly mark these functions INLINE.
+
+
+-- [Note: Local 'go' functions and capturing]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Care must be taken when using 'go' function which captures an argument.
+-- Sometimes (for example when the argument is passed to a data constructor,
+-- as in insert), GHC heap-allocates more than necessary. Therefore C-- code
+-- must be checked for increased allocation when creating and modifying such
+-- functions.
+
+
+-- [Note: Order of constructors]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- The order of constructors of Word64Map matters when considering performance.
+-- Currently in GHC 7.0, when type has 3 constructors, they are matched from
+-- the first to the last -- the best performance is achieved when the
+-- constructors are ordered by frequency.
+-- On GHC 7.0, reordering constructors from Nil | Tip | Bin to Bin | Tip | Nil
+-- improves the benchmark by circa 10%.
+--
+
+module GHC.Data.Word64Map.Internal (
+ -- * Map type
+ Word64Map(..), Key -- instance Eq,Show
+
+ -- * Operators
+ , (!), (!?), (\\)
+
+ -- * Query
+ , null
+ , size
+ , member
+ , notMember
+ , lookup
+ , findWithDefault
+ , lookupLT
+ , lookupGT
+ , lookupLE
+ , lookupGE
+ , disjoint
+
+ -- * Construction
+ , empty
+ , singleton
+
+ -- ** Insertion
+ , insert
+ , insertWith
+ , insertWithKey
+ , insertLookupWithKey
+
+ -- ** Delete\/Update
+ , delete
+ , adjust
+ , adjustWithKey
+ , update
+ , updateWithKey
+ , updateLookupWithKey
+ , alter
+ , alterF
+
+ -- * Combine
+
+ -- ** Union
+ , union
+ , unionWith
+ , unionWithKey
+ , unions
+ , unionsWith
+
+ -- ** Difference
+ , difference
+ , differenceWith
+ , differenceWithKey
+
+ -- ** Intersection
+ , intersection
+ , intersectionWith
+ , intersectionWithKey
+
+ -- ** Compose
+ , compose
+
+ -- ** General combining function
+ , SimpleWhenMissing
+ , SimpleWhenMatched
+ , runWhenMatched
+ , runWhenMissing
+ , merge
+ -- *** @WhenMatched@ tactics
+ , zipWithMaybeMatched
+ , zipWithMatched
+ -- *** @WhenMissing@ tactics
+ , mapMaybeMissing
+ , dropMissing
+ , preserveMissing
+ , mapMissing
+ , filterMissing
+
+ -- ** Applicative general combining function
+ , WhenMissing (..)
+ , WhenMatched (..)
+ , mergeA
+ -- *** @WhenMatched@ tactics
+ -- | The tactics described for 'merge' work for
+ -- 'mergeA' as well. Furthermore, the following
+ -- are available.
+ , zipWithMaybeAMatched
+ , zipWithAMatched
+ -- *** @WhenMissing@ tactics
+ -- | The tactics described for 'merge' work for
+ -- 'mergeA' as well. Furthermore, the following
+ -- are available.
+ , traverseMaybeMissing
+ , traverseMissing
+ , filterAMissing
+
+ -- ** Deprecated general combining function
+ , mergeWithKey
+ , mergeWithKey'
+
+ -- * Traversal
+ -- ** Map
+ , map
+ , mapWithKey
+ , traverseWithKey
+ , traverseMaybeWithKey
+ , mapAccum
+ , mapAccumWithKey
+ , mapAccumRWithKey
+ , mapKeys
+ , mapKeysWith
+ , mapKeysMonotonic
+
+ -- * Folds
+ , foldr
+ , foldl
+ , foldrWithKey
+ , foldlWithKey
+ , foldMapWithKey
+
+ -- ** Strict folds
+ , foldr'
+ , foldl'
+ , foldrWithKey'
+ , foldlWithKey'
+
+ -- * Conversion
+ , elems
+ , keys
+ , assocs
+ , keysSet
+ , fromSet
+
+ -- ** Lists
+ , toList
+ , fromList
+ , fromListWith
+ , fromListWithKey
+
+ -- ** Ordered lists
+ , toAscList
+ , toDescList
+ , fromAscList
+ , fromAscListWith
+ , fromAscListWithKey
+ , fromDistinctAscList
+
+ -- * Filter
+ , filter
+ , filterWithKey
+ , restrictKeys
+ , withoutKeys
+ , partition
+ , partitionWithKey
+
+ , takeWhileAntitone
+ , dropWhileAntitone
+ , spanAntitone
+
+ , mapMaybe
+ , mapMaybeWithKey
+ , mapEither
+ , mapEitherWithKey
+
+ , split
+ , splitLookup
+ , splitRoot
+
+ -- * Submap
+ , isSubmapOf, isSubmapOfBy
+ , isProperSubmapOf, isProperSubmapOfBy
+
+ -- * Min\/Max
+ , lookupMin
+ , lookupMax
+ , findMin
+ , findMax
+ , deleteMin
+ , deleteMax
+ , deleteFindMin
+ , deleteFindMax
+ , updateMin
+ , updateMax
+ , updateMinWithKey
+ , updateMaxWithKey
+ , minView
+ , maxView
+ , minViewWithKey
+ , maxViewWithKey
+
+ -- * Debugging
+ , showTree
+ , showTreeWith
+
+ -- * Internal types
+ , Mask, Prefix, Nat
+
+ -- * Utility
+ , natFromInt
+ , intFromNat
+ , link
+ , linkWithMask
+ , bin
+ , binCheckLeft
+ , binCheckRight
+ , zero
+ , nomatch
+ , match
+ , mask
+ , maskW
+ , shorter
+ , branchMask
+ , highestBitMask
+
+ -- * Used by "Word64Map.Merge.Lazy" and "Word64Map.Merge.Strict"
+ , mapWhenMissing
+ , mapWhenMatched
+ , lmapWhenMissing
+ , contramapFirstWhenMatched
+ , contramapSecondWhenMatched
+ , mapGentlyWhenMissing
+ , mapGentlyWhenMatched
+ ) where
+
+import GHC.Prelude.Basic hiding
+ (lookup, filter, foldr, foldl, foldl', null, map)
+
+import Data.Functor.Identity (Identity (..))
+import Data.Semigroup (Semigroup(stimes,(<>)),stimesIdempotentMonoid)
+import Data.Functor.Classes
+
+import Control.DeepSeq (NFData(rnf))
+import qualified Data.Foldable as Foldable
+import Data.Maybe (fromMaybe)
+
+import GHC.Data.Word64Set.Internal (Key)
+import qualified GHC.Data.Word64Set.Internal as Word64Set
+import GHC.Utils.Containers.Internal.BitUtil
+import GHC.Utils.Containers.Internal.StrictPair
+
+#ifdef __GLASGOW_HASKELL__
+import Data.Coerce
+import Data.Data (Data(..), Constr, mkConstr, constrIndex, Fixity(Prefix),
+ DataType, mkDataType, gcast1)
+import GHC.Exts (build)
+import qualified GHC.Exts as GHCExts
+import Text.Read
+#endif
+import qualified Control.Category as Category
+import Data.Word
+
+
+-- A "Nat" is a 64 bit machine word (an unsigned Int64)
+type Nat = Word64
+
+natFromInt :: Key -> Nat
+natFromInt = id
+{-# INLINE natFromInt #-}
+
+intFromNat :: Nat -> Key
+intFromNat = id
+{-# INLINE intFromNat #-}
+
+{--------------------------------------------------------------------
+ Types
+--------------------------------------------------------------------}
+
+
+-- | A map of integers to values @a@.
+
+-- See Note: Order of constructors
+data Word64Map a = Bin {-# UNPACK #-} !Prefix
+ {-# UNPACK #-} !Mask
+ !(Word64Map a)
+ !(Word64Map a)
+-- Fields:
+-- prefix: The most significant bits shared by all keys in this Bin.
+-- mask: The switching bit to determine if a key should follow the left
+-- or right subtree of a 'Bin'.
+-- Invariant: Nil is never found as a child of Bin.
+-- Invariant: The Mask is a power of 2. It is the largest bit position at which
+-- two keys of the map differ.
+-- Invariant: Prefix is the common high-order bits that all elements share to
+-- the left of the Mask bit.
+-- Invariant: In (Bin prefix mask left right), left consists of the elements that
+-- don't have the mask bit set; right is all the elements that do.
+ | Tip {-# UNPACK #-} !Key a
+ | Nil
+
+type Prefix = Word64
+type Mask = Word64
+
+
+-- Some stuff from "Data.Word64Set.Internal", for 'restrictKeys' and
+-- 'withoutKeys' to use.
+type Word64SetPrefix = Word64
+type Word64SetBitMap = Word64
+
+bitmapOf :: Word64 -> Word64SetBitMap
+bitmapOf x = shiftLL 1 (fromIntegral (x .&. Word64Set.suffixBitMask))
+{-# INLINE bitmapOf #-}
+
+{--------------------------------------------------------------------
+ Operators
+--------------------------------------------------------------------}
+
+-- | \(O(\min(n,W))\). Find the value at a key.
+-- Calls 'error' when the element can not be found.
+--
+-- > fromList [(5,'a'), (3,'b')] ! 1 Error: element not in the map
+-- > fromList [(5,'a'), (3,'b')] ! 5 == 'a'
+
+(!) :: Word64Map a -> Key -> a
+(!) m k = find k m
+
+-- | \(O(\min(n,W))\). Find the value at a key.
+-- Returns 'Nothing' when the element can not be found.
+--
+-- > fromList [(5,'a'), (3,'b')] !? 1 == Nothing
+-- > fromList [(5,'a'), (3,'b')] !? 5 == Just 'a'
+--
+-- @since 0.5.11
+
+(!?) :: Word64Map a -> Key -> Maybe a
+(!?) m k = lookup k m
+
+-- | Same as 'difference'.
+(\\) :: Word64Map a -> Word64Map b -> Word64Map a
+m1 \\ m2 = difference m1 m2
+
+infixl 9 !?,\\{-This comment teaches CPP correct behaviour -}
+
+{--------------------------------------------------------------------
+ Types
+--------------------------------------------------------------------}
+
+instance Monoid (Word64Map a) where
+ mempty = empty
+ mconcat = unions
+ mappend = (<>)
+
+-- | @since 0.5.7
+instance Semigroup (Word64Map a) where
+ (<>) = union
+ stimes = stimesIdempotentMonoid
+
+-- | Folds in order of increasing key.
+instance Foldable.Foldable Word64Map where
+ fold = go
+ where go Nil = mempty
+ go (Tip _ v) = v
+ go (Bin _ m l r)
+ | m < 0 = go r `mappend` go l
+ | otherwise = go l `mappend` go r
+ {-# INLINABLE fold #-}
+ foldr = foldr
+ {-# INLINE foldr #-}
+ foldl = foldl
+ {-# INLINE foldl #-}
+ foldMap f t = go t
+ where go Nil = mempty
+ go (Tip _ v) = f v
+ go (Bin _ m l r)
+ | m < 0 = go r `mappend` go l
+ | otherwise = go l `mappend` go r
+ {-# INLINE foldMap #-}
+ foldl' = foldl'
+ {-# INLINE foldl' #-}
+ foldr' = foldr'
+ {-# INLINE foldr' #-}
+ length = size
+ {-# INLINE length #-}
+ null = null
+ {-# INLINE null #-}
+ toList = elems -- NB: Foldable.toList /= Word64Map.toList
+ {-# INLINE toList #-}
+ elem = go
+ where go !_ Nil = False
+ go x (Tip _ y) = x == y
+ go x (Bin _ _ l r) = go x l || go x r
+ {-# INLINABLE elem #-}
+ maximum = start
+ where start Nil = error "Data.Foldable.maximum (for Data.Word64Map): empty map"
+ start (Tip _ y) = y
+ start (Bin _ m l r)
+ | m < 0 = go (start r) l
+ | otherwise = go (start l) r
+
+ go !m Nil = m
+ go m (Tip _ y) = max m y
+ go m (Bin _ _ l r) = go (go m l) r
+ {-# INLINABLE maximum #-}
+ minimum = start
+ where start Nil = error "Data.Foldable.minimum (for Data.Word64Map): empty map"
+ start (Tip _ y) = y
+ start (Bin _ m l r)
+ | m < 0 = go (start r) l
+ | otherwise = go (start l) r
+
+ go !m Nil = m
+ go m (Tip _ y) = min m y
+ go m (Bin _ _ l r) = go (go m l) r
+ {-# INLINABLE minimum #-}
+ sum = foldl' (+) 0
+ {-# INLINABLE sum #-}
+ product = foldl' (*) 1
+ {-# INLINABLE product #-}
+
+-- | Traverses in order of increasing key.
+instance Traversable Word64Map where
+ traverse f = traverseWithKey (\_ -> f)
+ {-# INLINE traverse #-}
+
+instance NFData a => NFData (Word64Map a) where
+ rnf Nil = ()
+ rnf (Tip _ v) = rnf v
+ rnf (Bin _ _ l r) = rnf l `seq` rnf r
+
+#if __GLASGOW_HASKELL__
+
+{--------------------------------------------------------------------
+ A Data instance
+--------------------------------------------------------------------}
+
+-- This instance preserves data abstraction at the cost of inefficiency.
+-- We provide limited reflection services for the sake of data abstraction.
+
+instance Data a => Data (Word64Map a) where
+ gfoldl f z im = z fromList `f` (toList im)
+ toConstr _ = fromListConstr
+ gunfold k z c = case constrIndex c of
+ 1 -> k (z fromList)
+ _ -> error "gunfold"
+ dataTypeOf _ = intMapDataType
+ dataCast1 f = gcast1 f
+
+fromListConstr :: Constr
+fromListConstr = mkConstr intMapDataType "fromList" [] Prefix
+
+intMapDataType :: DataType
+intMapDataType = mkDataType "Data.Word64Map.Internal.Word64Map" [fromListConstr]
+
+#endif
+
+{--------------------------------------------------------------------
+ Query
+--------------------------------------------------------------------}
+-- | \(O(1)\). Is the map empty?
+--
+-- > Data.Word64Map.null (empty) == True
+-- > Data.Word64Map.null (singleton 1 'a') == False
+
+null :: Word64Map a -> Bool
+null Nil = True
+null _ = False
+{-# INLINE null #-}
+
+-- | \(O(n)\). Number of elements in the map.
+--
+-- > size empty == 0
+-- > size (singleton 1 'a') == 1
+-- > size (fromList([(1,'a'), (2,'c'), (3,'b')])) == 3
+size :: Word64Map a -> Int
+size = go 0
+ where
+ go !acc (Bin _ _ l r) = go (go acc l) r
+ go acc (Tip _ _) = 1 + acc
+ go acc Nil = acc
+
+-- | \(O(\min(n,W))\). Is the key a member of the map?
+--
+-- > member 5 (fromList [(5,'a'), (3,'b')]) == True
+-- > member 1 (fromList [(5,'a'), (3,'b')]) == False
+
+-- See Note: Local 'go' functions and capturing]
+member :: Key -> Word64Map a -> Bool
+member !k = go
+ where
+ go (Bin p m l r) | nomatch k p m = False
+ | zero k m = go l
+ | otherwise = go r
+ go (Tip kx _) = k == kx
+ go Nil = False
+
+-- | \(O(\min(n,W))\). Is the key not a member of the map?
+--
+-- > notMember 5 (fromList [(5,'a'), (3,'b')]) == False
+-- > notMember 1 (fromList [(5,'a'), (3,'b')]) == True
+
+notMember :: Key -> Word64Map a -> Bool
+notMember k m = not $ member k m
+
+-- | \(O(\min(n,W))\). Lookup the value at a key in the map. See also 'Data.Map.lookup'.
+
+-- See Note: Local 'go' functions and capturing
+lookup :: Key -> Word64Map a -> Maybe a
+lookup !k = go
+ where
+ go (Bin _p m l r) | zero k m = go l
+ | otherwise = go r
+ go (Tip kx x) | k == kx = Just x
+ | otherwise = Nothing
+ go Nil = Nothing
+
+-- See Note: Local 'go' functions and capturing]
+find :: Key -> Word64Map a -> a
+find !k = go
+ where
+ go (Bin _p m l r) | zero k m = go l
+ | otherwise = go r
+ go (Tip kx x) | k == kx = x
+ | otherwise = not_found
+ go Nil = not_found
+
+ not_found = error ("Word64Map.!: key " ++ show k ++ " is not an element of the map")
+
+-- | \(O(\min(n,W))\). The expression @('findWithDefault' def k map)@
+-- returns the value at key @k@ or returns @def@ when the key is not an
+-- element of the map.
+--
+-- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'
+-- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'
+
+-- See Note: Local 'go' functions and capturing]
+findWithDefault :: a -> Key -> Word64Map a -> a
+findWithDefault def !k = go
+ where
+ go (Bin p m l r) | nomatch k p m = def
+ | zero k m = go l
+ | otherwise = go r
+ go (Tip kx x) | k == kx = x
+ | otherwise = def
+ go Nil = def
+
+-- | \(O(\min(n,W))\). Find largest key smaller than the given one and return the
+-- corresponding (key, value) pair.
+--
+-- > lookupLT 3 (fromList [(3,'a'), (5,'b')]) == Nothing
+-- > lookupLT 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')
+
+-- See Note: Local 'go' functions and capturing.
+lookupLT :: Key -> Word64Map a -> Maybe (Key, a)
+lookupLT !k t = case t of
+ Bin _ m l r | m < 0 -> if k >= 0 then go r l else go Nil r
+ _ -> go Nil t
+ where
+ go def (Bin p m l r)
+ | nomatch k p m = if k < p then unsafeFindMax def else unsafeFindMax r
+ | zero k m = go def l
+ | otherwise = go l r
+ go def (Tip ky y)
+ | k <= ky = unsafeFindMax def
+ | otherwise = Just (ky, y)
+ go def Nil = unsafeFindMax def
+
+-- | \(O(\min(n,W))\). Find smallest key greater than the given one and return the
+-- corresponding (key, value) pair.
+--
+-- > lookupGT 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')
+-- > lookupGT 5 (fromList [(3,'a'), (5,'b')]) == Nothing
+
+-- See Note: Local 'go' functions and capturing.
+lookupGT :: Key -> Word64Map a -> Maybe (Key, a)
+lookupGT !k t = case t of
+ Bin _ m l r | m < 0 -> if k >= 0 then go Nil l else go l r
+ _ -> go Nil t
+ where
+ go def (Bin p m l r)
+ | nomatch k p m = if k < p then unsafeFindMin l else unsafeFindMin def
+ | zero k m = go r l
+ | otherwise = go def r
+ go def (Tip ky y)
+ | k >= ky = unsafeFindMin def
+ | otherwise = Just (ky, y)
+ go def Nil = unsafeFindMin def
+
+-- | \(O(\min(n,W))\). Find largest key smaller or equal to the given one and return
+-- the corresponding (key, value) pair.
+--
+-- > lookupLE 2 (fromList [(3,'a'), (5,'b')]) == Nothing
+-- > lookupLE 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')
+-- > lookupLE 5 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')
+
+-- See Note: Local 'go' functions and capturing.
+lookupLE :: Key -> Word64Map a -> Maybe (Key, a)
+lookupLE !k t = case t of
+ Bin _ m l r | m < 0 -> if k >= 0 then go r l else go Nil r
+ _ -> go Nil t
+ where
+ go def (Bin p m l r)
+ | nomatch k p m = if k < p then unsafeFindMax def else unsafeFindMax r
+ | zero k m = go def l
+ | otherwise = go l r
+ go def (Tip ky y)
+ | k < ky = unsafeFindMax def
+ | otherwise = Just (ky, y)
+ go def Nil = unsafeFindMax def
+
+-- | \(O(\min(n,W))\). Find smallest key greater or equal to the given one and return
+-- the corresponding (key, value) pair.
+--
+-- > lookupGE 3 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')
+-- > lookupGE 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')
+-- > lookupGE 6 (fromList [(3,'a'), (5,'b')]) == Nothing
+
+-- See Note: Local 'go' functions and capturing.
+lookupGE :: Key -> Word64Map a -> Maybe (Key, a)
+lookupGE !k t = case t of
+ Bin _ m l r | m < 0 -> if k >= 0 then go Nil l else go l r
+ _ -> go Nil t
+ where
+ go def (Bin p m l r)
+ | nomatch k p m = if k < p then unsafeFindMin l else unsafeFindMin def
+ | zero k m = go r l
+ | otherwise = go def r
+ go def (Tip ky y)
+ | k > ky = unsafeFindMin def
+ | otherwise = Just (ky, y)
+ go def Nil = unsafeFindMin def
+
+
+-- Helper function for lookupGE and lookupGT. It assumes that if a Bin node is
+-- given, it has m > 0.
+unsafeFindMin :: Word64Map a -> Maybe (Key, a)
+unsafeFindMin Nil = Nothing
+unsafeFindMin (Tip ky y) = Just (ky, y)
+unsafeFindMin (Bin _ _ l _) = unsafeFindMin l
+
+-- Helper function for lookupLE and lookupLT. It assumes that if a Bin node is
+-- given, it has m > 0.
+unsafeFindMax :: Word64Map a -> Maybe (Key, a)
+unsafeFindMax Nil = Nothing
+unsafeFindMax (Tip ky y) = Just (ky, y)
+unsafeFindMax (Bin _ _ _ r) = unsafeFindMax r
+
+{--------------------------------------------------------------------
+ Disjoint
+--------------------------------------------------------------------}
+-- | \(O(n+m)\). Check whether the key sets of two maps are disjoint
+-- (i.e. their 'intersection' is empty).
+--
+-- > disjoint (fromList [(2,'a')]) (fromList [(1,()), (3,())]) == True
+-- > disjoint (fromList [(2,'a')]) (fromList [(1,'a'), (2,'b')]) == False
+-- > disjoint (fromList []) (fromList []) == True
+--
+-- > disjoint a b == null (intersection a b)
+--
+-- @since 0.6.2.1
+disjoint :: Word64Map a -> Word64Map b -> Bool
+disjoint Nil _ = True
+disjoint _ Nil = True
+disjoint (Tip kx _) ys = notMember kx ys
+disjoint xs (Tip ky _) = notMember ky xs
+disjoint t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
+ | shorter m1 m2 = disjoint1
+ | shorter m2 m1 = disjoint2
+ | p1 == p2 = disjoint l1 l2 && disjoint r1 r2
+ | otherwise = True
+ where
+ disjoint1 | nomatch p2 p1 m1 = True
+ | zero p2 m1 = disjoint l1 t2
+ | otherwise = disjoint r1 t2
+ disjoint2 | nomatch p1 p2 m2 = True
+ | zero p1 m2 = disjoint t1 l2
+ | otherwise = disjoint t1 r2
+
+{--------------------------------------------------------------------
+ Compose
+--------------------------------------------------------------------}
+-- | Relate the keys of one map to the values of
+-- the other, by using the values of the former as keys for lookups
+-- in the latter.
+--
+-- Complexity: \( O(n * \min(m,W)) \), where \(m\) is the size of the first argument
+--
+-- > compose (fromList [('a', "A"), ('b', "B")]) (fromList [(1,'a'),(2,'b'),(3,'z')]) = fromList [(1,"A"),(2,"B")]
+--
+-- @
+-- ('compose' bc ab '!?') = (bc '!?') <=< (ab '!?')
+-- @
+--
+-- __Note:__ Prior to v0.6.4, "Data.Word64Map.Strict" exposed a version of
+-- 'compose' that forced the values of the output 'Word64Map'. This version does
+-- not force these values.
+--
+-- @since 0.6.3.1
+compose :: Word64Map c -> Word64Map Word64 -> Word64Map c
+compose bc !ab
+ | null bc = empty
+ | otherwise = mapMaybe (bc !?) ab
+
+{--------------------------------------------------------------------
+ Construction
+--------------------------------------------------------------------}
+-- | \(O(1)\). The empty map.
+--
+-- > empty == fromList []
+-- > size empty == 0
+
+empty :: Word64Map a
+empty
+ = Nil
+{-# INLINE empty #-}
+
+-- | \(O(1)\). A map of one element.
+--
+-- > singleton 1 'a' == fromList [(1, 'a')]
+-- > size (singleton 1 'a') == 1
+
+singleton :: Key -> a -> Word64Map a
+singleton k x
+ = Tip k x
+{-# INLINE singleton #-}
+
+{--------------------------------------------------------------------
+ Insert
+--------------------------------------------------------------------}
+-- | \(O(\min(n,W))\). Insert a new key\/value pair in the map.
+-- If the key is already present in the map, the associated value is
+-- replaced with the supplied value, i.e. 'insert' is equivalent to
+-- @'insertWith' 'const'@.
+--
+-- > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')]
+-- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')]
+-- > insert 5 'x' empty == singleton 5 'x'
+
+insert :: Key -> a -> Word64Map a -> Word64Map a
+insert !k x t@(Bin p m l r)
+ | nomatch k p m = link k (Tip k x) p t
+ | zero k m = Bin p m (insert k x l) r
+ | otherwise = Bin p m l (insert k x r)
+insert k x t@(Tip ky _)
+ | k==ky = Tip k x
+ | otherwise = link k (Tip k x) ky t
+insert k x Nil = Tip k x
+
+-- right-biased insertion, used by 'union'
+-- | \(O(\min(n,W))\). Insert with a combining function.
+-- @'insertWith' f key value mp@
+-- will insert the pair (key, value) into @mp@ if key does
+-- not exist in the map. If the key does exist, the function will
+-- insert @f new_value old_value@.
+--
+-- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")]
+-- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]
+-- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx"
+
+insertWith :: (a -> a -> a) -> Key -> a -> Word64Map a -> Word64Map a
+insertWith f k x t
+ = insertWithKey (\_ x' y' -> f x' y') k x t
+
+-- | \(O(\min(n,W))\). Insert with a combining function.
+-- @'insertWithKey' f key value mp@
+-- will insert the pair (key, value) into @mp@ if key does
+-- not exist in the map. If the key does exist, the function will
+-- insert @f key new_value old_value@.
+--
+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value
+-- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")]
+-- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]
+-- > insertWithKey f 5 "xxx" empty == singleton 5 "xxx"
+
+insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> Word64Map a -> Word64Map a
+insertWithKey f !k x t@(Bin p m l r)
+ | nomatch k p m = link k (Tip k x) p t
+ | zero k m = Bin p m (insertWithKey f k x l) r
+ | otherwise = Bin p m l (insertWithKey f k x r)
+insertWithKey f k x t@(Tip ky y)
+ | k == ky = Tip k (f k x y)
+ | otherwise = link k (Tip k x) ky t
+insertWithKey _ k x Nil = Tip k x
+
+-- | \(O(\min(n,W))\). The expression (@'insertLookupWithKey' f k x map@)
+-- is a pair where the first element is equal to (@'lookup' k map@)
+-- and the second element equal to (@'insertWithKey' f k x map@).
+--
+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value
+-- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")])
+-- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "xxx")])
+-- > insertLookupWithKey f 5 "xxx" empty == (Nothing, singleton 5 "xxx")
+--
+-- This is how to define @insertLookup@ using @insertLookupWithKey@:
+--
+-- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t
+-- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")])
+-- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "x")])
+
+insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> Word64Map a -> (Maybe a, Word64Map a)
+insertLookupWithKey f !k x t@(Bin p m l r)
+ | nomatch k p m = (Nothing,link k (Tip k x) p t)
+ | zero k m = let (found,l') = insertLookupWithKey f k x l
+ in (found,Bin p m l' r)
+ | otherwise = let (found,r') = insertLookupWithKey f k x r
+ in (found,Bin p m l r')
+insertLookupWithKey f k x t@(Tip ky y)
+ | k == ky = (Just y,Tip k (f k x y))
+ | otherwise = (Nothing,link k (Tip k x) ky t)
+insertLookupWithKey _ k x Nil = (Nothing,Tip k x)
+
+
+{--------------------------------------------------------------------
+ Deletion
+--------------------------------------------------------------------}
+-- | \(O(\min(n,W))\). Delete a key and its value from the map. When the key is not
+-- a member of the map, the original map is returned.
+--
+-- > delete 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
+-- > delete 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
+-- > delete 5 empty == empty
+
+delete :: Key -> Word64Map a -> Word64Map a
+delete !k t@(Bin p m l r)
+ | nomatch k p m = t
+ | zero k m = binCheckLeft p m (delete k l) r
+ | otherwise = binCheckRight p m l (delete k r)
+delete k t@(Tip ky _)
+ | k == ky = Nil
+ | otherwise = t
+delete _k Nil = Nil
+
+-- | \(O(\min(n,W))\). Adjust a value at a specific key. When the key is not
+-- a member of the map, the original map is returned.
+--
+-- > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]
+-- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
+-- > adjust ("new " ++) 7 empty == empty
+
+adjust :: (a -> a) -> Key -> Word64Map a -> Word64Map a
+adjust f k m
+ = adjustWithKey (\_ x -> f x) k m
+
+-- | \(O(\min(n,W))\). Adjust a value at a specific key. When the key is not
+-- a member of the map, the original map is returned.
+--
+-- > let f key x = (show key) ++ ":new " ++ x
+-- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]
+-- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
+-- > adjustWithKey f 7 empty == empty
+
+adjustWithKey :: (Key -> a -> a) -> Key -> Word64Map a -> Word64Map a
+adjustWithKey f !k (Bin p m l r)
+ | zero k m = Bin p m (adjustWithKey f k l) r
+ | otherwise = Bin p m l (adjustWithKey f k r)
+adjustWithKey f k t@(Tip ky y)
+ | k == ky = Tip ky (f k y)
+ | otherwise = t
+adjustWithKey _ _ Nil = Nil
+
+
+-- | \(O(\min(n,W))\). The expression (@'update' f k map@) updates the value @x@
+-- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is
+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.
+--
+-- > let f x = if x == "a" then Just "new a" else Nothing
+-- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]
+-- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
+-- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
+
+update :: (a -> Maybe a) -> Key -> Word64Map a -> Word64Map a
+update f
+ = updateWithKey (\_ x -> f x)
+
+-- | \(O(\min(n,W))\). The expression (@'update' f k map@) updates the value @x@
+-- at @k@ (if it is in the map). If (@f k x@) is 'Nothing', the element is
+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.
+--
+-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing
+-- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]
+-- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
+-- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
+
+updateWithKey :: (Key -> a -> Maybe a) -> Key -> Word64Map a -> Word64Map a
+updateWithKey f !k (Bin p m l r)
+ | zero k m = binCheckLeft p m (updateWithKey f k l) r
+ | otherwise = binCheckRight p m l (updateWithKey f k r)
+updateWithKey f k t@(Tip ky y)
+ | k == ky = case (f k y) of
+ Just y' -> Tip ky y'
+ Nothing -> Nil
+ | otherwise = t
+updateWithKey _ _ Nil = Nil
+
+-- | \(O(\min(n,W))\). Lookup and update.
+-- The function returns original value, if it is updated.
+-- This is different behavior than 'Data.Map.updateLookupWithKey'.
+-- Returns the original key value if the map entry is deleted.
+--
+-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing
+-- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:new a")])
+-- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a")])
+-- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a")
+
+updateLookupWithKey :: (Key -> a -> Maybe a) -> Key -> Word64Map a -> (Maybe a,Word64Map a)
+updateLookupWithKey f !k (Bin p m l r)
+ | zero k m = let !(found,l') = updateLookupWithKey f k l
+ in (found,binCheckLeft p m l' r)
+ | otherwise = let !(found,r') = updateLookupWithKey f k r
+ in (found,binCheckRight p m l r')
+updateLookupWithKey f k t@(Tip ky y)
+ | k==ky = case (f k y) of
+ Just y' -> (Just y,Tip ky y')
+ Nothing -> (Just y,Nil)
+ | otherwise = (Nothing,t)
+updateLookupWithKey _ _ Nil = (Nothing,Nil)
+
+
+
+-- | \(O(\min(n,W))\). The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.
+-- 'alter' can be used to insert, delete, or update a value in an 'Word64Map'.
+-- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.
+alter :: (Maybe a -> Maybe a) -> Key -> Word64Map a -> Word64Map a
+alter f !k t@(Bin p m l r)
+ | nomatch k p m = case f Nothing of
+ Nothing -> t
+ Just x -> link k (Tip k x) p t
+ | zero k m = binCheckLeft p m (alter f k l) r
+ | otherwise = binCheckRight p m l (alter f k r)
+alter f k t@(Tip ky y)
+ | k==ky = case f (Just y) of
+ Just x -> Tip ky x
+ Nothing -> Nil
+ | otherwise = case f Nothing of
+ Just x -> link k (Tip k x) ky t
+ Nothing -> Tip ky y
+alter f k Nil = case f Nothing of
+ Just x -> Tip k x
+ Nothing -> Nil
+
+-- | \(O(\min(n,W))\). The expression (@'alterF' f k map@) alters the value @x@ at
+-- @k@, or absence thereof. 'alterF' can be used to inspect, insert, delete,
+-- or update a value in an 'Word64Map'. In short : @'lookup' k <$> 'alterF' f k m = f
+-- ('lookup' k m)@.
+--
+-- Example:
+--
+-- @
+-- interactiveAlter :: Int -> Word64Map String -> IO (Word64Map String)
+-- interactiveAlter k m = alterF f k m where
+-- f Nothing = do
+-- putStrLn $ show k ++
+-- " was not found in the map. Would you like to add it?"
+-- getUserResponse1 :: IO (Maybe String)
+-- f (Just old) = do
+-- putStrLn $ "The key is currently bound to " ++ show old ++
+-- ". Would you like to change or delete it?"
+-- getUserResponse2 :: IO (Maybe String)
+-- @
+--
+-- 'alterF' is the most general operation for working with an individual
+-- key that may or may not be in a given map.
+--
+-- Note: 'alterF' is a flipped version of the @at@ combinator from
+-- @Control.Lens.At@.
+--
+-- @since 0.5.8
+
+alterF :: Functor f
+ => (Maybe a -> f (Maybe a)) -> Key -> Word64Map a -> f (Word64Map a)
+-- This implementation was stolen from 'Control.Lens.At'.
+alterF f k m = (<$> f mv) $ \fres ->
+ case fres of
+ Nothing -> maybe m (const (delete k m)) mv
+ Just v' -> insert k v' m
+ where mv = lookup k m
+
+{--------------------------------------------------------------------
+ Union
+--------------------------------------------------------------------}
+-- | The union of a list of maps.
+--
+-- > unions [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]
+-- > == fromList [(3, "b"), (5, "a"), (7, "C")]
+-- > unions [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])]
+-- > == fromList [(3, "B3"), (5, "A3"), (7, "C")]
+
+unions :: Foldable f => f (Word64Map a) -> Word64Map a
+unions xs
+ = Foldable.foldl' union empty xs
+
+-- | The union of a list of maps, with a combining operation.
+--
+-- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]
+-- > == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")]
+
+unionsWith :: Foldable f => (a->a->a) -> f (Word64Map a) -> Word64Map a
+unionsWith f ts
+ = Foldable.foldl' (unionWith f) empty ts
+
+-- | \(O(n+m)\). The (left-biased) union of two maps.
+-- It prefers the first map when duplicate keys are encountered,
+-- i.e. (@'union' == 'unionWith' 'const'@).
+--
+-- > union (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "a"), (7, "C")]
+
+union :: Word64Map a -> Word64Map a -> Word64Map a
+union m1 m2
+ = mergeWithKey' Bin const id id m1 m2
+
+-- | \(O(n+m)\). The union with a combining function.
+--
+-- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")]
+
+unionWith :: (a -> a -> a) -> Word64Map a -> Word64Map a -> Word64Map a
+unionWith f m1 m2
+ = unionWithKey (\_ x y -> f x y) m1 m2
+
+-- | \(O(n+m)\). The union with a combining function.
+--
+-- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value
+-- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]
+
+unionWithKey :: (Key -> a -> a -> a) -> Word64Map a -> Word64Map a -> Word64Map a
+unionWithKey f m1 m2
+ = mergeWithKey' Bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 (f k1 x1 x2)) id id m1 m2
+
+{--------------------------------------------------------------------
+ Difference
+--------------------------------------------------------------------}
+-- | \(O(n+m)\). Difference between two maps (based on keys).
+--
+-- > difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 3 "b"
+
+difference :: Word64Map a -> Word64Map b -> Word64Map a
+difference m1 m2
+ = mergeWithKey (\_ _ _ -> Nothing) id (const Nil) m1 m2
+
+-- | \(O(n+m)\). Difference with a combining function.
+--
+-- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing
+-- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])
+-- > == singleton 3 "b:B"
+
+differenceWith :: (a -> b -> Maybe a) -> Word64Map a -> Word64Map b -> Word64Map a
+differenceWith f m1 m2
+ = differenceWithKey (\_ x y -> f x y) m1 m2
+
+-- | \(O(n+m)\). Difference with a combining function. When two equal keys are
+-- encountered, the combining function is applied to the key and both values.
+-- If it returns 'Nothing', the element is discarded (proper set difference).
+-- If it returns (@'Just' y@), the element is updated with a new value @y@.
+--
+-- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing
+-- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])
+-- > == singleton 3 "3:b|B"
+
+differenceWithKey :: (Key -> a -> b -> Maybe a) -> Word64Map a -> Word64Map b -> Word64Map a
+differenceWithKey f m1 m2
+ = mergeWithKey f id (const Nil) m1 m2
+
+
+-- TODO(wrengr): re-verify that asymptotic bound
+-- | \(O(n+m)\). Remove all the keys in a given set from a map.
+--
+-- @
+-- m \`withoutKeys\` s = 'filterWithKey' (\\k _ -> k ``Word64Set.notMember`` s) m
+-- @
+--
+-- @since 0.5.8
+withoutKeys :: Word64Map a -> Word64Set.Word64Set -> Word64Map a
+withoutKeys t1@(Bin p1 m1 l1 r1) t2@(Word64Set.Bin p2 m2 l2 r2)
+ | shorter m1 m2 = difference1
+ | shorter m2 m1 = difference2
+ | p1 == p2 = bin p1 m1 (withoutKeys l1 l2) (withoutKeys r1 r2)
+ | otherwise = t1
+ where
+ difference1
+ | nomatch p2 p1 m1 = t1
+ | zero p2 m1 = binCheckLeft p1 m1 (withoutKeys l1 t2) r1
+ | otherwise = binCheckRight p1 m1 l1 (withoutKeys r1 t2)
+ difference2
+ | nomatch p1 p2 m2 = t1
+ | zero p1 m2 = withoutKeys t1 l2
+ | otherwise = withoutKeys t1 r2
+withoutKeys t1@(Bin p1 m1 _ _) (Word64Set.Tip p2 bm2) =
+ let minbit = bitmapOf p1
+ lt_minbit = minbit - 1
+ maxbit = bitmapOf (p1 .|. (m1 .|. (m1 - 1)))
+ gt_maxbit = (-maxbit) `xor` maxbit
+ -- TODO(wrengr): should we manually inline/unroll 'updatePrefix'
+ -- and 'withoutBM' here, in order to avoid redundant case analyses?
+ in updatePrefix p2 t1 $ withoutBM (bm2 .|. lt_minbit .|. gt_maxbit)
+withoutKeys t1@(Bin _ _ _ _) Word64Set.Nil = t1
+withoutKeys t1@(Tip k1 _) t2
+ | k1 `Word64Set.member` t2 = Nil
+ | otherwise = t1
+withoutKeys Nil _ = Nil
+
+
+updatePrefix
+ :: Word64SetPrefix -> Word64Map a -> (Word64Map a -> Word64Map a) -> Word64Map a
+updatePrefix !kp t@(Bin p m l r) f
+ | m .&. Word64Set.suffixBitMask /= 0 =
+ if p .&. Word64Set.prefixBitMask == kp then f t else t
+ | nomatch kp p m = t
+ | zero kp m = binCheckLeft p m (updatePrefix kp l f) r
+ | otherwise = binCheckRight p m l (updatePrefix kp r f)
+updatePrefix kp t@(Tip kx _) f
+ | kx .&. Word64Set.prefixBitMask == kp = f t
+ | otherwise = t
+updatePrefix _ Nil _ = Nil
+
+
+withoutBM :: Word64SetBitMap -> Word64Map a -> Word64Map a
+withoutBM 0 t = t
+withoutBM bm (Bin p m l r) =
+ let leftBits = bitmapOf (p .|. m) - 1
+ bmL = bm .&. leftBits
+ bmR = bm `xor` bmL -- = (bm .&. complement leftBits)
+ in bin p m (withoutBM bmL l) (withoutBM bmR r)
+withoutBM bm t@(Tip k _)
+ -- TODO(wrengr): need we manually inline 'Word64Set.Member' here?
+ | k `Word64Set.member` Word64Set.Tip (k .&. Word64Set.prefixBitMask) bm = Nil
+ | otherwise = t
+withoutBM _ Nil = Nil
+
+
+{--------------------------------------------------------------------
+ Intersection
+--------------------------------------------------------------------}
+-- | \(O(n+m)\). The (left-biased) intersection of two maps (based on keys).
+--
+-- > intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "a"
+
+intersection :: Word64Map a -> Word64Map b -> Word64Map a
+intersection m1 m2
+ = mergeWithKey' bin const (const Nil) (const Nil) m1 m2
+
+
+-- TODO(wrengr): re-verify that asymptotic bound
+-- | \(O(n+m)\). The restriction of a map to the keys in a set.
+--
+-- @
+-- m \`restrictKeys\` s = 'filterWithKey' (\\k _ -> k ``Word64Set.member`` s) m
+-- @
+--
+-- @since 0.5.8
+restrictKeys :: Word64Map a -> Word64Set.Word64Set -> Word64Map a
+restrictKeys t1@(Bin p1 m1 l1 r1) t2@(Word64Set.Bin p2 m2 l2 r2)
+ | shorter m1 m2 = intersection1
+ | shorter m2 m1 = intersection2
+ | p1 == p2 = bin p1 m1 (restrictKeys l1 l2) (restrictKeys r1 r2)
+ | otherwise = Nil
+ where
+ intersection1
+ | nomatch p2 p1 m1 = Nil
+ | zero p2 m1 = restrictKeys l1 t2
+ | otherwise = restrictKeys r1 t2
+ intersection2
+ | nomatch p1 p2 m2 = Nil
+ | zero p1 m2 = restrictKeys t1 l2
+ | otherwise = restrictKeys t1 r2
+restrictKeys t1@(Bin p1 m1 _ _) (Word64Set.Tip p2 bm2) =
+ let minbit = bitmapOf p1
+ ge_minbit = complement (minbit - 1)
+ maxbit = bitmapOf (p1 .|. (m1 .|. (m1 - 1)))
+ le_maxbit = maxbit .|. (maxbit - 1)
+ -- TODO(wrengr): should we manually inline/unroll 'lookupPrefix'
+ -- and 'restrictBM' here, in order to avoid redundant case analyses?
+ in restrictBM (bm2 .&. ge_minbit .&. le_maxbit) (lookupPrefix p2 t1)
+restrictKeys (Bin _ _ _ _) Word64Set.Nil = Nil
+restrictKeys t1@(Tip k1 _) t2
+ | k1 `Word64Set.member` t2 = t1
+ | otherwise = Nil
+restrictKeys Nil _ = Nil
+
+
+-- | \(O(\min(n,W))\). Restrict to the sub-map with all keys matching
+-- a key prefix.
+lookupPrefix :: Word64SetPrefix -> Word64Map a -> Word64Map a
+lookupPrefix !kp t@(Bin p m l r)
+ | m .&. Word64Set.suffixBitMask /= 0 =
+ if p .&. Word64Set.prefixBitMask == kp then t else Nil
+ | nomatch kp p m = Nil
+ | zero kp m = lookupPrefix kp l
+ | otherwise = lookupPrefix kp r
+lookupPrefix kp t@(Tip kx _)
+ | (kx .&. Word64Set.prefixBitMask) == kp = t
+ | otherwise = Nil
+lookupPrefix _ Nil = Nil
+
+
+restrictBM :: Word64SetBitMap -> Word64Map a -> Word64Map a
+restrictBM 0 _ = Nil
+restrictBM bm (Bin p m l r) =
+ let leftBits = bitmapOf (p .|. m) - 1
+ bmL = bm .&. leftBits
+ bmR = bm `xor` bmL -- = (bm .&. complement leftBits)
+ in bin p m (restrictBM bmL l) (restrictBM bmR r)
+restrictBM bm t@(Tip k _)
+ -- TODO(wrengr): need we manually inline 'Word64Set.Member' here?
+ | k `Word64Set.member` Word64Set.Tip (k .&. Word64Set.prefixBitMask) bm = t
+ | otherwise = Nil
+restrictBM _ Nil = Nil
+
+
+-- | \(O(n+m)\). The intersection with a combining function.
+--
+-- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"
+
+intersectionWith :: (a -> b -> c) -> Word64Map a -> Word64Map b -> Word64Map c
+intersectionWith f m1 m2
+ = intersectionWithKey (\_ x y -> f x y) m1 m2
+
+-- | \(O(n+m)\). The intersection with a combining function.
+--
+-- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar
+-- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"
+
+intersectionWithKey :: (Key -> a -> b -> c) -> Word64Map a -> Word64Map b -> Word64Map c
+intersectionWithKey f m1 m2
+ = mergeWithKey' bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 (f k1 x1 x2)) (const Nil) (const Nil) m1 m2
+
+{--------------------------------------------------------------------
+ MergeWithKey
+--------------------------------------------------------------------}
+
+-- | \(O(n+m)\). A high-performance universal combining function. Using
+-- 'mergeWithKey', all combining functions can be defined without any loss of
+-- efficiency (with exception of 'union', 'difference' and 'intersection',
+-- where sharing of some nodes is lost with 'mergeWithKey').
+--
+-- Please make sure you know what is going on when using 'mergeWithKey',
+-- otherwise you can be surprised by unexpected code growth or even
+-- corruption of the data structure.
+--
+-- When 'mergeWithKey' is given three arguments, it is inlined to the call
+-- site. You should therefore use 'mergeWithKey' only to define your custom
+-- combining functions. For example, you could define 'unionWithKey',
+-- 'differenceWithKey' and 'intersectionWithKey' as
+--
+-- > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2
+-- > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const empty) m1 m2
+-- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1 m2
+--
+-- When calling @'mergeWithKey' combine only1 only2@, a function combining two
+-- 'Word64Map's is created, such that
+--
+-- * if a key is present in both maps, it is passed with both corresponding
+-- values to the @combine@ function. Depending on the result, the key is either
+-- present in the result with specified value, or is left out;
+--
+-- * a nonempty subtree present only in the first map is passed to @only1@ and
+-- the output is added to the result;
+--
+-- * a nonempty subtree present only in the second map is passed to @only2@ and
+-- the output is added to the result.
+--
+-- The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given map/.
+-- The values can be modified arbitrarily. Most common variants of @only1@ and
+-- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@ or
+-- @'filterWithKey' f@ could be used for any @f@.
+
+mergeWithKey :: (Key -> a -> b -> Maybe c) -> (Word64Map a -> Word64Map c) -> (Word64Map b -> Word64Map c)
+ -> Word64Map a -> Word64Map b -> Word64Map c
+mergeWithKey f g1 g2 = mergeWithKey' bin combine g1 g2
+ where -- We use the lambda form to avoid non-exhaustive pattern matches warning.
+ combine = \(Tip k1 x1) (Tip _k2 x2) ->
+ case f k1 x1 x2 of
+ Nothing -> Nil
+ Just x -> Tip k1 x
+ {-# INLINE combine #-}
+{-# INLINE mergeWithKey #-}
+
+-- Slightly more general version of mergeWithKey. It differs in the following:
+--
+-- * the combining function operates on maps instead of keys and values. The
+-- reason is to enable sharing in union, difference and intersection.
+--
+-- * mergeWithKey' is given an equivalent of bin. The reason is that in union*,
+-- Bin constructor can be used, because we know both subtrees are nonempty.
+
+mergeWithKey' :: (Prefix -> Mask -> Word64Map c -> Word64Map c -> Word64Map c)
+ -> (Word64Map a -> Word64Map b -> Word64Map c) -> (Word64Map a -> Word64Map c) -> (Word64Map b -> Word64Map c)
+ -> Word64Map a -> Word64Map b -> Word64Map c
+mergeWithKey' bin' f g1 g2 = go
+ where
+ go t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
+ | shorter m1 m2 = merge1
+ | shorter m2 m1 = merge2
+ | p1 == p2 = bin' p1 m1 (go l1 l2) (go r1 r2)
+ | otherwise = maybe_link p1 (g1 t1) p2 (g2 t2)
+ where
+ merge1 | nomatch p2 p1 m1 = maybe_link p1 (g1 t1) p2 (g2 t2)
+ | zero p2 m1 = bin' p1 m1 (go l1 t2) (g1 r1)
+ | otherwise = bin' p1 m1 (g1 l1) (go r1 t2)
+ merge2 | nomatch p1 p2 m2 = maybe_link p1 (g1 t1) p2 (g2 t2)
+ | zero p1 m2 = bin' p2 m2 (go t1 l2) (g2 r2)
+ | otherwise = bin' p2 m2 (g2 l2) (go t1 r2)
+
+ go t1'@(Bin _ _ _ _) t2'@(Tip k2' _) = merge0 t2' k2' t1'
+ where
+ merge0 t2 k2 t1@(Bin p1 m1 l1 r1)
+ | nomatch k2 p1 m1 = maybe_link p1 (g1 t1) k2 (g2 t2)
+ | zero k2 m1 = bin' p1 m1 (merge0 t2 k2 l1) (g1 r1)
+ | otherwise = bin' p1 m1 (g1 l1) (merge0 t2 k2 r1)
+ merge0 t2 k2 t1@(Tip k1 _)
+ | k1 == k2 = f t1 t2
+ | otherwise = maybe_link k1 (g1 t1) k2 (g2 t2)
+ merge0 t2 _ Nil = g2 t2
+
+ go t1@(Bin _ _ _ _) Nil = g1 t1
+
+ go t1'@(Tip k1' _) t2' = merge0 t1' k1' t2'
+ where
+ merge0 t1 k1 t2@(Bin p2 m2 l2 r2)
+ | nomatch k1 p2 m2 = maybe_link k1 (g1 t1) p2 (g2 t2)
+ | zero k1 m2 = bin' p2 m2 (merge0 t1 k1 l2) (g2 r2)
+ | otherwise = bin' p2 m2 (g2 l2) (merge0 t1 k1 r2)
+ merge0 t1 k1 t2@(Tip k2 _)
+ | k1 == k2 = f t1 t2
+ | otherwise = maybe_link k1 (g1 t1) k2 (g2 t2)
+ merge0 t1 _ Nil = g1 t1
+
+ go Nil t2 = g2 t2
+
+ maybe_link _ Nil _ t2 = t2
+ maybe_link _ t1 _ Nil = t1
+ maybe_link p1 t1 p2 t2 = link p1 t1 p2 t2
+ {-# INLINE maybe_link #-}
+{-# INLINE mergeWithKey' #-}
+
+
+{--------------------------------------------------------------------
+ mergeA
+--------------------------------------------------------------------}
+
+-- | A tactic for dealing with keys present in one map but not the
+-- other in 'merge' or 'mergeA'.
+--
+-- A tactic of type @WhenMissing f k x z@ is an abstract representation
+-- of a function of type @Key -> x -> f (Maybe z)@.
+--
+-- @since 0.5.9
+
+data WhenMissing f x y = WhenMissing
+ { missingSubtree :: Word64Map x -> f (Word64Map y)
+ , missingKey :: Key -> x -> f (Maybe y)}
+
+-- | @since 0.5.9
+instance (Applicative f, Monad f) => Functor (WhenMissing f x) where
+ fmap = mapWhenMissing
+ {-# INLINE fmap #-}
+
+
+-- | @since 0.5.9
+instance (Applicative f, Monad f) => Category.Category (WhenMissing f)
+ where
+ id = preserveMissing
+ f . g =
+ traverseMaybeMissing $ \ k x -> do
+ y <- missingKey g k x
+ case y of
+ Nothing -> pure Nothing
+ Just q -> missingKey f k q
+ {-# INLINE id #-}
+ {-# INLINE (.) #-}
+
+
+-- | Equivalent to @ReaderT k (ReaderT x (MaybeT f))@.
+--
+-- @since 0.5.9
+instance (Applicative f, Monad f) => Applicative (WhenMissing f x) where
+ pure x = mapMissing (\ _ _ -> x)
+ f <*> g =
+ traverseMaybeMissing $ \k x -> do
+ res1 <- missingKey f k x
+ case res1 of
+ Nothing -> pure Nothing
+ Just r -> (pure $!) . fmap r =<< missingKey g k x
+ {-# INLINE pure #-}
+ {-# INLINE (<*>) #-}
+
+
+-- | Equivalent to @ReaderT k (ReaderT x (MaybeT f))@.
+--
+-- @since 0.5.9
+instance (Applicative f, Monad f) => Monad (WhenMissing f x) where
+ m >>= f =
+ traverseMaybeMissing $ \k x -> do
+ res1 <- missingKey m k x
+ case res1 of
+ Nothing -> pure Nothing
+ Just r -> missingKey (f r) k x
+ {-# INLINE (>>=) #-}
+
+
+-- | Map covariantly over a @'WhenMissing' f x@.
+--
+-- @since 0.5.9
+mapWhenMissing
+ :: (Applicative f, Monad f)
+ => (a -> b)
+ -> WhenMissing f x a
+ -> WhenMissing f x b
+mapWhenMissing f t = WhenMissing
+ { missingSubtree = \m -> missingSubtree t m >>= \m' -> pure $! fmap f m'
+ , missingKey = \k x -> missingKey t k x >>= \q -> (pure $! fmap f q) }
+{-# INLINE mapWhenMissing #-}
+
+
+-- | Map covariantly over a @'WhenMissing' f x@, using only a
+-- 'Functor f' constraint.
+mapGentlyWhenMissing
+ :: Functor f
+ => (a -> b)
+ -> WhenMissing f x a
+ -> WhenMissing f x b
+mapGentlyWhenMissing f t = WhenMissing
+ { missingSubtree = \m -> fmap f <$> missingSubtree t m
+ , missingKey = \k x -> fmap f <$> missingKey t k x }
+{-# INLINE mapGentlyWhenMissing #-}
+
+
+-- | Map covariantly over a @'WhenMatched' f k x@, using only a
+-- 'Functor f' constraint.
+mapGentlyWhenMatched
+ :: Functor f
+ => (a -> b)
+ -> WhenMatched f x y a
+ -> WhenMatched f x y b
+mapGentlyWhenMatched f t =
+ zipWithMaybeAMatched $ \k x y -> fmap f <$> runWhenMatched t k x y
+{-# INLINE mapGentlyWhenMatched #-}
+
+
+-- | Map contravariantly over a @'WhenMissing' f _ x@.
+--
+-- @since 0.5.9
+lmapWhenMissing :: (b -> a) -> WhenMissing f a x -> WhenMissing f b x
+lmapWhenMissing f t = WhenMissing
+ { missingSubtree = \m -> missingSubtree t (fmap f m)
+ , missingKey = \k x -> missingKey t k (f x) }
+{-# INLINE lmapWhenMissing #-}
+
+
+-- | Map contravariantly over a @'WhenMatched' f _ y z@.
+--
+-- @since 0.5.9
+contramapFirstWhenMatched
+ :: (b -> a)
+ -> WhenMatched f a y z
+ -> WhenMatched f b y z
+contramapFirstWhenMatched f t =
+ WhenMatched $ \k x y -> runWhenMatched t k (f x) y
+{-# INLINE contramapFirstWhenMatched #-}
+
+
+-- | Map contravariantly over a @'WhenMatched' f x _ z@.
+--
+-- @since 0.5.9
+contramapSecondWhenMatched
+ :: (b -> a)
+ -> WhenMatched f x a z
+ -> WhenMatched f x b z
+contramapSecondWhenMatched f t =
+ WhenMatched $ \k x y -> runWhenMatched t k x (f y)
+{-# INLINE contramapSecondWhenMatched #-}
+
+
+-- | A tactic for dealing with keys present in one map but not the
+-- other in 'merge'.
+--
+-- A tactic of type @SimpleWhenMissing x z@ is an abstract
+-- representation of a function of type @Key -> x -> Maybe z@.
+--
+-- @since 0.5.9
+type SimpleWhenMissing = WhenMissing Identity
+
+
+-- | A tactic for dealing with keys present in both maps in 'merge'
+-- or 'mergeA'.
+--
+-- A tactic of type @WhenMatched f x y z@ is an abstract representation
+-- of a function of type @Key -> x -> y -> f (Maybe z)@.
+--
+-- @since 0.5.9
+newtype WhenMatched f x y z = WhenMatched
+ { matchedKey :: Key -> x -> y -> f (Maybe z) }
+
+
+-- | Along with zipWithMaybeAMatched, witnesses the isomorphism
+-- between @WhenMatched f x y z@ and @Key -> x -> y -> f (Maybe z)@.
+--
+-- @since 0.5.9
+runWhenMatched :: WhenMatched f x y z -> Key -> x -> y -> f (Maybe z)
+runWhenMatched = matchedKey
+{-# INLINE runWhenMatched #-}
+
+
+-- | Along with traverseMaybeMissing, witnesses the isomorphism
+-- between @WhenMissing f x y@ and @Key -> x -> f (Maybe y)@.
+--
+-- @since 0.5.9
+runWhenMissing :: WhenMissing f x y -> Key-> x -> f (Maybe y)
+runWhenMissing = missingKey
+{-# INLINE runWhenMissing #-}
+
+
+-- | @since 0.5.9
+instance Functor f => Functor (WhenMatched f x y) where
+ fmap = mapWhenMatched
+ {-# INLINE fmap #-}
+
+
+-- | @since 0.5.9
+instance (Monad f, Applicative f) => Category.Category (WhenMatched f x)
+ where
+ id = zipWithMatched (\_ _ y -> y)
+ f . g =
+ zipWithMaybeAMatched $ \k x y -> do
+ res <- runWhenMatched g k x y
+ case res of
+ Nothing -> pure Nothing
+ Just r -> runWhenMatched f k x r
+ {-# INLINE id #-}
+ {-# INLINE (.) #-}
+
+
+-- | Equivalent to @ReaderT Key (ReaderT x (ReaderT y (MaybeT f)))@
+--
+-- @since 0.5.9
+instance (Monad f, Applicative f) => Applicative (WhenMatched f x y) where
+ pure x = zipWithMatched (\_ _ _ -> x)
+ fs <*> xs =
+ zipWithMaybeAMatched $ \k x y -> do
+ res <- runWhenMatched fs k x y
+ case res of
+ Nothing -> pure Nothing
+ Just r -> (pure $!) . fmap r =<< runWhenMatched xs k x y
+ {-# INLINE pure #-}
+ {-# INLINE (<*>) #-}
+
+
+-- | Equivalent to @ReaderT Key (ReaderT x (ReaderT y (MaybeT f)))@
+--
+-- @since 0.5.9
+instance (Monad f, Applicative f) => Monad (WhenMatched f x y) where
+ m >>= f =
+ zipWithMaybeAMatched $ \k x y -> do
+ res <- runWhenMatched m k x y
+ case res of
+ Nothing -> pure Nothing
+ Just r -> runWhenMatched (f r) k x y
+ {-# INLINE (>>=) #-}
+
+
+-- | Map covariantly over a @'WhenMatched' f x y@.
+--
+-- @since 0.5.9
+mapWhenMatched
+ :: Functor f
+ => (a -> b)
+ -> WhenMatched f x y a
+ -> WhenMatched f x y b
+mapWhenMatched f (WhenMatched g) =
+ WhenMatched $ \k x y -> fmap (fmap f) (g k x y)
+{-# INLINE mapWhenMatched #-}
+
+
+-- | A tactic for dealing with keys present in both maps in 'merge'.
+--
+-- A tactic of type @SimpleWhenMatched x y z@ is an abstract
+-- representation of a function of type @Key -> x -> y -> Maybe z@.
+--
+-- @since 0.5.9
+type SimpleWhenMatched = WhenMatched Identity
+
+
+-- | When a key is found in both maps, apply a function to the key
+-- and values and use the result in the merged map.
+--
+-- > zipWithMatched
+-- > :: (Key -> x -> y -> z)
+-- > -> SimpleWhenMatched x y z
+--
+-- @since 0.5.9
+zipWithMatched
+ :: Applicative f
+ => (Key -> x -> y -> z)
+ -> WhenMatched f x y z
+zipWithMatched f = WhenMatched $ \ k x y -> pure . Just $ f k x y
+{-# INLINE zipWithMatched #-}
+
+
+-- | When a key is found in both maps, apply a function to the key
+-- and values to produce an action and use its result in the merged
+-- map.
+--
+-- @since 0.5.9
+zipWithAMatched
+ :: Applicative f
+ => (Key -> x -> y -> f z)
+ -> WhenMatched f x y z
+zipWithAMatched f = WhenMatched $ \ k x y -> Just <$> f k x y
+{-# INLINE zipWithAMatched #-}
+
+
+-- | When a key is found in both maps, apply a function to the key
+-- and values and maybe use the result in the merged map.
+--
+-- > zipWithMaybeMatched
+-- > :: (Key -> x -> y -> Maybe z)
+-- > -> SimpleWhenMatched x y z
+--
+-- @since 0.5.9
+zipWithMaybeMatched
+ :: Applicative f
+ => (Key -> x -> y -> Maybe z)
+ -> WhenMatched f x y z
+zipWithMaybeMatched f = WhenMatched $ \ k x y -> pure $ f k x y
+{-# INLINE zipWithMaybeMatched #-}
+
+
+-- | When a key is found in both maps, apply a function to the key
+-- and values, perform the resulting action, and maybe use the
+-- result in the merged map.
+--
+-- This is the fundamental 'WhenMatched' tactic.
+--
+-- @since 0.5.9
+zipWithMaybeAMatched
+ :: (Key -> x -> y -> f (Maybe z))
+ -> WhenMatched f x y z
+zipWithMaybeAMatched f = WhenMatched $ \ k x y -> f k x y
+{-# INLINE zipWithMaybeAMatched #-}
+
+
+-- | Drop all the entries whose keys are missing from the other
+-- map.
+--
+-- > dropMissing :: SimpleWhenMissing x y
+--
+-- prop> dropMissing = mapMaybeMissing (\_ _ -> Nothing)
+--
+-- but @dropMissing@ is much faster.
+--
+-- @since 0.5.9
+dropMissing :: Applicative f => WhenMissing f x y
+dropMissing = WhenMissing
+ { missingSubtree = const (pure Nil)
+ , missingKey = \_ _ -> pure Nothing }
+{-# INLINE dropMissing #-}
+
+
+-- | Preserve, unchanged, the entries whose keys are missing from
+-- the other map.
+--
+-- > preserveMissing :: SimpleWhenMissing x x
+--
+-- prop> preserveMissing = Merge.Lazy.mapMaybeMissing (\_ x -> Just x)
+--
+-- but @preserveMissing@ is much faster.
+--
+-- @since 0.5.9
+preserveMissing :: Applicative f => WhenMissing f x x
+preserveMissing = WhenMissing
+ { missingSubtree = pure
+ , missingKey = \_ v -> pure (Just v) }
+{-# INLINE preserveMissing #-}
+
+
+-- | Map over the entries whose keys are missing from the other map.
+--
+-- > mapMissing :: (k -> x -> y) -> SimpleWhenMissing x y
+--
+-- prop> mapMissing f = mapMaybeMissing (\k x -> Just $ f k x)
+--
+-- but @mapMissing@ is somewhat faster.
+--
+-- @since 0.5.9
+mapMissing :: Applicative f => (Key -> x -> y) -> WhenMissing f x y
+mapMissing f = WhenMissing
+ { missingSubtree = \m -> pure $! mapWithKey f m
+ , missingKey = \k x -> pure $ Just (f k x) }
+{-# INLINE mapMissing #-}
+
+
+-- | Map over the entries whose keys are missing from the other
+-- map, optionally removing some. This is the most powerful
+-- 'SimpleWhenMissing' tactic, but others are usually more efficient.
+--
+-- > mapMaybeMissing :: (Key -> x -> Maybe y) -> SimpleWhenMissing x y
+--
+-- prop> mapMaybeMissing f = traverseMaybeMissing (\k x -> pure (f k x))
+--
+-- but @mapMaybeMissing@ uses fewer unnecessary 'Applicative'
+-- operations.
+--
+-- @since 0.5.9
+mapMaybeMissing
+ :: Applicative f => (Key -> x -> Maybe y) -> WhenMissing f x y
+mapMaybeMissing f = WhenMissing
+ { missingSubtree = \m -> pure $! mapMaybeWithKey f m
+ , missingKey = \k x -> pure $! f k x }
+{-# INLINE mapMaybeMissing #-}
+
+
+-- | Filter the entries whose keys are missing from the other map.
+--
+-- > filterMissing :: (k -> x -> Bool) -> SimpleWhenMissing x x
+--
+-- prop> filterMissing f = Merge.Lazy.mapMaybeMissing $ \k x -> guard (f k x) *> Just x
+--
+-- but this should be a little faster.
+--
+-- @since 0.5.9
+filterMissing
+ :: Applicative f => (Key -> x -> Bool) -> WhenMissing f x x
+filterMissing f = WhenMissing
+ { missingSubtree = \m -> pure $! filterWithKey f m
+ , missingKey = \k x -> pure $! if f k x then Just x else Nothing }
+{-# INLINE filterMissing #-}
+
+
+-- | Filter the entries whose keys are missing from the other map
+-- using some 'Applicative' action.
+--
+-- > filterAMissing f = Merge.Lazy.traverseMaybeMissing $
+-- > \k x -> (\b -> guard b *> Just x) <$> f k x
+--
+-- but this should be a little faster.
+--
+-- @since 0.5.9
+filterAMissing
+ :: Applicative f => (Key -> x -> f Bool) -> WhenMissing f x x
+filterAMissing f = WhenMissing
+ { missingSubtree = \m -> filterWithKeyA f m
+ , missingKey = \k x -> bool Nothing (Just x) <$> f k x }
+{-# INLINE filterAMissing #-}
+
+
+-- | \(O(n)\). Filter keys and values using an 'Applicative' predicate.
+filterWithKeyA
+ :: Applicative f => (Key -> a -> f Bool) -> Word64Map a -> f (Word64Map a)
+filterWithKeyA _ Nil = pure Nil
+filterWithKeyA f t@(Tip k x) = (\b -> if b then t else Nil) <$> f k x
+filterWithKeyA f (Bin p m l r)
+ | m < 0 = liftA2 (flip (bin p m)) (filterWithKeyA f r) (filterWithKeyA f l)
+ | otherwise = liftA2 (bin p m) (filterWithKeyA f l) (filterWithKeyA f r)
+
+-- | This wasn't in Data.Bool until 4.7.0, so we define it here
+bool :: a -> a -> Bool -> a
+bool f _ False = f
+bool _ t True = t
+
+
+-- | Traverse over the entries whose keys are missing from the other
+-- map.
+--
+-- @since 0.5.9
+traverseMissing
+ :: Applicative f => (Key -> x -> f y) -> WhenMissing f x y
+traverseMissing f = WhenMissing
+ { missingSubtree = traverseWithKey f
+ , missingKey = \k x -> Just <$> f k x }
+{-# INLINE traverseMissing #-}
+
+
+-- | Traverse over the entries whose keys are missing from the other
+-- map, optionally producing values to put in the result. This is
+-- the most powerful 'WhenMissing' tactic, but others are usually
+-- more efficient.
+--
+-- @since 0.5.9
+traverseMaybeMissing
+ :: Applicative f => (Key -> x -> f (Maybe y)) -> WhenMissing f x y
+traverseMaybeMissing f = WhenMissing
+ { missingSubtree = traverseMaybeWithKey f
+ , missingKey = f }
+{-# INLINE traverseMaybeMissing #-}
+
+
+-- | \(O(n)\). Traverse keys\/values and collect the 'Just' results.
+--
+-- @since 0.6.4
+traverseMaybeWithKey
+ :: Applicative f => (Key -> a -> f (Maybe b)) -> Word64Map a -> f (Word64Map b)
+traverseMaybeWithKey f = go
+ where
+ go Nil = pure Nil
+ go (Tip k x) = maybe Nil (Tip k) <$> f k x
+ go (Bin p m l r)
+ | m < 0 = liftA2 (flip (bin p m)) (go r) (go l)
+ | otherwise = liftA2 (bin p m) (go l) (go r)
+
+
+-- | Merge two maps.
+--
+-- 'merge' takes two 'WhenMissing' tactics, a 'WhenMatched' tactic
+-- and two maps. It uses the tactics to merge the maps. Its behavior
+-- is best understood via its fundamental tactics, 'mapMaybeMissing'
+-- and 'zipWithMaybeMatched'.
+--
+-- Consider
+--
+-- @
+-- merge (mapMaybeMissing g1)
+-- (mapMaybeMissing g2)
+-- (zipWithMaybeMatched f)
+-- m1 m2
+-- @
+--
+-- Take, for example,
+--
+-- @
+-- m1 = [(0, \'a\'), (1, \'b\'), (3, \'c\'), (4, \'d\')]
+-- m2 = [(1, "one"), (2, "two"), (4, "three")]
+-- @
+--
+-- 'merge' will first \"align\" these maps by key:
+--
+-- @
+-- m1 = [(0, \'a\'), (1, \'b\'), (3, \'c\'), (4, \'d\')]
+-- m2 = [(1, "one"), (2, "two"), (4, "three")]
+-- @
+--
+-- It will then pass the individual entries and pairs of entries
+-- to @g1@, @g2@, or @f@ as appropriate:
+--
+-- @
+-- maybes = [g1 0 \'a\', f 1 \'b\' "one", g2 2 "two", g1 3 \'c\', f 4 \'d\' "three"]
+-- @
+--
+-- This produces a 'Maybe' for each key:
+--
+-- @
+-- keys = 0 1 2 3 4
+-- results = [Nothing, Just True, Just False, Nothing, Just True]
+-- @
+--
+-- Finally, the @Just@ results are collected into a map:
+--
+-- @
+-- return value = [(1, True), (2, False), (4, True)]
+-- @
+--
+-- The other tactics below are optimizations or simplifications of
+-- 'mapMaybeMissing' for special cases. Most importantly,
+--
+-- * 'dropMissing' drops all the keys.
+-- * 'preserveMissing' leaves all the entries alone.
+--
+-- When 'merge' is given three arguments, it is inlined at the call
+-- site. To prevent excessive inlining, you should typically use
+-- 'merge' to define your custom combining functions.
+--
+--
+-- Examples:
+--
+-- prop> unionWithKey f = merge preserveMissing preserveMissing (zipWithMatched f)
+-- prop> intersectionWithKey f = merge dropMissing dropMissing (zipWithMatched f)
+-- prop> differenceWith f = merge diffPreserve diffDrop f
+-- prop> symmetricDifference = merge diffPreserve diffPreserve (\ _ _ _ -> Nothing)
+-- prop> mapEachPiece f g h = merge (diffMapWithKey f) (diffMapWithKey g)
+--
+-- @since 0.5.9
+merge
+ :: SimpleWhenMissing a c -- ^ What to do with keys in @m1@ but not @m2@
+ -> SimpleWhenMissing b c -- ^ What to do with keys in @m2@ but not @m1@
+ -> SimpleWhenMatched a b c -- ^ What to do with keys in both @m1@ and @m2@
+ -> Word64Map a -- ^ Map @m1@
+ -> Word64Map b -- ^ Map @m2@
+ -> Word64Map c
+merge g1 g2 f m1 m2 =
+ runIdentity $ mergeA g1 g2 f m1 m2
+{-# INLINE merge #-}
+
+
+-- | An applicative version of 'merge'.
+--
+-- 'mergeA' takes two 'WhenMissing' tactics, a 'WhenMatched'
+-- tactic and two maps. It uses the tactics to merge the maps.
+-- Its behavior is best understood via its fundamental tactics,
+-- 'traverseMaybeMissing' and 'zipWithMaybeAMatched'.
+--
+-- Consider
+--
+-- @
+-- mergeA (traverseMaybeMissing g1)
+-- (traverseMaybeMissing g2)
+-- (zipWithMaybeAMatched f)
+-- m1 m2
+-- @
+--
+-- Take, for example,
+--
+-- @
+-- m1 = [(0, \'a\'), (1, \'b\'), (3,\'c\'), (4, \'d\')]
+-- m2 = [(1, "one"), (2, "two"), (4, "three")]
+-- @
+--
+-- 'mergeA' will first \"align\" these maps by key:
+--
+-- @
+-- m1 = [(0, \'a\'), (1, \'b\'), (3, \'c\'), (4, \'d\')]
+-- m2 = [(1, "one"), (2, "two"), (4, "three")]
+-- @
+--
+-- It will then pass the individual entries and pairs of entries
+-- to @g1@, @g2@, or @f@ as appropriate:
+--
+-- @
+-- actions = [g1 0 \'a\', f 1 \'b\' "one", g2 2 "two", g1 3 \'c\', f 4 \'d\' "three"]
+-- @
+--
+-- Next, it will perform the actions in the @actions@ list in order from
+-- left to right.
+--
+-- @
+-- keys = 0 1 2 3 4
+-- results = [Nothing, Just True, Just False, Nothing, Just True]
+-- @
+--
+-- Finally, the @Just@ results are collected into a map:
+--
+-- @
+-- return value = [(1, True), (2, False), (4, True)]
+-- @
+--
+-- The other tactics below are optimizations or simplifications of
+-- 'traverseMaybeMissing' for special cases. Most importantly,
+--
+-- * 'dropMissing' drops all the keys.
+-- * 'preserveMissing' leaves all the entries alone.
+-- * 'mapMaybeMissing' does not use the 'Applicative' context.
+--
+-- When 'mergeA' is given three arguments, it is inlined at the call
+-- site. To prevent excessive inlining, you should generally only use
+-- 'mergeA' to define custom combining functions.
+--
+-- @since 0.5.9
+mergeA
+ :: (Applicative f)
+ => WhenMissing f a c -- ^ What to do with keys in @m1@ but not @m2@
+ -> WhenMissing f b c -- ^ What to do with keys in @m2@ but not @m1@
+ -> WhenMatched f a b c -- ^ What to do with keys in both @m1@ and @m2@
+ -> Word64Map a -- ^ Map @m1@
+ -> Word64Map b -- ^ Map @m2@
+ -> f (Word64Map c)
+mergeA
+ WhenMissing{missingSubtree = g1t, missingKey = g1k}
+ WhenMissing{missingSubtree = g2t, missingKey = g2k}
+ WhenMatched{matchedKey = f}
+ = go
+ where
+ go t1 Nil = g1t t1
+ go Nil t2 = g2t t2
+
+ -- This case is already covered below.
+ -- go (Tip k1 x1) (Tip k2 x2) = mergeTips k1 x1 k2 x2
+
+ go (Tip k1 x1) t2' = merge2 t2'
+ where
+ merge2 t2@(Bin p2 m2 l2 r2)
+ | nomatch k1 p2 m2 = linkA k1 (subsingletonBy g1k k1 x1) p2 (g2t t2)
+ | zero k1 m2 = binA p2 m2 (merge2 l2) (g2t r2)
+ | otherwise = binA p2 m2 (g2t l2) (merge2 r2)
+ merge2 (Tip k2 x2) = mergeTips k1 x1 k2 x2
+ merge2 Nil = subsingletonBy g1k k1 x1
+
+ go t1' (Tip k2 x2) = merge1 t1'
+ where
+ merge1 t1@(Bin p1 m1 l1 r1)
+ | nomatch k2 p1 m1 = linkA p1 (g1t t1) k2 (subsingletonBy g2k k2 x2)
+ | zero k2 m1 = binA p1 m1 (merge1 l1) (g1t r1)
+ | otherwise = binA p1 m1 (g1t l1) (merge1 r1)
+ merge1 (Tip k1 x1) = mergeTips k1 x1 k2 x2
+ merge1 Nil = subsingletonBy g2k k2 x2
+
+ go t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
+ | shorter m1 m2 = merge1
+ | shorter m2 m1 = merge2
+ | p1 == p2 = binA p1 m1 (go l1 l2) (go r1 r2)
+ | otherwise = linkA p1 (g1t t1) p2 (g2t t2)
+ where
+ merge1 | nomatch p2 p1 m1 = linkA p1 (g1t t1) p2 (g2t t2)
+ | zero p2 m1 = binA p1 m1 (go l1 t2) (g1t r1)
+ | otherwise = binA p1 m1 (g1t l1) (go r1 t2)
+ merge2 | nomatch p1 p2 m2 = linkA p1 (g1t t1) p2 (g2t t2)
+ | zero p1 m2 = binA p2 m2 (go t1 l2) (g2t r2)
+ | otherwise = binA p2 m2 (g2t l2) (go t1 r2)
+
+ subsingletonBy gk k x = maybe Nil (Tip k) <$> gk k x
+ {-# INLINE subsingletonBy #-}
+
+ mergeTips k1 x1 k2 x2
+ | k1 == k2 = maybe Nil (Tip k1) <$> f k1 x1 x2
+ | k1 < k2 = liftA2 (subdoubleton k1 k2) (g1k k1 x1) (g2k k2 x2)
+ {-
+ = link_ k1 k2 <$> subsingletonBy g1k k1 x1 <*> subsingletonBy g2k k2 x2
+ -}
+ | otherwise = liftA2 (subdoubleton k2 k1) (g2k k2 x2) (g1k k1 x1)
+ {-# INLINE mergeTips #-}
+
+ subdoubleton _ _ Nothing Nothing = Nil
+ subdoubleton _ k2 Nothing (Just y2) = Tip k2 y2
+ subdoubleton k1 _ (Just y1) Nothing = Tip k1 y1
+ subdoubleton k1 k2 (Just y1) (Just y2) = link k1 (Tip k1 y1) k2 (Tip k2 y2)
+ {-# INLINE subdoubleton #-}
+
+ -- A variant of 'link_' which makes sure to execute side-effects
+ -- in the right order.
+ linkA
+ :: Applicative f
+ => Prefix -> f (Word64Map a)
+ -> Prefix -> f (Word64Map a)
+ -> f (Word64Map a)
+ linkA p1 t1 p2 t2
+ | zero p1 m = binA p m t1 t2
+ | otherwise = binA p m t2 t1
+ where
+ m = branchMask p1 p2
+ p = mask p1 m
+ {-# INLINE linkA #-}
+
+ -- A variant of 'bin' that ensures that effects for negative keys are executed
+ -- first.
+ binA
+ :: Applicative f
+ => Prefix
+ -> Mask
+ -> f (Word64Map a)
+ -> f (Word64Map a)
+ -> f (Word64Map a)
+ binA p m a b
+ | m < 0 = liftA2 (flip (bin p m)) b a
+ | otherwise = liftA2 (bin p m) a b
+ {-# INLINE binA #-}
+{-# INLINE mergeA #-}
+
+
+{--------------------------------------------------------------------
+ Min\/Max
+--------------------------------------------------------------------}
+
+-- | \(O(\min(n,W))\). Update the value at the minimal key.
+--
+-- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")]
+-- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
+
+updateMinWithKey :: (Key -> a -> Maybe a) -> Word64Map a -> Word64Map a
+updateMinWithKey f t =
+ case t of Bin p m l r | m < 0 -> binCheckRight p m l (go f r)
+ _ -> go f t
+ where
+ go f' (Bin p m l r) = binCheckLeft p m (go f' l) r
+ go f' (Tip k y) = case f' k y of
+ Just y' -> Tip k y'
+ Nothing -> Nil
+ go _ Nil = error "updateMinWithKey Nil"
+
+-- | \(O(\min(n,W))\). Update the value at the maximal key.
+--
+-- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")]
+-- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
+
+updateMaxWithKey :: (Key -> a -> Maybe a) -> Word64Map a -> Word64Map a
+updateMaxWithKey f t =
+ case t of Bin p m l r | m < 0 -> binCheckLeft p m (go f l) r
+ _ -> go f t
+ where
+ go f' (Bin p m l r) = binCheckRight p m l (go f' r)
+ go f' (Tip k y) = case f' k y of
+ Just y' -> Tip k y'
+ Nothing -> Nil
+ go _ Nil = error "updateMaxWithKey Nil"
+
+
+data View a = View {-# UNPACK #-} !Key a !(Word64Map a)
+
+-- | \(O(\min(n,W))\). Retrieves the maximal (key,value) pair of the map, and
+-- the map stripped of that element, or 'Nothing' if passed an empty map.
+--
+-- > maxViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((5,"a"), singleton 3 "b")
+-- > maxViewWithKey empty == Nothing
+
+maxViewWithKey :: Word64Map a -> Maybe ((Key, a), Word64Map a)
+maxViewWithKey t = case t of
+ Nil -> Nothing
+ _ -> Just $ case maxViewWithKeySure t of
+ View k v t' -> ((k, v), t')
+{-# INLINE maxViewWithKey #-}
+
+maxViewWithKeySure :: Word64Map a -> View a
+maxViewWithKeySure t =
+ case t of
+ Nil -> error "maxViewWithKeySure Nil"
+ Bin p m l r | m < 0 ->
+ case go l of View k a l' -> View k a (binCheckLeft p m l' r)
+ _ -> go t
+ where
+ go (Bin p m l r) =
+ case go r of View k a r' -> View k a (binCheckRight p m l r')
+ go (Tip k y) = View k y Nil
+ go Nil = error "maxViewWithKey_go Nil"
+-- See note on NOINLINE at minViewWithKeySure
+{-# NOINLINE maxViewWithKeySure #-}
+
+-- | \(O(\min(n,W))\). Retrieves the minimal (key,value) pair of the map, and
+-- the map stripped of that element, or 'Nothing' if passed an empty map.
+--
+-- > minViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((3,"b"), singleton 5 "a")
+-- > minViewWithKey empty == Nothing
+
+minViewWithKey :: Word64Map a -> Maybe ((Key, a), Word64Map a)
+minViewWithKey t =
+ case t of
+ Nil -> Nothing
+ _ -> Just $ case minViewWithKeySure t of
+ View k v t' -> ((k, v), t')
+-- We inline this to give GHC the best possible chance of
+-- getting rid of the Maybe, pair, and Int constructors, as
+-- well as a thunk under the Just. That is, we really want to
+-- be certain this inlines!
+{-# INLINE minViewWithKey #-}
+
+minViewWithKeySure :: Word64Map a -> View a
+minViewWithKeySure t =
+ case t of
+ Nil -> error "minViewWithKeySure Nil"
+ Bin p m l r | m < 0 ->
+ case go r of
+ View k a r' -> View k a (binCheckRight p m l r')
+ _ -> go t
+ where
+ go (Bin p m l r) =
+ case go l of View k a l' -> View k a (binCheckLeft p m l' r)
+ go (Tip k y) = View k y Nil
+ go Nil = error "minViewWithKey_go Nil"
+-- There's never anything significant to be gained by inlining
+-- this. Sufficiently recent GHC versions will inline the wrapper
+-- anyway, which should be good enough.
+{-# NOINLINE minViewWithKeySure #-}
+
+-- | \(O(\min(n,W))\). Update the value at the maximal key.
+--
+-- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")]
+-- > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
+
+updateMax :: (a -> Maybe a) -> Word64Map a -> Word64Map a
+updateMax f = updateMaxWithKey (const f)
+
+-- | \(O(\min(n,W))\). Update the value at the minimal key.
+--
+-- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")]
+-- > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
+
+updateMin :: (a -> Maybe a) -> Word64Map a -> Word64Map a
+updateMin f = updateMinWithKey (const f)
+
+-- | \(O(\min(n,W))\). Retrieves the maximal key of the map, and the map
+-- stripped of that element, or 'Nothing' if passed an empty map.
+maxView :: Word64Map a -> Maybe (a, Word64Map a)
+maxView t = fmap (\((_, x), t') -> (x, t')) (maxViewWithKey t)
+
+-- | \(O(\min(n,W))\). Retrieves the minimal key of the map, and the map
+-- stripped of that element, or 'Nothing' if passed an empty map.
+minView :: Word64Map a -> Maybe (a, Word64Map a)
+minView t = fmap (\((_, x), t') -> (x, t')) (minViewWithKey t)
+
+-- | \(O(\min(n,W))\). Delete and find the maximal element.
+-- This function throws an error if the map is empty. Use 'maxViewWithKey'
+-- if the map may be empty.
+deleteFindMax :: Word64Map a -> ((Key, a), Word64Map a)
+deleteFindMax = fromMaybe (error "deleteFindMax: empty map has no maximal element") . maxViewWithKey
+
+-- | \(O(\min(n,W))\). Delete and find the minimal element.
+-- This function throws an error if the map is empty. Use 'minViewWithKey'
+-- if the map may be empty.
+deleteFindMin :: Word64Map a -> ((Key, a), Word64Map a)
+deleteFindMin = fromMaybe (error "deleteFindMin: empty map has no minimal element") . minViewWithKey
+
+-- | \(O(\min(n,W))\). The minimal key of the map. Returns 'Nothing' if the map is empty.
+lookupMin :: Word64Map a -> Maybe (Key, a)
+lookupMin Nil = Nothing
+lookupMin (Tip k v) = Just (k,v)
+lookupMin (Bin _ m l r)
+ | m < 0 = go r
+ | otherwise = go l
+ where go (Tip k v) = Just (k,v)
+ go (Bin _ _ l' _) = go l'
+ go Nil = Nothing
+
+-- | \(O(\min(n,W))\). The minimal key of the map. Calls 'error' if the map is empty.
+-- Use 'minViewWithKey' if the map may be empty.
+findMin :: Word64Map a -> (Key, a)
+findMin t
+ | Just r <- lookupMin t = r
+ | otherwise = error "findMin: empty map has no minimal element"
+
+-- | \(O(\min(n,W))\). The maximal key of the map. Returns 'Nothing' if the map is empty.
+lookupMax :: Word64Map a -> Maybe (Key, a)
+lookupMax Nil = Nothing
+lookupMax (Tip k v) = Just (k,v)
+lookupMax (Bin _ m l r)
+ | m < 0 = go l
+ | otherwise = go r
+ where go (Tip k v) = Just (k,v)
+ go (Bin _ _ _ r') = go r'
+ go Nil = Nothing
+
+-- | \(O(\min(n,W))\). The maximal key of the map. Calls 'error' if the map is empty.
+-- Use 'maxViewWithKey' if the map may be empty.
+findMax :: Word64Map a -> (Key, a)
+findMax t
+ | Just r <- lookupMax t = r
+ | otherwise = error "findMax: empty map has no maximal element"
+
+-- | \(O(\min(n,W))\). Delete the minimal key. Returns an empty map if the map is empty.
+--
+-- Note that this is a change of behaviour for consistency with 'Data.Map.Map' –
+-- versions prior to 0.5 threw an error if the 'Word64Map' was already empty.
+deleteMin :: Word64Map a -> Word64Map a
+deleteMin = maybe Nil snd . minView
+
+-- | \(O(\min(n,W))\). Delete the maximal key. Returns an empty map if the map is empty.
+--
+-- Note that this is a change of behaviour for consistency with 'Data.Map.Map' –
+-- versions prior to 0.5 threw an error if the 'Word64Map' was already empty.
+deleteMax :: Word64Map a -> Word64Map a
+deleteMax = maybe Nil snd . maxView
+
+
+{--------------------------------------------------------------------
+ Submap
+--------------------------------------------------------------------}
+-- | \(O(n+m)\). Is this a proper submap? (ie. a submap but not equal).
+-- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).
+isProperSubmapOf :: Eq a => Word64Map a -> Word64Map a -> Bool
+isProperSubmapOf m1 m2
+ = isProperSubmapOfBy (==) m1 m2
+
+{- | \(O(n+m)\). Is this a proper submap? (ie. a submap but not equal).
+ The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when
+ @keys m1@ and @keys m2@ are not equal,
+ all keys in @m1@ are in @m2@, and when @f@ returns 'True' when
+ applied to their respective values. For example, the following
+ expressions are all 'True':
+
+ > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
+ > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
+
+ But the following are all 'False':
+
+ > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])
+ > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])
+ > isProperSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
+-}
+isProperSubmapOfBy :: (a -> b -> Bool) -> Word64Map a -> Word64Map b -> Bool
+isProperSubmapOfBy predicate t1 t2
+ = case submapCmp predicate t1 t2 of
+ LT -> True
+ _ -> False
+
+submapCmp :: (a -> b -> Bool) -> Word64Map a -> Word64Map b -> Ordering
+submapCmp predicate t1@(Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
+ | shorter m1 m2 = GT
+ | shorter m2 m1 = submapCmpLt
+ | p1 == p2 = submapCmpEq
+ | otherwise = GT -- disjoint
+ where
+ submapCmpLt | nomatch p1 p2 m2 = GT
+ | zero p1 m2 = submapCmp predicate t1 l2
+ | otherwise = submapCmp predicate t1 r2
+ submapCmpEq = case (submapCmp predicate l1 l2, submapCmp predicate r1 r2) of
+ (GT,_ ) -> GT
+ (_ ,GT) -> GT
+ (EQ,EQ) -> EQ
+ _ -> LT
+
+submapCmp _ (Bin _ _ _ _) _ = GT
+submapCmp predicate (Tip kx x) (Tip ky y)
+ | (kx == ky) && predicate x y = EQ
+ | otherwise = GT -- disjoint
+submapCmp predicate (Tip k x) t
+ = case lookup k t of
+ Just y | predicate x y -> LT
+ _ -> GT -- disjoint
+submapCmp _ Nil Nil = EQ
+submapCmp _ Nil _ = LT
+
+-- | \(O(n+m)\). Is this a submap?
+-- Defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).
+isSubmapOf :: Eq a => Word64Map a -> Word64Map a -> Bool
+isSubmapOf m1 m2
+ = isSubmapOfBy (==) m1 m2
+
+{- | \(O(n+m)\).
+ The expression (@'isSubmapOfBy' f m1 m2@) returns 'True' if
+ all keys in @m1@ are in @m2@, and when @f@ returns 'True' when
+ applied to their respective values. For example, the following
+ expressions are all 'True':
+
+ > isSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
+ > isSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
+ > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])
+
+ But the following are all 'False':
+
+ > isSubmapOfBy (==) (fromList [(1,2)]) (fromList [(1,1),(2,2)])
+ > isSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
+ > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])
+-}
+isSubmapOfBy :: (a -> b -> Bool) -> Word64Map a -> Word64Map b -> Bool
+isSubmapOfBy predicate t1@(Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
+ | shorter m1 m2 = False
+ | shorter m2 m1 = match p1 p2 m2 &&
+ if zero p1 m2
+ then isSubmapOfBy predicate t1 l2
+ else isSubmapOfBy predicate t1 r2
+ | otherwise = (p1==p2) && isSubmapOfBy predicate l1 l2 && isSubmapOfBy predicate r1 r2
+isSubmapOfBy _ (Bin _ _ _ _) _ = False
+isSubmapOfBy predicate (Tip k x) t = case lookup k t of
+ Just y -> predicate x y
+ Nothing -> False
+isSubmapOfBy _ Nil _ = True
+
+{--------------------------------------------------------------------
+ Mapping
+--------------------------------------------------------------------}
+-- | \(O(n)\). Map a function over all values in the map.
+--
+-- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")]
+
+map :: (a -> b) -> Word64Map a -> Word64Map b
+map f = go
+ where
+ go (Bin p m l r) = Bin p m (go l) (go r)
+ go (Tip k x) = Tip k (f x)
+ go Nil = Nil
+
+#ifdef __GLASGOW_HASKELL__
+{-# NOINLINE [1] map #-}
+{-# RULES
+"map/map" forall f g xs . map f (map g xs) = map (f . g) xs
+"map/coerce" map coerce = coerce
+ #-}
+#endif
+
+-- | \(O(n)\). Map a function over all values in the map.
+--
+-- > let f key x = (show key) ++ ":" ++ x
+-- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")]
+
+mapWithKey :: (Key -> a -> b) -> Word64Map a -> Word64Map b
+mapWithKey f t
+ = case t of
+ Bin p m l r -> Bin p m (mapWithKey f l) (mapWithKey f r)
+ Tip k x -> Tip k (f k x)
+ Nil -> Nil
+
+#ifdef __GLASGOW_HASKELL__
+{-# NOINLINE [1] mapWithKey #-}
+{-# RULES
+"mapWithKey/mapWithKey" forall f g xs . mapWithKey f (mapWithKey g xs) =
+ mapWithKey (\k a -> f k (g k a)) xs
+"mapWithKey/map" forall f g xs . mapWithKey f (map g xs) =
+ mapWithKey (\k a -> f k (g a)) xs
+"map/mapWithKey" forall f g xs . map f (mapWithKey g xs) =
+ mapWithKey (\k a -> f (g k a)) xs
+ #-}
+#endif
+
+-- | \(O(n)\).
+-- @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@
+-- That is, behaves exactly like a regular 'traverse' except that the traversing
+-- function also has access to the key associated with a value.
+--
+-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')])
+-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')]) == Nothing
+traverseWithKey :: Applicative t => (Key -> a -> t b) -> Word64Map a -> t (Word64Map b)
+traverseWithKey f = go
+ where
+ go Nil = pure Nil
+ go (Tip k v) = Tip k <$> f k v
+ go (Bin p m l r)
+ | m < 0 = liftA2 (flip (Bin p m)) (go r) (go l)
+ | otherwise = liftA2 (Bin p m) (go l) (go r)
+{-# INLINE traverseWithKey #-}
+
+-- | \(O(n)\). The function @'mapAccum'@ threads an accumulating
+-- argument through the map in ascending order of keys.
+--
+-- > let f a b = (a ++ b, b ++ "X")
+-- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")])
+
+mapAccum :: (a -> b -> (a,c)) -> a -> Word64Map b -> (a,Word64Map c)
+mapAccum f = mapAccumWithKey (\a' _ x -> f a' x)
+
+-- | \(O(n)\). The function @'mapAccumWithKey'@ threads an accumulating
+-- argument through the map in ascending order of keys.
+--
+-- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")
+-- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])
+
+mapAccumWithKey :: (a -> Key -> b -> (a,c)) -> a -> Word64Map b -> (a,Word64Map c)
+mapAccumWithKey f a t
+ = mapAccumL f a t
+
+-- | \(O(n)\). The function @'mapAccumL'@ threads an accumulating
+-- argument through the map in ascending order of keys.
+mapAccumL :: (a -> Key -> b -> (a,c)) -> a -> Word64Map b -> (a,Word64Map c)
+mapAccumL f a t
+ = case t of
+ Bin p m l r
+ | m < 0 ->
+ let (a1,r') = mapAccumL f a r
+ (a2,l') = mapAccumL f a1 l
+ in (a2,Bin p m l' r')
+ | otherwise ->
+ let (a1,l') = mapAccumL f a l
+ (a2,r') = mapAccumL f a1 r
+ in (a2,Bin p m l' r')
+ Tip k x -> let (a',x') = f a k x in (a',Tip k x')
+ Nil -> (a,Nil)
+
+-- | \(O(n)\). The function @'mapAccumRWithKey'@ threads an accumulating
+-- argument through the map in descending order of keys.
+mapAccumRWithKey :: (a -> Key -> b -> (a,c)) -> a -> Word64Map b -> (a,Word64Map c)
+mapAccumRWithKey f a t
+ = case t of
+ Bin p m l r
+ | m < 0 ->
+ let (a1,l') = mapAccumRWithKey f a l
+ (a2,r') = mapAccumRWithKey f a1 r
+ in (a2,Bin p m l' r')
+ | otherwise ->
+ let (a1,r') = mapAccumRWithKey f a r
+ (a2,l') = mapAccumRWithKey f a1 l
+ in (a2,Bin p m l' r')
+ Tip k x -> let (a',x') = f a k x in (a',Tip k x')
+ Nil -> (a,Nil)
+
+-- | \(O(n \min(n,W))\).
+-- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.
+--
+-- The size of the result may be smaller if @f@ maps two or more distinct
+-- keys to the same new key. In this case the value at the greatest of the
+-- original keys is retained.
+--
+-- > mapKeys (+ 1) (fromList [(5,"a"), (3,"b")]) == fromList [(4, "b"), (6, "a")]
+-- > mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "c"
+-- > mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "c"
+
+mapKeys :: (Key->Key) -> Word64Map a -> Word64Map a
+mapKeys f = fromList . foldrWithKey (\k x xs -> (f k, x) : xs) []
+
+-- | \(O(n \min(n,W))\).
+-- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.
+--
+-- The size of the result may be smaller if @f@ maps two or more distinct
+-- keys to the same new key. In this case the associated values will be
+-- combined using @c@.
+--
+-- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab"
+-- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab"
+
+mapKeysWith :: (a -> a -> a) -> (Key->Key) -> Word64Map a -> Word64Map a
+mapKeysWith c f
+ = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) []
+
+-- | \(O(n \min(n,W))\).
+-- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@
+-- is strictly monotonic.
+-- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@.
+-- /The precondition is not checked./
+-- Semi-formally, we have:
+--
+-- > and [x < y ==> f x < f y | x <- ls, y <- ls]
+-- > ==> mapKeysMonotonic f s == mapKeys f s
+-- > where ls = keys s
+--
+-- This means that @f@ maps distinct original keys to distinct resulting keys.
+-- This function has slightly better performance than 'mapKeys'.
+--
+-- > mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) == fromList [(6, "b"), (10, "a")]
+
+mapKeysMonotonic :: (Key->Key) -> Word64Map a -> Word64Map a
+mapKeysMonotonic f
+ = fromDistinctAscList . foldrWithKey (\k x xs -> (f k, x) : xs) []
+
+{--------------------------------------------------------------------
+ Filter
+--------------------------------------------------------------------}
+-- | \(O(n)\). Filter all values that satisfy some predicate.
+--
+-- > filter (> "a") (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
+-- > filter (> "x") (fromList [(5,"a"), (3,"b")]) == empty
+-- > filter (< "a") (fromList [(5,"a"), (3,"b")]) == empty
+
+filter :: (a -> Bool) -> Word64Map a -> Word64Map a
+filter p m
+ = filterWithKey (\_ x -> p x) m
+
+-- | \(O(n)\). Filter all keys\/values that satisfy some predicate.
+--
+-- > filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
+
+filterWithKey :: (Key -> a -> Bool) -> Word64Map a -> Word64Map a
+filterWithKey predicate = go
+ where
+ go Nil = Nil
+ go t@(Tip k x) = if predicate k x then t else Nil
+ go (Bin p m l r) = bin p m (go l) (go r)
+
+-- | \(O(n)\). Partition the map according to some predicate. The first
+-- map contains all elements that satisfy the predicate, the second all
+-- elements that fail the predicate. See also 'split'.
+--
+-- > partition (> "a") (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")
+-- > partition (< "x") (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)
+-- > partition (> "x") (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])
+
+partition :: (a -> Bool) -> Word64Map a -> (Word64Map a,Word64Map a)
+partition p m
+ = partitionWithKey (\_ x -> p x) m
+
+-- | \(O(n)\). Partition the map according to some predicate. The first
+-- map contains all elements that satisfy the predicate, the second all
+-- elements that fail the predicate. See also 'split'.
+--
+-- > partitionWithKey (\ k _ -> k > 3) (fromList [(5,"a"), (3,"b")]) == (singleton 5 "a", singleton 3 "b")
+-- > partitionWithKey (\ k _ -> k < 7) (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)
+-- > partitionWithKey (\ k _ -> k > 7) (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])
+
+partitionWithKey :: (Key -> a -> Bool) -> Word64Map a -> (Word64Map a,Word64Map a)
+partitionWithKey predicate0 t0 = toPair $ go predicate0 t0
+ where
+ go predicate t =
+ case t of
+ Bin p m l r ->
+ let (l1 :*: l2) = go predicate l
+ (r1 :*: r2) = go predicate r
+ in bin p m l1 r1 :*: bin p m l2 r2
+ Tip k x
+ | predicate k x -> (t :*: Nil)
+ | otherwise -> (Nil :*: t)
+ Nil -> (Nil :*: Nil)
+
+-- | \(O(\min(n,W))\). Take while a predicate on the keys holds.
+-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@.
+-- See note at 'spanAntitone'.
+--
+-- @
+-- takeWhileAntitone p = 'fromDistinctAscList' . 'Data.List.takeWhile' (p . fst) . 'toList'
+-- takeWhileAntitone p = 'filterWithKey' (\\k _ -> p k)
+-- @
+--
+-- @since 0.6.7
+takeWhileAntitone :: (Key -> Bool) -> Word64Map a -> Word64Map a
+takeWhileAntitone predicate t =
+ case t of
+ Bin p m l r
+ | m < 0 ->
+ if predicate 0 -- handle negative numbers.
+ then bin p m (go predicate l) r
+ else go predicate r
+ _ -> go predicate t
+ where
+ go predicate' (Bin p m l r)
+ | predicate' $! p+m = bin p m l (go predicate' r)
+ | otherwise = go predicate' l
+ go predicate' t'@(Tip ky _)
+ | predicate' ky = t'
+ | otherwise = Nil
+ go _ Nil = Nil
+
+-- | \(O(\min(n,W))\). Drop while a predicate on the keys holds.
+-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@.
+-- See note at 'spanAntitone'.
+--
+-- @
+-- dropWhileAntitone p = 'fromDistinctAscList' . 'Data.List.dropWhile' (p . fst) . 'toList'
+-- dropWhileAntitone p = 'filterWithKey' (\\k _ -> not (p k))
+-- @
+--
+-- @since 0.6.7
+dropWhileAntitone :: (Key -> Bool) -> Word64Map a -> Word64Map a
+dropWhileAntitone predicate t =
+ case t of
+ Bin p m l r
+ | m < 0 ->
+ if predicate 0 -- handle negative numbers.
+ then go predicate l
+ else bin p m l (go predicate r)
+ _ -> go predicate t
+ where
+ go predicate' (Bin p m l r)
+ | predicate' $! p+m = go predicate' r
+ | otherwise = bin p m (go predicate' l) r
+ go predicate' t'@(Tip ky _)
+ | predicate' ky = Nil
+ | otherwise = t'
+ go _ Nil = Nil
+
+-- | \(O(\min(n,W))\). Divide a map at the point where a predicate on the keys stops holding.
+-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@.
+--
+-- @
+-- spanAntitone p xs = ('takeWhileAntitone' p xs, 'dropWhileAntitone' p xs)
+-- spanAntitone p xs = 'partitionWithKey' (\\k _ -> p k) xs
+-- @
+--
+-- Note: if @p@ is not actually antitone, then @spanAntitone@ will split the map
+-- at some /unspecified/ point.
+--
+-- @since 0.6.7
+spanAntitone :: (Key -> Bool) -> Word64Map a -> (Word64Map a, Word64Map a)
+spanAntitone predicate t =
+ case t of
+ Bin p m l r
+ | m < 0 ->
+ if predicate 0 -- handle negative numbers.
+ then
+ case go predicate l of
+ (lt :*: gt) ->
+ let !lt' = bin p m lt r
+ in (lt', gt)
+ else
+ case go predicate r of
+ (lt :*: gt) ->
+ let !gt' = bin p m l gt
+ in (lt, gt')
+ _ -> case go predicate t of
+ (lt :*: gt) -> (lt, gt)
+ where
+ go predicate' (Bin p m l r)
+ | predicate' $! p+m = case go predicate' r of (lt :*: gt) -> bin p m l lt :*: gt
+ | otherwise = case go predicate' l of (lt :*: gt) -> lt :*: bin p m gt r
+ go predicate' t'@(Tip ky _)
+ | predicate' ky = (t' :*: Nil)
+ | otherwise = (Nil :*: t')
+ go _ Nil = (Nil :*: Nil)
+
+-- | \(O(n)\). Map values and collect the 'Just' results.
+--
+-- > let f x = if x == "a" then Just "new a" else Nothing
+-- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a"
+
+mapMaybe :: (a -> Maybe b) -> Word64Map a -> Word64Map b
+mapMaybe f = mapMaybeWithKey (\_ x -> f x)
+
+-- | \(O(n)\). Map keys\/values and collect the 'Just' results.
+--
+-- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing
+-- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3"
+
+mapMaybeWithKey :: (Key -> a -> Maybe b) -> Word64Map a -> Word64Map b
+mapMaybeWithKey f (Bin p m l r)
+ = bin p m (mapMaybeWithKey f l) (mapMaybeWithKey f r)
+mapMaybeWithKey f (Tip k x) = case f k x of
+ Just y -> Tip k y
+ Nothing -> Nil
+mapMaybeWithKey _ Nil = Nil
+
+-- | \(O(n)\). Map values and separate the 'Left' and 'Right' results.
+--
+-- > let f a = if a < "c" then Left a else Right a
+-- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
+-- > == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")])
+-- >
+-- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
+-- > == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
+
+mapEither :: (a -> Either b c) -> Word64Map a -> (Word64Map b, Word64Map c)
+mapEither f m
+ = mapEitherWithKey (\_ x -> f x) m
+
+-- | \(O(n)\). Map keys\/values and separate the 'Left' and 'Right' results.
+--
+-- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a)
+-- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
+-- > == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")])
+-- >
+-- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
+-- > == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])
+
+mapEitherWithKey :: (Key -> a -> Either b c) -> Word64Map a -> (Word64Map b, Word64Map c)
+mapEitherWithKey f0 t0 = toPair $ go f0 t0
+ where
+ go f (Bin p m l r) =
+ bin p m l1 r1 :*: bin p m l2 r2
+ where
+ (l1 :*: l2) = go f l
+ (r1 :*: r2) = go f r
+ go f (Tip k x) = case f k x of
+ Left y -> (Tip k y :*: Nil)
+ Right z -> (Nil :*: Tip k z)
+ go _ Nil = (Nil :*: Nil)
+
+-- | \(O(\min(n,W))\). The expression (@'split' k map@) is a pair @(map1,map2)@
+-- where all keys in @map1@ are lower than @k@ and all keys in
+-- @map2@ larger than @k@. Any key equal to @k@ is found in neither @map1@ nor @map2@.
+--
+-- > split 2 (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3,"b"), (5,"a")])
+-- > split 3 (fromList [(5,"a"), (3,"b")]) == (empty, singleton 5 "a")
+-- > split 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")
+-- > split 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", empty)
+-- > split 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], empty)
+
+split :: Key -> Word64Map a -> (Word64Map a, Word64Map a)
+split k t =
+ case t of
+ Bin p m l r
+ | m < 0 ->
+ if k >= 0 -- handle negative numbers.
+ then
+ case go k l of
+ (lt :*: gt) ->
+ let !lt' = bin p m lt r
+ in (lt', gt)
+ else
+ case go k r of
+ (lt :*: gt) ->
+ let !gt' = bin p m l gt
+ in (lt, gt')
+ _ -> case go k t of
+ (lt :*: gt) -> (lt, gt)
+ where
+ go k' t'@(Bin p m l r)
+ | nomatch k' p m = if k' > p then t' :*: Nil else Nil :*: t'
+ | zero k' m = case go k' l of (lt :*: gt) -> lt :*: bin p m gt r
+ | otherwise = case go k' r of (lt :*: gt) -> bin p m l lt :*: gt
+ go k' t'@(Tip ky _)
+ | k' > ky = (t' :*: Nil)
+ | k' < ky = (Nil :*: t')
+ | otherwise = (Nil :*: Nil)
+ go _ Nil = (Nil :*: Nil)
+
+
+data SplitLookup a = SplitLookup !(Word64Map a) !(Maybe a) !(Word64Map a)
+
+mapLT :: (Word64Map a -> Word64Map a) -> SplitLookup a -> SplitLookup a
+mapLT f (SplitLookup lt fnd gt) = SplitLookup (f lt) fnd gt
+{-# INLINE mapLT #-}
+
+mapGT :: (Word64Map a -> Word64Map a) -> SplitLookup a -> SplitLookup a
+mapGT f (SplitLookup lt fnd gt) = SplitLookup lt fnd (f gt)
+{-# INLINE mapGT #-}
+
+-- | \(O(\min(n,W))\). Performs a 'split' but also returns whether the pivot
+-- key was found in the original map.
+--
+-- > splitLookup 2 (fromList [(5,"a"), (3,"b")]) == (empty, Nothing, fromList [(3,"b"), (5,"a")])
+-- > splitLookup 3 (fromList [(5,"a"), (3,"b")]) == (empty, Just "b", singleton 5 "a")
+-- > splitLookup 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Nothing, singleton 5 "a")
+-- > splitLookup 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Just "a", empty)
+-- > splitLookup 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], Nothing, empty)
+
+splitLookup :: Key -> Word64Map a -> (Word64Map a, Maybe a, Word64Map a)
+splitLookup k t =
+ case
+ case t of
+ Bin p m l r
+ | m < 0 ->
+ if k >= 0 -- handle negative numbers.
+ then mapLT (flip (bin p m) r) (go k l)
+ else mapGT (bin p m l) (go k r)
+ _ -> go k t
+ of SplitLookup lt fnd gt -> (lt, fnd, gt)
+ where
+ go k' t'@(Bin p m l r)
+ | nomatch k' p m =
+ if k' > p
+ then SplitLookup t' Nothing Nil
+ else SplitLookup Nil Nothing t'
+ | zero k' m = mapGT (flip (bin p m) r) (go k' l)
+ | otherwise = mapLT (bin p m l) (go k' r)
+ go k' t'@(Tip ky y)
+ | k' > ky = SplitLookup t' Nothing Nil
+ | k' < ky = SplitLookup Nil Nothing t'
+ | otherwise = SplitLookup Nil (Just y) Nil
+ go _ Nil = SplitLookup Nil Nothing Nil
+
+{--------------------------------------------------------------------
+ Fold
+--------------------------------------------------------------------}
+-- | \(O(n)\). Fold the values in the map using the given right-associative
+-- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'elems'@.
+--
+-- For example,
+--
+-- > elems map = foldr (:) [] map
+--
+-- > let f a len = len + (length a)
+-- > foldr f 0 (fromList [(5,"a"), (3,"bbb")]) == 4
+foldr :: (a -> b -> b) -> b -> Word64Map a -> b
+foldr f z = \t -> -- Use lambda t to be inlinable with two arguments only.
+ case t of
+ Bin _ m l r
+ | m < 0 -> go (go z l) r -- put negative numbers before
+ | otherwise -> go (go z r) l
+ _ -> go z t
+ where
+ go z' Nil = z'
+ go z' (Tip _ x) = f x z'
+ go z' (Bin _ _ l r) = go (go z' r) l
+{-# INLINE foldr #-}
+
+-- | \(O(n)\). A strict version of 'foldr'. Each application of the operator is
+-- evaluated before using the result in the next application. This
+-- function is strict in the starting value.
+foldr' :: (a -> b -> b) -> b -> Word64Map a -> b
+foldr' f z = \t -> -- Use lambda t to be inlinable with two arguments only.
+ case t of
+ Bin _ m l r
+ | m < 0 -> go (go z l) r -- put negative numbers before
+ | otherwise -> go (go z r) l
+ _ -> go z t
+ where
+ go !z' Nil = z'
+ go z' (Tip _ x) = f x z'
+ go z' (Bin _ _ l r) = go (go z' r) l
+{-# INLINE foldr' #-}
+
+-- | \(O(n)\). Fold the values in the map using the given left-associative
+-- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'elems'@.
+--
+-- For example,
+--
+-- > elems = reverse . foldl (flip (:)) []
+--
+-- > let f len a = len + (length a)
+-- > foldl f 0 (fromList [(5,"a"), (3,"bbb")]) == 4
+foldl :: (a -> b -> a) -> a -> Word64Map b -> a
+foldl f z = \t -> -- Use lambda t to be inlinable with two arguments only.
+ case t of
+ Bin _ m l r
+ | m < 0 -> go (go z r) l -- put negative numbers before
+ | otherwise -> go (go z l) r
+ _ -> go z t
+ where
+ go z' Nil = z'
+ go z' (Tip _ x) = f z' x
+ go z' (Bin _ _ l r) = go (go z' l) r
+{-# INLINE foldl #-}
+
+-- | \(O(n)\). A strict version of 'foldl'. Each application of the operator is
+-- evaluated before using the result in the next application. This
+-- function is strict in the starting value.
+foldl' :: (a -> b -> a) -> a -> Word64Map b -> a
+foldl' f z = \t -> -- Use lambda t to be inlinable with two arguments only.
+ case t of
+ Bin _ m l r
+ | m < 0 -> go (go z r) l -- put negative numbers before
+ | otherwise -> go (go z l) r
+ _ -> go z t
+ where
+ go !z' Nil = z'
+ go z' (Tip _ x) = f z' x
+ go z' (Bin _ _ l r) = go (go z' l) r
+{-# INLINE foldl' #-}
+
+-- | \(O(n)\). Fold the keys and values in the map using the given right-associative
+-- binary operator, such that
+-- @'foldrWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.
+--
+-- For example,
+--
+-- > keys map = foldrWithKey (\k x ks -> k:ks) [] map
+--
+-- > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"
+-- > foldrWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)"
+foldrWithKey :: (Key -> a -> b -> b) -> b -> Word64Map a -> b
+foldrWithKey f z = \t -> -- Use lambda t to be inlinable with two arguments only.
+ case t of
+ Bin _ m l r
+ | m < 0 -> go (go z l) r -- put negative numbers before
+ | otherwise -> go (go z r) l
+ _ -> go z t
+ where
+ go z' Nil = z'
+ go z' (Tip kx x) = f kx x z'
+ go z' (Bin _ _ l r) = go (go z' r) l
+{-# INLINE foldrWithKey #-}
+
+-- | \(O(n)\). A strict version of 'foldrWithKey'. Each application of the operator is
+-- evaluated before using the result in the next application. This
+-- function is strict in the starting value.
+foldrWithKey' :: (Key -> a -> b -> b) -> b -> Word64Map a -> b
+foldrWithKey' f z = \t -> -- Use lambda t to be inlinable with two arguments only.
+ case t of
+ Bin _ m l r
+ | m < 0 -> go (go z l) r -- put negative numbers before
+ | otherwise -> go (go z r) l
+ _ -> go z t
+ where
+ go !z' Nil = z'
+ go z' (Tip kx x) = f kx x z'
+ go z' (Bin _ _ l r) = go (go z' r) l
+{-# INLINE foldrWithKey' #-}
+
+-- | \(O(n)\). Fold the keys and values in the map using the given left-associative
+-- binary operator, such that
+-- @'foldlWithKey' f z == 'Prelude.foldl' (\\z' (kx, x) -> f z' kx x) z . 'toAscList'@.
+--
+-- For example,
+--
+-- > keys = reverse . foldlWithKey (\ks k x -> k:ks) []
+--
+-- > let f result k a = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"
+-- > foldlWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (3:b)(5:a)"
+foldlWithKey :: (a -> Key -> b -> a) -> a -> Word64Map b -> a
+foldlWithKey f z = \t -> -- Use lambda t to be inlinable with two arguments only.
+ case t of
+ Bin _ m l r
+ | m < 0 -> go (go z r) l -- put negative numbers before
+ | otherwise -> go (go z l) r
+ _ -> go z t
+ where
+ go z' Nil = z'
+ go z' (Tip kx x) = f z' kx x
+ go z' (Bin _ _ l r) = go (go z' l) r
+{-# INLINE foldlWithKey #-}
+
+-- | \(O(n)\). A strict version of 'foldlWithKey'. Each application of the operator is
+-- evaluated before using the result in the next application. This
+-- function is strict in the starting value.
+foldlWithKey' :: (a -> Key -> b -> a) -> a -> Word64Map b -> a
+foldlWithKey' f z = \t -> -- Use lambda t to be inlinable with two arguments only.
+ case t of
+ Bin _ m l r
+ | m < 0 -> go (go z r) l -- put negative numbers before
+ | otherwise -> go (go z l) r
+ _ -> go z t
+ where
+ go !z' Nil = z'
+ go z' (Tip kx x) = f z' kx x
+ go z' (Bin _ _ l r) = go (go z' l) r
+{-# INLINE foldlWithKey' #-}
+
+-- | \(O(n)\). Fold the keys and values in the map using the given monoid, such that
+--
+-- @'foldMapWithKey' f = 'Prelude.fold' . 'mapWithKey' f@
+--
+-- This can be an asymptotically faster than 'foldrWithKey' or 'foldlWithKey' for some monoids.
+--
+-- @since 0.5.4
+foldMapWithKey :: Monoid m => (Key -> a -> m) -> Word64Map a -> m
+foldMapWithKey f = go
+ where
+ go Nil = mempty
+ go (Tip kx x) = f kx x
+ go (Bin _ m l r)
+ | m < 0 = go r `mappend` go l
+ | otherwise = go l `mappend` go r
+{-# INLINE foldMapWithKey #-}
+
+{--------------------------------------------------------------------
+ List variations
+--------------------------------------------------------------------}
+-- | \(O(n)\).
+-- Return all elements of the map in the ascending order of their keys.
+-- Subject to list fusion.
+--
+-- > elems (fromList [(5,"a"), (3,"b")]) == ["b","a"]
+-- > elems empty == []
+
+elems :: Word64Map a -> [a]
+elems = foldr (:) []
+
+-- | \(O(n)\). Return all keys of the map in ascending order. Subject to list
+-- fusion.
+--
+-- > keys (fromList [(5,"a"), (3,"b")]) == [3,5]
+-- > keys empty == []
+
+keys :: Word64Map a -> [Key]
+keys = foldrWithKey (\k _ ks -> k : ks) []
+
+-- | \(O(n)\). An alias for 'toAscList'. Returns all key\/value pairs in the
+-- map in ascending key order. Subject to list fusion.
+--
+-- > assocs (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]
+-- > assocs empty == []
+
+assocs :: Word64Map a -> [(Key,a)]
+assocs = toAscList
+
+-- | \(O(n \min(n,W))\). The set of all keys of the map.
+--
+-- > keysSet (fromList [(5,"a"), (3,"b")]) == Data.Word64Set.fromList [3,5]
+-- > keysSet empty == Data.Word64Set.empty
+
+keysSet :: Word64Map a -> Word64Set.Word64Set
+keysSet Nil = Word64Set.Nil
+keysSet (Tip kx _) = Word64Set.singleton kx
+keysSet (Bin p m l r)
+ | m .&. Word64Set.suffixBitMask == 0 = Word64Set.Bin p m (keysSet l) (keysSet r)
+ | otherwise = Word64Set.Tip (p .&. Word64Set.prefixBitMask) (computeBm (computeBm 0 l) r)
+ where computeBm !acc (Bin _ _ l' r') = computeBm (computeBm acc l') r'
+ computeBm acc (Tip kx _) = acc .|. Word64Set.bitmapOf kx
+ computeBm _ Nil = error "Data.Word64Set.keysSet: Nil"
+
+-- | \(O(n)\). Build a map from a set of keys and a function which for each key
+-- computes its value.
+--
+-- > fromSet (\k -> replicate k 'a') (Data.Word64Set.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")]
+-- > fromSet undefined Data.Word64Set.empty == empty
+
+fromSet :: (Key -> a) -> Word64Set.Word64Set -> Word64Map a
+fromSet _ Word64Set.Nil = Nil
+fromSet f (Word64Set.Bin p m l r) = Bin p m (fromSet f l) (fromSet f r)
+fromSet f (Word64Set.Tip kx bm) = buildTree f kx bm (Word64Set.suffixBitMask + 1)
+ where
+ -- This is slightly complicated, as we to convert the dense
+ -- representation of Word64Set into tree representation of Word64Map.
+ --
+ -- We are given a nonzero bit mask 'bmask' of 'bits' bits with
+ -- prefix 'prefix'. We split bmask into halves corresponding
+ -- to left and right subtree. If they are both nonempty, we
+ -- create a Bin node, otherwise exactly one of them is nonempty
+ -- and we construct the Word64Map from that half.
+ buildTree g !prefix !bmask bits = case bits of
+ 0 -> Tip prefix (g prefix)
+ _ -> case intFromNat ((natFromInt bits) `shiftRL` 1) of
+ bits2
+ | bmask .&. ((1 `shiftLL` fromIntegral bits2) - 1) == 0 ->
+ buildTree g (prefix + bits2) (bmask `shiftRL` fromIntegral bits2) bits2
+ | (bmask `shiftRL` fromIntegral bits2) .&. ((1 `shiftLL` fromIntegral bits2) - 1) == 0 ->
+ buildTree g prefix bmask bits2
+ | otherwise ->
+ Bin prefix bits2
+ (buildTree g prefix bmask bits2)
+ (buildTree g (prefix + bits2) (bmask `shiftRL` fromIntegral bits2) bits2)
+
+{--------------------------------------------------------------------
+ Lists
+--------------------------------------------------------------------}
+
+#ifdef __GLASGOW_HASKELL__
+-- | @since 0.5.6.2
+instance GHCExts.IsList (Word64Map a) where
+ type Item (Word64Map a) = (Key,a)
+ fromList = fromList
+ toList = toList
+#endif
+
+-- | \(O(n)\). Convert the map to a list of key\/value pairs. Subject to list
+-- fusion.
+--
+-- > toList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]
+-- > toList empty == []
+
+toList :: Word64Map a -> [(Key,a)]
+toList = toAscList
+
+-- | \(O(n)\). Convert the map to a list of key\/value pairs where the
+-- keys are in ascending order. Subject to list fusion.
+--
+-- > toAscList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]
+
+toAscList :: Word64Map a -> [(Key,a)]
+toAscList = foldrWithKey (\k x xs -> (k,x):xs) []
+
+-- | \(O(n)\). Convert the map to a list of key\/value pairs where the keys
+-- are in descending order. Subject to list fusion.
+--
+-- > toDescList (fromList [(5,"a"), (3,"b")]) == [(5,"a"), (3,"b")]
+
+toDescList :: Word64Map a -> [(Key,a)]
+toDescList = foldlWithKey (\xs k x -> (k,x):xs) []
+
+-- List fusion for the list generating functions.
+#if __GLASGOW_HASKELL__
+-- The foldrFB and foldlFB are fold{r,l}WithKey equivalents, used for list fusion.
+-- They are important to convert unfused methods back, see mapFB in prelude.
+foldrFB :: (Key -> a -> b -> b) -> b -> Word64Map a -> b
+foldrFB = foldrWithKey
+{-# INLINE[0] foldrFB #-}
+foldlFB :: (a -> Key -> b -> a) -> a -> Word64Map b -> a
+foldlFB = foldlWithKey
+{-# INLINE[0] foldlFB #-}
+
+-- Inline assocs and toList, so that we need to fuse only toAscList.
+{-# INLINE assocs #-}
+{-# INLINE toList #-}
+
+-- The fusion is enabled up to phase 2 included. If it does not succeed,
+-- convert in phase 1 the expanded elems,keys,to{Asc,Desc}List calls back to
+-- elems,keys,to{Asc,Desc}List. In phase 0, we inline fold{lr}FB (which were
+-- used in a list fusion, otherwise it would go away in phase 1), and let compiler
+-- do whatever it wants with elems,keys,to{Asc,Desc}List -- it was forbidden to
+-- inline it before phase 0, otherwise the fusion rules would not fire at all.
+{-# NOINLINE[0] elems #-}
+{-# NOINLINE[0] keys #-}
+{-# NOINLINE[0] toAscList #-}
+{-# NOINLINE[0] toDescList #-}
+{-# RULES "Word64Map.elems" [~1] forall m . elems m = build (\c n -> foldrFB (\_ x xs -> c x xs) n m) #-}
+{-# RULES "Word64Map.elemsBack" [1] foldrFB (\_ x xs -> x : xs) [] = elems #-}
+{-# RULES "Word64Map.keys" [~1] forall m . keys m = build (\c n -> foldrFB (\k _ xs -> c k xs) n m) #-}
+{-# RULES "Word64Map.keysBack" [1] foldrFB (\k _ xs -> k : xs) [] = keys #-}
+{-# RULES "Word64Map.toAscList" [~1] forall m . toAscList m = build (\c n -> foldrFB (\k x xs -> c (k,x) xs) n m) #-}
+{-# RULES "Word64Map.toAscListBack" [1] foldrFB (\k x xs -> (k, x) : xs) [] = toAscList #-}
+{-# RULES "Word64Map.toDescList" [~1] forall m . toDescList m = build (\c n -> foldlFB (\xs k x -> c (k,x) xs) n m) #-}
+{-# RULES "Word64Map.toDescListBack" [1] foldlFB (\xs k x -> (k, x) : xs) [] = toDescList #-}
+#endif
+
+
+-- | \(O(n \min(n,W))\). Create a map from a list of key\/value pairs.
+--
+-- > fromList [] == empty
+-- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]
+-- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")]
+
+fromList :: [(Key,a)] -> Word64Map a
+fromList xs
+ = Foldable.foldl' ins empty xs
+ where
+ ins t (k,x) = insert k x t
+
+-- | \(O(n \min(n,W))\). Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.
+--
+-- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "ab"), (5, "cba")]
+-- > fromListWith (++) [] == empty
+
+fromListWith :: (a -> a -> a) -> [(Key,a)] -> Word64Map a
+fromListWith f xs
+ = fromListWithKey (\_ x y -> f x y) xs
+
+-- | \(O(n \min(n,W))\). Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'.
+--
+-- > let f key new_value old_value = show key ++ ":" ++ new_value ++ "|" ++ old_value
+-- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "3:a|b"), (5, "5:c|5:b|a")]
+-- > fromListWithKey f [] == empty
+
+fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> Word64Map a
+fromListWithKey f xs
+ = Foldable.foldl' ins empty xs
+ where
+ ins t (k,x) = insertWithKey f k x t
+
+-- | \(O(n)\). Build a map from a list of key\/value pairs where
+-- the keys are in ascending order.
+--
+-- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]
+-- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]
+
+fromAscList :: [(Key,a)] -> Word64Map a
+fromAscList = fromMonoListWithKey Nondistinct (\_ x _ -> x)
+{-# NOINLINE fromAscList #-}
+
+-- | \(O(n)\). Build a map from a list of key\/value pairs where
+-- the keys are in ascending order, with a combining function on equal keys.
+-- /The precondition (input list is ascending) is not checked./
+--
+-- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]
+
+fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> Word64Map a
+fromAscListWith f = fromMonoListWithKey Nondistinct (\_ x y -> f x y)
+{-# NOINLINE fromAscListWith #-}
+
+-- | \(O(n)\). Build a map from a list of key\/value pairs where
+-- the keys are in ascending order, with a combining function on equal keys.
+-- /The precondition (input list is ascending) is not checked./
+--
+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value
+-- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "5:b|a")]
+
+fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> Word64Map a
+fromAscListWithKey f = fromMonoListWithKey Nondistinct f
+{-# NOINLINE fromAscListWithKey #-}
+
+-- | \(O(n)\). Build a map from a list of key\/value pairs where
+-- the keys are in ascending order and all distinct.
+-- /The precondition (input list is strictly ascending) is not checked./
+--
+-- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]
+
+fromDistinctAscList :: [(Key,a)] -> Word64Map a
+fromDistinctAscList = fromMonoListWithKey Distinct (\_ x _ -> x)
+{-# NOINLINE fromDistinctAscList #-}
+
+-- | \(O(n)\). Build a map from a list of key\/value pairs with monotonic keys
+-- and a combining function.
+--
+-- The precise conditions under which this function works are subtle:
+-- For any branch mask, keys with the same prefix w.r.t. the branch
+-- mask must occur consecutively in the list.
+
+fromMonoListWithKey :: Distinct -> (Key -> a -> a -> a) -> [(Key,a)] -> Word64Map a
+fromMonoListWithKey distinct f = go
+ where
+ go [] = Nil
+ go ((kx,vx) : zs1) = addAll' kx vx zs1
+
+ -- `addAll'` collects all keys equal to `kx` into a single value,
+ -- and then proceeds with `addAll`.
+ addAll' !kx vx []
+ = Tip kx vx
+ addAll' !kx vx ((ky,vy) : zs)
+ | Nondistinct <- distinct, kx == ky
+ = let v = f kx vy vx in addAll' ky v zs
+ -- inlined: | otherwise = addAll kx (Tip kx vx) (ky : zs)
+ | m <- branchMask kx ky
+ , Inserted ty zs' <- addMany' m ky vy zs
+ = addAll kx (linkWithMask m ky ty {-kx-} (Tip kx vx)) zs'
+
+ -- for `addAll` and `addMany`, kx is /a/ key inside the tree `tx`
+ -- `addAll` consumes the rest of the list, adding to the tree `tx`
+ addAll !_kx !tx []
+ = tx
+ addAll !kx !tx ((ky,vy) : zs)
+ | m <- branchMask kx ky
+ , Inserted ty zs' <- addMany' m ky vy zs
+ = addAll kx (linkWithMask m ky ty {-kx-} tx) zs'
+
+ -- `addMany'` is similar to `addAll'`, but proceeds with `addMany'`.
+ addMany' !_m !kx vx []
+ = Inserted (Tip kx vx) []
+ addMany' !m !kx vx zs0@((ky,vy) : zs)
+ | Nondistinct <- distinct, kx == ky
+ = let v = f kx vy vx in addMany' m ky v zs
+ -- inlined: | otherwise = addMany m kx (Tip kx vx) (ky : zs)
+ | mask kx m /= mask ky m
+ = Inserted (Tip kx vx) zs0
+ | mxy <- branchMask kx ky
+ , Inserted ty zs' <- addMany' mxy ky vy zs
+ = addMany m kx (linkWithMask mxy ky ty {-kx-} (Tip kx vx)) zs'
+
+ -- `addAll` adds to `tx` all keys whose prefix w.r.t. `m` agrees with `kx`.
+ addMany !_m !_kx tx []
+ = Inserted tx []
+ addMany !m !kx tx zs0@((ky,vy) : zs)
+ | mask kx m /= mask ky m
+ = Inserted tx zs0
+ | mxy <- branchMask kx ky
+ , Inserted ty zs' <- addMany' mxy ky vy zs
+ = addMany m kx (linkWithMask mxy ky ty {-kx-} tx) zs'
+{-# INLINE fromMonoListWithKey #-}
+
+data Inserted a = Inserted !(Word64Map a) ![(Key,a)]
+
+data Distinct = Distinct | Nondistinct
+
+{--------------------------------------------------------------------
+ Eq
+--------------------------------------------------------------------}
+instance Eq a => Eq (Word64Map a) where
+ t1 == t2 = equal t1 t2
+ t1 /= t2 = nequal t1 t2
+
+equal :: Eq a => Word64Map a -> Word64Map a -> Bool
+equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
+ = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2)
+equal (Tip kx x) (Tip ky y)
+ = (kx == ky) && (x==y)
+equal Nil Nil = True
+equal _ _ = False
+
+nequal :: Eq a => Word64Map a -> Word64Map a -> Bool
+nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
+ = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2)
+nequal (Tip kx x) (Tip ky y)
+ = (kx /= ky) || (x/=y)
+nequal Nil Nil = False
+nequal _ _ = True
+
+-- | @since 0.5.9
+instance Eq1 Word64Map where
+ liftEq eq (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
+ = (m1 == m2) && (p1 == p2) && (liftEq eq l1 l2) && (liftEq eq r1 r2)
+ liftEq eq (Tip kx x) (Tip ky y)
+ = (kx == ky) && (eq x y)
+ liftEq _eq Nil Nil = True
+ liftEq _eq _ _ = False
+
+{--------------------------------------------------------------------
+ Ord
+--------------------------------------------------------------------}
+
+instance Ord a => Ord (Word64Map a) where
+ compare m1 m2 = compare (toList m1) (toList m2)
+
+-- | @since 0.5.9
+instance Ord1 Word64Map where
+ liftCompare cmp m n =
+ liftCompare (liftCompare cmp) (toList m) (toList n)
+
+{--------------------------------------------------------------------
+ Functor
+--------------------------------------------------------------------}
+
+instance Functor Word64Map where
+ fmap = map
+
+#ifdef __GLASGOW_HASKELL__
+ a <$ Bin p m l r = Bin p m (a <$ l) (a <$ r)
+ a <$ Tip k _ = Tip k a
+ _ <$ Nil = Nil
+#endif
+
+{--------------------------------------------------------------------
+ Show
+--------------------------------------------------------------------}
+
+instance Show a => Show (Word64Map a) where
+ showsPrec d m = showParen (d > 10) $
+ showString "fromList " . shows (toList m)
+
+-- | @since 0.5.9
+instance Show1 Word64Map where
+ liftShowsPrec sp sl d m =
+ showsUnaryWith (liftShowsPrec sp' sl') "fromList" d (toList m)
+ where
+ sp' = liftShowsPrec sp sl
+ sl' = liftShowList sp sl
+
+{--------------------------------------------------------------------
+ Read
+--------------------------------------------------------------------}
+instance (Read e) => Read (Word64Map e) where
+#ifdef __GLASGOW_HASKELL__
+ readPrec = parens $ prec 10 $ do
+ Ident "fromList" <- lexP
+ xs <- readPrec
+ return (fromList xs)
+
+ readListPrec = readListPrecDefault
+#else
+ readsPrec p = readParen (p > 10) $ \ r -> do
+ ("fromList",s) <- lex r
+ (xs,t) <- reads s
+ return (fromList xs,t)
+#endif
+
+-- | @since 0.5.9
+instance Read1 Word64Map where
+ liftReadsPrec rp rl = readsData $
+ readsUnaryWith (liftReadsPrec rp' rl') "fromList" fromList
+ where
+ rp' = liftReadsPrec rp rl
+ rl' = liftReadList rp rl
+
+{--------------------------------------------------------------------
+ Helpers
+--------------------------------------------------------------------}
+{--------------------------------------------------------------------
+ Link
+--------------------------------------------------------------------}
+link :: Prefix -> Word64Map a -> Prefix -> Word64Map a -> Word64Map a
+link p1 t1 p2 t2 = linkWithMask (branchMask p1 p2) p1 t1 {-p2-} t2
+{-# INLINE link #-}
+
+-- `linkWithMask` is useful when the `branchMask` has already been computed
+linkWithMask :: Mask -> Prefix -> Word64Map a -> Word64Map a -> Word64Map a
+linkWithMask m p1 t1 {-p2-} t2
+ | zero p1 m = Bin p m t1 t2
+ | otherwise = Bin p m t2 t1
+ where
+ p = mask p1 m
+{-# INLINE linkWithMask #-}
+
+{--------------------------------------------------------------------
+ @bin@ assures that we never have empty trees within a tree.
+--------------------------------------------------------------------}
+bin :: Prefix -> Mask -> Word64Map a -> Word64Map a -> Word64Map a
+bin _ _ l Nil = l
+bin _ _ Nil r = r
+bin p m l r = Bin p m l r
+{-# INLINE bin #-}
+
+-- binCheckLeft only checks that the left subtree is non-empty
+binCheckLeft :: Prefix -> Mask -> Word64Map a -> Word64Map a -> Word64Map a
+binCheckLeft _ _ Nil r = r
+binCheckLeft p m l r = Bin p m l r
+{-# INLINE binCheckLeft #-}
+
+-- binCheckRight only checks that the right subtree is non-empty
+binCheckRight :: Prefix -> Mask -> Word64Map a -> Word64Map a -> Word64Map a
+binCheckRight _ _ l Nil = l
+binCheckRight p m l r = Bin p m l r
+{-# INLINE binCheckRight #-}
+
+{--------------------------------------------------------------------
+ Endian independent bit twiddling
+--------------------------------------------------------------------}
+
+-- | Should this key follow the left subtree of a 'Bin' with switching
+-- bit @m@? N.B., the answer is only valid when @match i p m@ is true.
+zero :: Key -> Mask -> Bool
+zero i m
+ = (natFromInt i) .&. (natFromInt m) == 0
+{-# INLINE zero #-}
+
+nomatch,match :: Key -> Prefix -> Mask -> Bool
+
+-- | Does the key @i@ differ from the prefix @p@ before getting to
+-- the switching bit @m@?
+nomatch i p m
+ = (mask i m) /= p
+{-# INLINE nomatch #-}
+
+-- | Does the key @i@ match the prefix @p@ (up to but not including
+-- bit @m@)?
+match i p m
+ = (mask i m) == p
+{-# INLINE match #-}
+
+
+-- | The prefix of key @i@ up to (but not including) the switching
+-- bit @m@.
+mask :: Key -> Mask -> Prefix
+mask i m
+ = maskW (natFromInt i) (natFromInt m)
+{-# INLINE mask #-}
+
+
+{--------------------------------------------------------------------
+ Big endian operations
+--------------------------------------------------------------------}
+
+-- | The prefix of key @i@ up to (but not including) the switching
+-- bit @m@.
+maskW :: Nat -> Nat -> Prefix
+maskW i m
+ = intFromNat (i .&. ((-m) `xor` m))
+{-# INLINE maskW #-}
+
+-- | Does the left switching bit specify a shorter prefix?
+shorter :: Mask -> Mask -> Bool
+shorter m1 m2
+ = (natFromInt m1) > (natFromInt m2)
+{-# INLINE shorter #-}
+
+-- | The first switching bit where the two prefixes disagree.
+branchMask :: Prefix -> Prefix -> Mask
+branchMask p1 p2
+ = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))
+{-# INLINE branchMask #-}
+
+{--------------------------------------------------------------------
+ Utilities
+--------------------------------------------------------------------}
+
+-- | \(O(1)\). Decompose a map into pieces based on the structure
+-- of the underlying tree. This function is useful for consuming a
+-- map in parallel.
+--
+-- No guarantee is made as to the sizes of the pieces; an internal, but
+-- deterministic process determines this. However, it is guaranteed that the
+-- pieces returned will be in ascending order (all elements in the first submap
+-- less than all elements in the second, and so on).
+--
+-- Examples:
+--
+-- > splitRoot (fromList (zip [1..6::Int] ['a'..])) ==
+-- > [fromList [(1,'a'),(2,'b'),(3,'c')],fromList [(4,'d'),(5,'e'),(6,'f')]]
+--
+-- > splitRoot empty == []
+--
+-- Note that the current implementation does not return more than two submaps,
+-- but you should not depend on this behaviour because it can change in the
+-- future without notice.
+splitRoot :: Word64Map a -> [Word64Map a]
+splitRoot orig =
+ case orig of
+ Nil -> []
+ x@(Tip _ _) -> [x]
+ Bin _ m l r | m < 0 -> [r, l]
+ | otherwise -> [l, r]
+{-# INLINE splitRoot #-}
+
+
+{--------------------------------------------------------------------
+ Debugging
+--------------------------------------------------------------------}
+
+-- | \(O(n \min(n,W))\). Show the tree that implements the map. The tree is shown
+-- in a compressed, hanging format.
+showTree :: Show a => Word64Map a -> String
+showTree s
+ = showTreeWith True False s
+
+
+{- | \(O(n \min(n,W))\). The expression (@'showTreeWith' hang wide map@) shows
+ the tree that implements the map. If @hang@ is
+ 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If
+ @wide@ is 'True', an extra wide version is shown.
+-}
+showTreeWith :: Show a => Bool -> Bool -> Word64Map a -> String
+showTreeWith hang wide t
+ | hang = (showsTreeHang wide [] t) ""
+ | otherwise = (showsTree wide [] [] t) ""
+
+showsTree :: Show a => Bool -> [String] -> [String] -> Word64Map a -> ShowS
+showsTree wide lbars rbars t = case t of
+ Bin p m l r ->
+ showsTree wide (withBar rbars) (withEmpty rbars) r .
+ showWide wide rbars .
+ showsBars lbars . showString (showBin p m) . showString "\n" .
+ showWide wide lbars .
+ showsTree wide (withEmpty lbars) (withBar lbars) l
+ Tip k x ->
+ showsBars lbars .
+ showString " " . shows k . showString ":=" . shows x . showString "\n"
+ Nil -> showsBars lbars . showString "|\n"
+
+showsTreeHang :: Show a => Bool -> [String] -> Word64Map a -> ShowS
+showsTreeHang wide bars t = case t of
+ Bin p m l r ->
+ showsBars bars . showString (showBin p m) . showString "\n" .
+ showWide wide bars .
+ showsTreeHang wide (withBar bars) l .
+ showWide wide bars .
+ showsTreeHang wide (withEmpty bars) r
+ Tip k x ->
+ showsBars bars .
+ showString " " . shows k . showString ":=" . shows x . showString "\n"
+ Nil -> showsBars bars . showString "|\n"
+
+showBin :: Prefix -> Mask -> String
+showBin _ _
+ = "*" -- ++ show (p,m)
+
+showWide :: Bool -> [String] -> String -> String
+showWide wide bars
+ | wide = showString (concat (reverse bars)) . showString "|\n"
+ | otherwise = id
+
+showsBars :: [String] -> ShowS
+showsBars bars
+ = case bars of
+ [] -> id
+ _ : tl -> showString (concat (reverse tl)) . showString node
+
+node :: String
+node = "+--"
+
+withBar, withEmpty :: [String] -> [String]
+withBar bars = "| ":bars
+withEmpty bars = " ":bars
diff --git a/compiler/GHC/Data/Word64Map/Lazy.hs b/compiler/GHC/Data/Word64Map/Lazy.hs
new file mode 100644
index 0000000000000000000000000000000000000000..0df84842e2a7ce2c6aacb91c404b8a8f3f5c512e
--- /dev/null
+++ b/compiler/GHC/Data/Word64Map/Lazy.hs
@@ -0,0 +1,237 @@
+{-# LANGUAGE CPP #-}
+#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)
+{-# LANGUAGE Safe #-}
+#endif
+
+#include "containers.h"
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Data.Word64Map.Lazy
+-- Copyright : (c) Daan Leijen 2002
+-- (c) Andriy Palamarchuk 2008
+-- License : BSD-style
+-- Maintainer : libraries@haskell.org
+-- Portability : portable
+--
+--
+-- = Finite Word64 Maps (lazy interface)
+--
+-- The @'Word64Map' v@ type represents a finite map (sometimes called a dictionary)
+-- from keys of type @Word64@ to values of type @v@.
+--
+-- The functions in "Data.Word64Map.Strict" are careful to force values before
+-- installing them in an 'Word64Map'. This is usually more efficient in cases where
+-- laziness is not essential. The functions in this module do not do so.
+--
+-- For a walkthrough of the most commonly used functions see the
+-- <https://haskell-containers.readthedocs.io/en/latest/map.html maps introduction>.
+--
+-- This module is intended to be imported qualified, to avoid name clashes with
+-- Prelude functions:
+--
+-- > import Data.Word64Map.Lazy (Word64Map)
+-- > import qualified Data.Word64Map.Lazy as Word64Map
+--
+-- Note that the implementation is generally /left-biased/. Functions that take
+-- two maps as arguments and combine them, such as `union` and `intersection`,
+-- prefer the values in the first argument to those in the second.
+--
+--
+-- == Detailed performance information
+--
+-- The amortized running time is given for each operation, with \(n\) referring to
+-- the number of entries in the map and \(W\) referring to the number of bits in
+-- an 'Word64' (64).
+--
+-- Benchmarks comparing "Data.Word64Map.Lazy" with other dictionary
+-- implementations can be found at https://github.com/haskell-perf/dictionaries.
+--
+--
+-- == Implementation
+--
+-- The implementation is based on /big-endian patricia trees/. This data
+-- structure performs especially well on binary operations like 'union' and
+-- 'intersection'. Additionally, benchmarks show that it is also (much) faster
+-- on insertions and deletions when compared to a generic size-balanced map
+-- implementation (see "Data.Map").
+--
+-- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\",
+-- Workshop on ML, September 1998, pages 77-86,
+-- <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.37.5452>
+--
+-- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",
+-- Journal of the ACM, 15(4), October 1968, pages 514-534.
+--
+-----------------------------------------------------------------------------
+
+module GHC.Data.Word64Map.Lazy (
+ -- * Map type
+#if !defined(TESTING)
+ Word64Map, Key -- instance Eq,Show
+#else
+ Word64Map(..), Key -- instance Eq,Show
+#endif
+
+ -- * Construction
+ , empty
+ , singleton
+ , fromSet
+
+ -- ** From Unordered Lists
+ , fromList
+ , fromListWith
+ , fromListWithKey
+
+ -- ** From Ascending Lists
+ , fromAscList
+ , fromAscListWith
+ , fromAscListWithKey
+ , fromDistinctAscList
+
+ -- * Insertion
+ , insert
+ , insertWith
+ , insertWithKey
+ , insertLookupWithKey
+
+ -- * Deletion\/Update
+ , delete
+ , adjust
+ , adjustWithKey
+ , update
+ , updateWithKey
+ , updateLookupWithKey
+ , alter
+ , alterF
+
+ -- * Query
+ -- ** Lookup
+ , WM.lookup
+ , (!?)
+ , (!)
+ , findWithDefault
+ , member
+ , notMember
+ , lookupLT
+ , lookupGT
+ , lookupLE
+ , lookupGE
+
+ -- ** Size
+ , WM.null
+ , size
+
+ -- * Combine
+
+ -- ** Union
+ , union
+ , unionWith
+ , unionWithKey
+ , unions
+ , unionsWith
+
+ -- ** Difference
+ , difference
+ , (\\)
+ , differenceWith
+ , differenceWithKey
+
+ -- ** Intersection
+ , intersection
+ , intersectionWith
+ , intersectionWithKey
+
+ -- ** Disjoint
+ , disjoint
+
+ -- ** Compose
+ , compose
+
+ -- ** Universal combining function
+ , mergeWithKey
+
+ -- * Traversal
+ -- ** Map
+ , WM.map
+ , mapWithKey
+ , traverseWithKey
+ , traverseMaybeWithKey
+ , mapAccum
+ , mapAccumWithKey
+ , mapAccumRWithKey
+ , mapKeys
+ , mapKeysWith
+ , mapKeysMonotonic
+
+ -- * Folds
+ , WM.foldr
+ , WM.foldl
+ , foldrWithKey
+ , foldlWithKey
+ , foldMapWithKey
+
+ -- ** Strict folds
+ , foldr'
+ , foldl'
+ , foldrWithKey'
+ , foldlWithKey'
+
+ -- * Conversion
+ , elems
+ , keys
+ , assocs
+ , keysSet
+
+ -- ** Lists
+ , toList
+
+ -- ** Ordered lists
+ , toAscList
+ , toDescList
+
+ -- * Filter
+ , WM.filter
+ , filterWithKey
+ , restrictKeys
+ , withoutKeys
+ , partition
+ , partitionWithKey
+
+ , takeWhileAntitone
+ , dropWhileAntitone
+ , spanAntitone
+
+ , mapMaybe
+ , mapMaybeWithKey
+ , mapEither
+ , mapEitherWithKey
+
+ , split
+ , splitLookup
+ , splitRoot
+
+ -- * Submap
+ , isSubmapOf, isSubmapOfBy
+ , isProperSubmapOf, isProperSubmapOfBy
+
+ -- * Min\/Max
+ , lookupMin
+ , lookupMax
+ , findMin
+ , findMax
+ , deleteMin
+ , deleteMax
+ , deleteFindMin
+ , deleteFindMax
+ , updateMin
+ , updateMax
+ , updateMinWithKey
+ , updateMaxWithKey
+ , minView
+ , maxView
+ , minViewWithKey
+ , maxViewWithKey
+ ) where
+
+import GHC.Data.Word64Map.Internal as WM
diff --git a/compiler/GHC/Data/Word64Map/Strict.hs b/compiler/GHC/Data/Word64Map/Strict.hs
new file mode 100644
index 0000000000000000000000000000000000000000..4de68d7f7c39560fffd7c5935042446311054574
--- /dev/null
+++ b/compiler/GHC/Data/Word64Map/Strict.hs
@@ -0,0 +1,257 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
+#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)
+{-# LANGUAGE Trustworthy #-}
+#endif
+
+#include "containers.h"
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Data.Word64Map.Strict
+-- Copyright : (c) Daan Leijen 2002
+-- (c) Andriy Palamarchuk 2008
+-- License : BSD-style
+-- Maintainer : libraries@haskell.org
+-- Portability : portable
+--
+--
+-- = Finite Word64 Maps (strict interface)
+--
+-- The @'Word64Map' v@ type represents a finite map (sometimes called a dictionary)
+-- from key of type @Word64@ to values of type @v@.
+--
+-- Each function in this module is careful to force values before installing
+-- them in an 'Word64Map'. This is usually more efficient when laziness is not
+-- necessary. When laziness /is/ required, use the functions in
+-- "Data.Word64Map.Lazy".
+--
+-- In particular, the functions in this module obey the following law:
+--
+-- - If all values stored in all maps in the arguments are in WHNF, then all
+-- values stored in all maps in the results will be in WHNF once those maps
+-- are evaluated.
+--
+-- For a walkthrough of the most commonly used functions see the
+-- <https://haskell-containers.readthedocs.io/en/latest/map.html maps introduction>.
+--
+-- This module is intended to be imported qualified, to avoid name clashes with
+-- Prelude functions:
+--
+-- > import Data.Word64Map.Strict (Word64Map)
+-- > import qualified Data.Word64Map.Strict as Word64Map
+--
+-- Note that the implementation is generally /left-biased/. Functions that take
+-- two maps as arguments and combine them, such as `union` and `intersection`,
+-- prefer the values in the first argument to those in the second.
+--
+--
+-- == Detailed performance information
+--
+-- The amortized running time is given for each operation, with \(n\) referring to
+-- the number of entries in the map and \(W\) referring to the number of bits in
+-- an 'Word64' (64).
+--
+-- Benchmarks comparing "Data.Word64Map.Strict" with other dictionary
+-- implementations can be found at https://github.com/haskell-perf/dictionaries.
+--
+--
+-- == Warning
+--
+-- The 'Word64Map' type is shared between the lazy and strict modules, meaning that
+-- the same 'Word64Map' value can be passed to functions in both modules. This
+-- means that the 'Functor', 'Traversable' and 'Data.Data.Data' instances are
+-- the same as for the "Data.Word64Map.Lazy" module, so if they are used the
+-- resulting map may contain suspended values (thunks).
+--
+--
+-- == Implementation
+--
+-- The implementation is based on /big-endian patricia trees/. This data
+-- structure performs especially well on binary operations like 'union' and
+-- 'intersection'. Additionally, benchmarks show that it is also (much) faster
+-- on insertions and deletions when compared to a generic size-balanced map
+-- implementation (see "Data.Map").
+--
+-- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\",
+-- Workshop on ML, September 1998, pages 77-86,
+-- <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.37.5452>
+--
+-- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",
+-- Journal of the ACM, 15(4), October 1968, pages 514-534.
+--
+-----------------------------------------------------------------------------
+
+-- See the notes at the beginning of Data.Word64Map.Internal.
+
+module GHC.Data.Word64Map.Strict (
+ -- * Map type
+#if !defined(TESTING)
+ Word64Map, Key -- instance Eq,Show
+#else
+ Word64Map(..), Key -- instance Eq,Show
+#endif
+
+ -- * Construction
+ , empty
+ , singleton
+ , fromSet
+
+ -- ** From Unordered Lists
+ , fromList
+ , fromListWith
+ , fromListWithKey
+
+ -- ** From Ascending Lists
+ , fromAscList
+ , fromAscListWith
+ , fromAscListWithKey
+ , fromDistinctAscList
+
+ -- * Insertion
+ , insert
+ , insertWith
+ , insertWithKey
+ , insertLookupWithKey
+
+ -- * Deletion\/Update
+ , delete
+ , adjust
+ , adjustWithKey
+ , update
+ , updateWithKey
+ , updateLookupWithKey
+ , alter
+ , alterF
+
+ -- * Query
+ -- ** Lookup
+ , lookup
+ , (!?)
+ , (!)
+ , findWithDefault
+ , member
+ , notMember
+ , lookupLT
+ , lookupGT
+ , lookupLE
+ , lookupGE
+
+ -- ** Size
+ , null
+ , size
+
+ -- * Combine
+
+ -- ** Union
+ , union
+ , unionWith
+ , unionWithKey
+ , unions
+ , unionsWith
+
+ -- ** Difference
+ , difference
+ , (\\)
+ , differenceWith
+ , differenceWithKey
+
+ -- ** Intersection
+ , intersection
+ , intersectionWith
+ , intersectionWithKey
+
+ -- ** Disjoint
+ , disjoint
+
+ -- ** Compose
+ , compose
+
+ -- ** Universal combining function
+ , mergeWithKey
+
+ -- * Traversal
+ -- ** Map
+ , map
+ , mapWithKey
+ , traverseWithKey
+ , traverseMaybeWithKey
+ , mapAccum
+ , mapAccumWithKey
+ , mapAccumRWithKey
+ , mapKeys
+ , mapKeysWith
+ , mapKeysMonotonic
+
+ -- * Folds
+ , foldr
+ , foldl
+ , foldrWithKey
+ , foldlWithKey
+ , foldMapWithKey
+
+ -- ** Strict folds
+ , foldr'
+ , foldl'
+ , foldrWithKey'
+ , foldlWithKey'
+
+ -- * Conversion
+ , elems
+ , keys
+ , assocs
+ , keysSet
+
+ -- ** Lists
+ , toList
+
+-- ** Ordered lists
+ , toAscList
+ , toDescList
+
+ -- * Filter
+ , filter
+ , filterWithKey
+ , restrictKeys
+ , withoutKeys
+ , partition
+ , partitionWithKey
+
+ , takeWhileAntitone
+ , dropWhileAntitone
+ , spanAntitone
+
+ , mapMaybe
+ , mapMaybeWithKey
+ , mapEither
+ , mapEitherWithKey
+
+ , split
+ , splitLookup
+ , splitRoot
+
+ -- * Submap
+ , isSubmapOf, isSubmapOfBy
+ , isProperSubmapOf, isProperSubmapOfBy
+
+ -- * Min\/Max
+ , lookupMin
+ , lookupMax
+ , findMin
+ , findMax
+ , deleteMin
+ , deleteMax
+ , deleteFindMin
+ , deleteFindMax
+ , updateMin
+ , updateMax
+ , updateMinWithKey
+ , updateMaxWithKey
+ , minView
+ , maxView
+ , minViewWithKey
+ , maxViewWithKey
+ ) where
+
+import GHC.Data.Word64Map.Strict.Internal
+import Prelude ()
diff --git a/compiler/GHC/Data/Word64Map/Strict/Internal.hs b/compiler/GHC/Data/Word64Map/Strict/Internal.hs
new file mode 100644
index 0000000000000000000000000000000000000000..1605565c9fd7a527fac61dbf162ce0a805f4f920
--- /dev/null
+++ b/compiler/GHC/Data/Word64Map/Strict/Internal.hs
@@ -0,0 +1,1208 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE PatternGuards #-}
+
+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
+
+#include "containers.h"
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Data.Word64Map.Strict.Internal
+-- Copyright : (c) Daan Leijen 2002
+-- (c) Andriy Palamarchuk 2008
+-- License : BSD-style
+-- Maintainer : libraries@haskell.org
+-- Portability : portable
+--
+--
+-- = Finite Int Maps (strict interface)
+--
+-- The @'Word64Map' v@ type represents a finite map (sometimes called a dictionary)
+-- from key of type @Int@ to values of type @v@.
+--
+-- Each function in this module is careful to force values before installing
+-- them in an 'Word64Map'. This is usually more efficient when laziness is not
+-- necessary. When laziness /is/ required, use the functions in
+-- "Data.Word64Map.Lazy".
+--
+-- In particular, the functions in this module obey the following law:
+--
+-- - If all values stored in all maps in the arguments are in WHNF, then all
+-- values stored in all maps in the results will be in WHNF once those maps
+-- are evaluated.
+--
+-- For a walkthrough of the most commonly used functions see the
+-- <https://haskell-containers.readthedocs.io/en/latest/map.html maps introduction>.
+--
+-- This module is intended to be imported qualified, to avoid name clashes with
+-- Prelude functions:
+--
+-- > import Data.Word64Map.Strict (Word64Map)
+-- > import qualified Data.Word64Map.Strict as Word64Map
+--
+-- Note that the implementation is generally /left-biased/. Functions that take
+-- two maps as arguments and combine them, such as `union` and `intersection`,
+-- prefer the values in the first argument to those in the second.
+--
+--
+-- == Detailed performance information
+--
+-- The amortized running time is given for each operation, with \(n\) referring to
+-- the number of entries in the map and \(W\) referring to the number of bits in
+-- an 'Int' (32 or 64).
+--
+-- Benchmarks comparing "Data.Word64Map.Strict" with other dictionary
+-- implementations can be found at https://github.com/haskell-perf/dictionaries.
+--
+--
+-- == Warning
+--
+-- The 'Word64Map' type is shared between the lazy and strict modules, meaning that
+-- the same 'Word64Map' value can be passed to functions in both modules. This
+-- means that the 'Functor', 'Traversable' and 'Data.Data.Data' instances are
+-- the same as for the "Data.Word64Map.Lazy" module, so if they are used the
+-- resulting map may contain suspended values (thunks).
+--
+--
+-- == Implementation
+--
+-- The implementation is based on /big-endian patricia trees/. This data
+-- structure performs especially well on binary operations like 'union' and
+-- 'intersection'. Additionally, benchmarks show that it is also (much) faster
+-- on insertions and deletions when compared to a generic size-balanced map
+-- implementation (see "Data.Map").
+--
+-- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\",
+-- Workshop on ML, September 1998, pages 77-86,
+-- <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.37.5452>
+--
+-- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",
+-- Journal of the ACM, 15(4), October 1968, pages 514-534.
+--
+-----------------------------------------------------------------------------
+
+-- See the notes at the beginning of Data.Word64Map.Internal.
+
+module GHC.Data.Word64Map.Strict.Internal (
+ -- * Map type
+#if !defined(TESTING)
+ Word64Map, Key -- instance Eq,Show
+#else
+ Word64Map(..), Key -- instance Eq,Show
+#endif
+
+ -- * Construction
+ , empty
+ , singleton
+ , fromSet
+
+ -- ** From Unordered Lists
+ , fromList
+ , fromListWith
+ , fromListWithKey
+
+ -- ** From Ascending Lists
+ , fromAscList
+ , fromAscListWith
+ , fromAscListWithKey
+ , fromDistinctAscList
+
+ -- * Insertion
+ , insert
+ , insertWith
+ , insertWithKey
+ , insertLookupWithKey
+
+ -- * Deletion\/Update
+ , delete
+ , adjust
+ , adjustWithKey
+ , update
+ , updateWithKey
+ , updateLookupWithKey
+ , alter
+ , alterF
+
+ -- * Query
+ -- ** Lookup
+ , lookup
+ , (!?)
+ , (!)
+ , findWithDefault
+ , member
+ , notMember
+ , lookupLT
+ , lookupGT
+ , lookupLE
+ , lookupGE
+
+ -- ** Size
+ , null
+ , size
+
+ -- * Combine
+
+ -- ** Union
+ , union
+ , unionWith
+ , unionWithKey
+ , unions
+ , unionsWith
+
+ -- ** Difference
+ , difference
+ , (\\)
+ , differenceWith
+ , differenceWithKey
+
+ -- ** Intersection
+ , intersection
+ , intersectionWith
+ , intersectionWithKey
+
+ -- ** Disjoint
+ , disjoint
+
+ -- ** Compose
+ , compose
+
+ -- ** Universal combining function
+ , mergeWithKey
+
+ -- * Traversal
+ -- ** Map
+ , map
+ , mapWithKey
+ , traverseWithKey
+ , traverseMaybeWithKey
+ , mapAccum
+ , mapAccumWithKey
+ , mapAccumRWithKey
+ , mapKeys
+ , mapKeysWith
+ , mapKeysMonotonic
+
+ -- * Folds
+ , foldr
+ , foldl
+ , foldrWithKey
+ , foldlWithKey
+ , foldMapWithKey
+
+ -- ** Strict folds
+ , foldr'
+ , foldl'
+ , foldrWithKey'
+ , foldlWithKey'
+
+ -- * Conversion
+ , elems
+ , keys
+ , assocs
+ , keysSet
+
+ -- ** Lists
+ , toList
+
+-- ** Ordered lists
+ , toAscList
+ , toDescList
+
+ -- * Filter
+ , filter
+ , filterWithKey
+ , restrictKeys
+ , withoutKeys
+ , partition
+ , partitionWithKey
+
+ , takeWhileAntitone
+ , dropWhileAntitone
+ , spanAntitone
+
+ , mapMaybe
+ , mapMaybeWithKey
+ , mapEither
+ , mapEitherWithKey
+
+ , split
+ , splitLookup
+ , splitRoot
+
+ -- * Submap
+ , isSubmapOf, isSubmapOfBy
+ , isProperSubmapOf, isProperSubmapOfBy
+
+ -- * Min\/Max
+ , lookupMin
+ , lookupMax
+ , findMin
+ , findMax
+ , deleteMin
+ , deleteMax
+ , deleteFindMin
+ , deleteFindMax
+ , updateMin
+ , updateMax
+ , updateMinWithKey
+ , updateMaxWithKey
+ , minView
+ , maxView
+ , minViewWithKey
+ , maxViewWithKey
+ ) where
+
+import GHC.Prelude.Basic hiding
+ (lookup, filter, foldr, foldl, foldl', null, map)
+
+import qualified GHC.Data.Word64Map.Internal as L
+import GHC.Data.Word64Map.Internal
+ ( Word64Map (..)
+ , Key
+ , mask
+ , branchMask
+ , nomatch
+ , zero
+ , natFromInt
+ , intFromNat
+ , bin
+ , binCheckLeft
+ , binCheckRight
+ , link
+ , linkWithMask
+
+ , (\\)
+ , (!)
+ , (!?)
+ , empty
+ , assocs
+ , filter
+ , filterWithKey
+ , findMin
+ , findMax
+ , foldMapWithKey
+ , foldr
+ , foldl
+ , foldr'
+ , foldl'
+ , foldlWithKey
+ , foldrWithKey
+ , foldlWithKey'
+ , foldrWithKey'
+ , keysSet
+ , mergeWithKey'
+ , compose
+ , delete
+ , deleteMin
+ , deleteMax
+ , deleteFindMax
+ , deleteFindMin
+ , difference
+ , elems
+ , intersection
+ , disjoint
+ , isProperSubmapOf
+ , isProperSubmapOfBy
+ , isSubmapOf
+ , isSubmapOfBy
+ , lookup
+ , lookupLE
+ , lookupGE
+ , lookupLT
+ , lookupGT
+ , lookupMin
+ , lookupMax
+ , minView
+ , maxView
+ , minViewWithKey
+ , maxViewWithKey
+ , keys
+ , mapKeys
+ , mapKeysMonotonic
+ , member
+ , notMember
+ , null
+ , partition
+ , partitionWithKey
+ , takeWhileAntitone
+ , dropWhileAntitone
+ , spanAntitone
+ , restrictKeys
+ , size
+ , split
+ , splitLookup
+ , splitRoot
+ , toAscList
+ , toDescList
+ , toList
+ , union
+ , unions
+ , withoutKeys
+ )
+import qualified GHC.Data.Word64Set.Internal as Word64Set
+import GHC.Utils.Containers.Internal.BitUtil
+import GHC.Utils.Containers.Internal.StrictPair
+import qualified Data.Foldable as Foldable
+
+{--------------------------------------------------------------------
+ Query
+--------------------------------------------------------------------}
+
+-- | \(O(\min(n,W))\). The expression @('findWithDefault' def k map)@
+-- returns the value at key @k@ or returns @def@ when the key is not an
+-- element of the map.
+--
+-- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'
+-- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'
+
+-- See Word64Map.Internal.Note: Local 'go' functions and capturing]
+findWithDefault :: a -> Key -> Word64Map a -> a
+findWithDefault def !k = go
+ where
+ go (Bin p m l r) | nomatch k p m = def
+ | zero k m = go l
+ | otherwise = go r
+ go (Tip kx x) | k == kx = x
+ | otherwise = def
+ go Nil = def
+
+{--------------------------------------------------------------------
+ Construction
+--------------------------------------------------------------------}
+-- | \(O(1)\). A map of one element.
+--
+-- > singleton 1 'a' == fromList [(1, 'a')]
+-- > size (singleton 1 'a') == 1
+
+singleton :: Key -> a -> Word64Map a
+singleton k !x
+ = Tip k x
+{-# INLINE singleton #-}
+
+{--------------------------------------------------------------------
+ Insert
+--------------------------------------------------------------------}
+-- | \(O(\min(n,W))\). Insert a new key\/value pair in the map.
+-- If the key is already present in the map, the associated value is
+-- replaced with the supplied value, i.e. 'insert' is equivalent to
+-- @'insertWith' 'const'@.
+--
+-- > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')]
+-- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')]
+-- > insert 5 'x' empty == singleton 5 'x'
+
+insert :: Key -> a -> Word64Map a -> Word64Map a
+insert !k !x t =
+ case t of
+ Bin p m l r
+ | nomatch k p m -> link k (Tip k x) p t
+ | zero k m -> Bin p m (insert k x l) r
+ | otherwise -> Bin p m l (insert k x r)
+ Tip ky _
+ | k==ky -> Tip k x
+ | otherwise -> link k (Tip k x) ky t
+ Nil -> Tip k x
+
+-- right-biased insertion, used by 'union'
+-- | \(O(\min(n,W))\). Insert with a combining function.
+-- @'insertWith' f key value mp@
+-- will insert the pair (key, value) into @mp@ if key does
+-- not exist in the map. If the key does exist, the function will
+-- insert @f new_value old_value@.
+--
+-- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")]
+-- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]
+-- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx"
+
+insertWith :: (a -> a -> a) -> Key -> a -> Word64Map a -> Word64Map a
+insertWith f k x t
+ = insertWithKey (\_ x' y' -> f x' y') k x t
+
+-- | \(O(\min(n,W))\). Insert with a combining function.
+-- @'insertWithKey' f key value mp@
+-- will insert the pair (key, value) into @mp@ if key does
+-- not exist in the map. If the key does exist, the function will
+-- insert @f key new_value old_value@.
+--
+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value
+-- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")]
+-- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]
+-- > insertWithKey f 5 "xxx" empty == singleton 5 "xxx"
+--
+-- If the key exists in the map, this function is lazy in @value@ but strict
+-- in the result of @f@.
+
+insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> Word64Map a -> Word64Map a
+insertWithKey f !k x t =
+ case t of
+ Bin p m l r
+ | nomatch k p m -> link k (singleton k x) p t
+ | zero k m -> Bin p m (insertWithKey f k x l) r
+ | otherwise -> Bin p m l (insertWithKey f k x r)
+ Tip ky y
+ | k==ky -> Tip k $! f k x y
+ | otherwise -> link k (singleton k x) ky t
+ Nil -> singleton k x
+
+-- | \(O(\min(n,W))\). The expression (@'insertLookupWithKey' f k x map@)
+-- is a pair where the first element is equal to (@'lookup' k map@)
+-- and the second element equal to (@'insertWithKey' f k x map@).
+--
+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value
+-- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")])
+-- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "xxx")])
+-- > insertLookupWithKey f 5 "xxx" empty == (Nothing, singleton 5 "xxx")
+--
+-- This is how to define @insertLookup@ using @insertLookupWithKey@:
+--
+-- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t
+-- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")])
+-- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "x")])
+
+insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> Word64Map a -> (Maybe a, Word64Map a)
+insertLookupWithKey f0 !k0 x0 t0 = toPair $ go f0 k0 x0 t0
+ where
+ go f k x t =
+ case t of
+ Bin p m l r
+ | nomatch k p m -> Nothing :*: link k (singleton k x) p t
+ | zero k m -> let (found :*: l') = go f k x l in (found :*: Bin p m l' r)
+ | otherwise -> let (found :*: r') = go f k x r in (found :*: Bin p m l r')
+ Tip ky y
+ | k==ky -> (Just y :*: (Tip k $! f k x y))
+ | otherwise -> (Nothing :*: link k (singleton k x) ky t)
+ Nil -> Nothing :*: (singleton k x)
+
+
+{--------------------------------------------------------------------
+ Deletion
+--------------------------------------------------------------------}
+-- | \(O(\min(n,W))\). Adjust a value at a specific key. When the key is not
+-- a member of the map, the original map is returned.
+--
+-- > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]
+-- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
+-- > adjust ("new " ++) 7 empty == empty
+
+adjust :: (a -> a) -> Key -> Word64Map a -> Word64Map a
+adjust f k m
+ = adjustWithKey (\_ x -> f x) k m
+
+-- | \(O(\min(n,W))\). Adjust a value at a specific key. When the key is not
+-- a member of the map, the original map is returned.
+--
+-- > let f key x = (show key) ++ ":new " ++ x
+-- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]
+-- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
+-- > adjustWithKey f 7 empty == empty
+
+adjustWithKey :: (Key -> a -> a) -> Key -> Word64Map a -> Word64Map a
+adjustWithKey f !k t =
+ case t of
+ Bin p m l r
+ | nomatch k p m -> t
+ | zero k m -> Bin p m (adjustWithKey f k l) r
+ | otherwise -> Bin p m l (adjustWithKey f k r)
+ Tip ky y
+ | k==ky -> Tip ky $! f k y
+ | otherwise -> t
+ Nil -> Nil
+
+-- | \(O(\min(n,W))\). The expression (@'update' f k map@) updates the value @x@
+-- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is
+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.
+--
+-- > let f x = if x == "a" then Just "new a" else Nothing
+-- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]
+-- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
+-- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
+
+update :: (a -> Maybe a) -> Key -> Word64Map a -> Word64Map a
+update f
+ = updateWithKey (\_ x -> f x)
+
+-- | \(O(\min(n,W))\). The expression (@'update' f k map@) updates the value @x@
+-- at @k@ (if it is in the map). If (@f k x@) is 'Nothing', the element is
+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.
+--
+-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing
+-- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]
+-- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
+-- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
+
+updateWithKey :: (Key -> a -> Maybe a) -> Key -> Word64Map a -> Word64Map a
+updateWithKey f !k t =
+ case t of
+ Bin p m l r
+ | nomatch k p m -> t
+ | zero k m -> binCheckLeft p m (updateWithKey f k l) r
+ | otherwise -> binCheckRight p m l (updateWithKey f k r)
+ Tip ky y
+ | k==ky -> case f k y of
+ Just !y' -> Tip ky y'
+ Nothing -> Nil
+ | otherwise -> t
+ Nil -> Nil
+
+-- | \(O(\min(n,W))\). Lookup and update.
+-- The function returns original value, if it is updated.
+-- This is different behavior than 'Data.Map.updateLookupWithKey'.
+-- Returns the original key value if the map entry is deleted.
+--
+-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing
+-- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:new a")])
+-- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a")])
+-- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a")
+
+updateLookupWithKey :: (Key -> a -> Maybe a) -> Key -> Word64Map a -> (Maybe a,Word64Map a)
+updateLookupWithKey f0 !k0 t0 = toPair $ go f0 k0 t0
+ where
+ go f k t =
+ case t of
+ Bin p m l r
+ | nomatch k p m -> (Nothing :*: t)
+ | zero k m -> let (found :*: l') = go f k l in (found :*: binCheckLeft p m l' r)
+ | otherwise -> let (found :*: r') = go f k r in (found :*: binCheckRight p m l r')
+ Tip ky y
+ | k==ky -> case f k y of
+ Just !y' -> (Just y :*: Tip ky y')
+ Nothing -> (Just y :*: Nil)
+ | otherwise -> (Nothing :*: t)
+ Nil -> (Nothing :*: Nil)
+
+
+
+-- | \(O(\min(n,W))\). The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.
+-- 'alter' can be used to insert, delete, or update a value in an 'Word64Map'.
+-- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.
+alter :: (Maybe a -> Maybe a) -> Key -> Word64Map a -> Word64Map a
+alter f !k t =
+ case t of
+ Bin p m l r
+ | nomatch k p m -> case f Nothing of
+ Nothing -> t
+ Just !x -> link k (Tip k x) p t
+ | zero k m -> binCheckLeft p m (alter f k l) r
+ | otherwise -> binCheckRight p m l (alter f k r)
+ Tip ky y
+ | k==ky -> case f (Just y) of
+ Just !x -> Tip ky x
+ Nothing -> Nil
+ | otherwise -> case f Nothing of
+ Just !x -> link k (Tip k x) ky t
+ Nothing -> t
+ Nil -> case f Nothing of
+ Just !x -> Tip k x
+ Nothing -> Nil
+
+-- | \(O(\log n)\). The expression (@'alterF' f k map@) alters the value @x@ at
+-- @k@, or absence thereof. 'alterF' can be used to inspect, insert, delete,
+-- or update a value in an 'Word64Map'. In short : @'lookup' k <$> 'alterF' f k m = f
+-- ('lookup' k m)@.
+--
+-- Example:
+--
+-- @
+-- interactiveAlter :: Int -> Word64Map String -> IO (Word64Map String)
+-- interactiveAlter k m = alterF f k m where
+-- f Nothing = do
+-- putStrLn $ show k ++
+-- " was not found in the map. Would you like to add it?"
+-- getUserResponse1 :: IO (Maybe String)
+-- f (Just old) = do
+-- putStrLn $ "The key is currently bound to " ++ show old ++
+-- ". Would you like to change or delete it?"
+-- getUserResponse2 :: IO (Maybe String)
+-- @
+--
+-- 'alterF' is the most general operation for working with an individual
+-- key that may or may not be in a given map.
+
+-- Note: 'alterF' is a flipped version of the 'at' combinator from
+-- 'Control.Lens.At'.
+--
+-- @since 0.5.8
+
+alterF :: Functor f
+ => (Maybe a -> f (Maybe a)) -> Key -> Word64Map a -> f (Word64Map a)
+-- This implementation was modified from 'Control.Lens.At'.
+alterF f k m = (<$> f mv) $ \fres ->
+ case fres of
+ Nothing -> maybe m (const (delete k m)) mv
+ Just !v' -> insert k v' m
+ where mv = lookup k m
+
+
+{--------------------------------------------------------------------
+ Union
+--------------------------------------------------------------------}
+-- | The union of a list of maps, with a combining operation.
+--
+-- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]
+-- > == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")]
+
+unionsWith :: Foldable f => (a->a->a) -> f (Word64Map a) -> Word64Map a
+unionsWith f ts
+ = Foldable.foldl' (unionWith f) empty ts
+
+-- | \(O(n+m)\). The union with a combining function.
+--
+-- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")]
+
+unionWith :: (a -> a -> a) -> Word64Map a -> Word64Map a -> Word64Map a
+unionWith f m1 m2
+ = unionWithKey (\_ x y -> f x y) m1 m2
+
+-- | \(O(n+m)\). The union with a combining function.
+--
+-- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value
+-- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]
+
+unionWithKey :: (Key -> a -> a -> a) -> Word64Map a -> Word64Map a -> Word64Map a
+unionWithKey f m1 m2
+ = mergeWithKey' Bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 $! f k1 x1 x2) id id m1 m2
+
+{--------------------------------------------------------------------
+ Difference
+--------------------------------------------------------------------}
+
+-- | \(O(n+m)\). Difference with a combining function.
+--
+-- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing
+-- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])
+-- > == singleton 3 "b:B"
+
+differenceWith :: (a -> b -> Maybe a) -> Word64Map a -> Word64Map b -> Word64Map a
+differenceWith f m1 m2
+ = differenceWithKey (\_ x y -> f x y) m1 m2
+
+-- | \(O(n+m)\). Difference with a combining function. When two equal keys are
+-- encountered, the combining function is applied to the key and both values.
+-- If it returns 'Nothing', the element is discarded (proper set difference).
+-- If it returns (@'Just' y@), the element is updated with a new value @y@.
+--
+-- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing
+-- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])
+-- > == singleton 3 "3:b|B"
+
+differenceWithKey :: (Key -> a -> b -> Maybe a) -> Word64Map a -> Word64Map b -> Word64Map a
+differenceWithKey f m1 m2
+ = mergeWithKey f id (const Nil) m1 m2
+
+{--------------------------------------------------------------------
+ Intersection
+--------------------------------------------------------------------}
+
+-- | \(O(n+m)\). The intersection with a combining function.
+--
+-- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"
+
+intersectionWith :: (a -> b -> c) -> Word64Map a -> Word64Map b -> Word64Map c
+intersectionWith f m1 m2
+ = intersectionWithKey (\_ x y -> f x y) m1 m2
+
+-- | \(O(n+m)\). The intersection with a combining function.
+--
+-- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar
+-- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"
+
+intersectionWithKey :: (Key -> a -> b -> c) -> Word64Map a -> Word64Map b -> Word64Map c
+intersectionWithKey f m1 m2
+ = mergeWithKey' bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 $! f k1 x1 x2) (const Nil) (const Nil) m1 m2
+
+{--------------------------------------------------------------------
+ MergeWithKey
+--------------------------------------------------------------------}
+
+-- | \(O(n+m)\). A high-performance universal combining function. Using
+-- 'mergeWithKey', all combining functions can be defined without any loss of
+-- efficiency (with exception of 'union', 'difference' and 'intersection',
+-- where sharing of some nodes is lost with 'mergeWithKey').
+--
+-- Please make sure you know what is going on when using 'mergeWithKey',
+-- otherwise you can be surprised by unexpected code growth or even
+-- corruption of the data structure.
+--
+-- When 'mergeWithKey' is given three arguments, it is inlined to the call
+-- site. You should therefore use 'mergeWithKey' only to define your custom
+-- combining functions. For example, you could define 'unionWithKey',
+-- 'differenceWithKey' and 'intersectionWithKey' as
+--
+-- > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2
+-- > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const empty) m1 m2
+-- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1 m2
+--
+-- When calling @'mergeWithKey' combine only1 only2@, a function combining two
+-- 'Word64Map's is created, such that
+--
+-- * if a key is present in both maps, it is passed with both corresponding
+-- values to the @combine@ function. Depending on the result, the key is either
+-- present in the result with specified value, or is left out;
+--
+-- * a nonempty subtree present only in the first map is passed to @only1@ and
+-- the output is added to the result;
+--
+-- * a nonempty subtree present only in the second map is passed to @only2@ and
+-- the output is added to the result.
+--
+-- The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given map/.
+-- The values can be modified arbitrarily. Most common variants of @only1@ and
+-- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@ or
+-- @'filterWithKey' f@ could be used for any @f@.
+
+mergeWithKey :: (Key -> a -> b -> Maybe c) -> (Word64Map a -> Word64Map c) -> (Word64Map b -> Word64Map c)
+ -> Word64Map a -> Word64Map b -> Word64Map c
+mergeWithKey f g1 g2 = mergeWithKey' bin combine g1 g2
+ where -- We use the lambda form to avoid non-exhaustive pattern matches warning.
+ combine = \(Tip k1 x1) (Tip _k2 x2) -> case f k1 x1 x2 of Nothing -> Nil
+ Just !x -> Tip k1 x
+ {-# INLINE combine #-}
+{-# INLINE mergeWithKey #-}
+
+{--------------------------------------------------------------------
+ Min\/Max
+--------------------------------------------------------------------}
+
+-- | \(O(\log n)\). Update the value at the minimal key.
+--
+-- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")]
+-- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
+
+updateMinWithKey :: (Key -> a -> Maybe a) -> Word64Map a -> Word64Map a
+updateMinWithKey f t =
+ case t of Bin p m l r | m < 0 -> binCheckRight p m l (go f r)
+ _ -> go f t
+ where
+ go f' (Bin p m l r) = binCheckLeft p m (go f' l) r
+ go f' (Tip k y) = case f' k y of
+ Just !y' -> Tip k y'
+ Nothing -> Nil
+ go _ Nil = error "updateMinWithKey Nil"
+
+-- | \(O(\log n)\). Update the value at the maximal key.
+--
+-- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")]
+-- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
+
+updateMaxWithKey :: (Key -> a -> Maybe a) -> Word64Map a -> Word64Map a
+updateMaxWithKey f t =
+ case t of Bin p m l r | m < 0 -> binCheckLeft p m (go f l) r
+ _ -> go f t
+ where
+ go f' (Bin p m l r) = binCheckRight p m l (go f' r)
+ go f' (Tip k y) = case f' k y of
+ Just !y' -> Tip k y'
+ Nothing -> Nil
+ go _ Nil = error "updateMaxWithKey Nil"
+
+-- | \(O(\log n)\). Update the value at the maximal key.
+--
+-- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")]
+-- > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
+
+updateMax :: (a -> Maybe a) -> Word64Map a -> Word64Map a
+updateMax f = updateMaxWithKey (const f)
+
+-- | \(O(\log n)\). Update the value at the minimal key.
+--
+-- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")]
+-- > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
+
+updateMin :: (a -> Maybe a) -> Word64Map a -> Word64Map a
+updateMin f = updateMinWithKey (const f)
+
+
+{--------------------------------------------------------------------
+ Mapping
+--------------------------------------------------------------------}
+-- | \(O(n)\). Map a function over all values in the map.
+--
+-- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")]
+
+map :: (a -> b) -> Word64Map a -> Word64Map b
+map f = go
+ where
+ go (Bin p m l r) = Bin p m (go l) (go r)
+ go (Tip k x) = Tip k $! f x
+ go Nil = Nil
+
+#ifdef __GLASGOW_HASKELL__
+{-# NOINLINE [1] map #-}
+{-# RULES
+"map/map" forall f g xs . map f (map g xs) = map (\x -> f $! g x) xs
+"map/mapL" forall f g xs . map f (L.map g xs) = map (\x -> f (g x)) xs
+ #-}
+#endif
+
+-- | \(O(n)\). Map a function over all values in the map.
+--
+-- > let f key x = (show key) ++ ":" ++ x
+-- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")]
+
+mapWithKey :: (Key -> a -> b) -> Word64Map a -> Word64Map b
+mapWithKey f t
+ = case t of
+ Bin p m l r -> Bin p m (mapWithKey f l) (mapWithKey f r)
+ Tip k x -> Tip k $! f k x
+ Nil -> Nil
+
+#ifdef __GLASGOW_HASKELL__
+-- Pay close attention to strictness here. We need to force the
+-- intermediate result for map f . map g, and we need to refrain
+-- from forcing it for map f . L.map g, etc.
+--
+-- TODO Consider moving map and mapWithKey to Word64Map.Internal so we can write
+-- non-orphan RULES for things like L.map f (map g xs). We'd need a new function
+-- for this, and we'd have to pay attention to simplifier phases. Something like
+--
+-- lsmap :: (b -> c) -> (a -> b) -> Word64Map a -> Word64Map c
+-- lsmap _ _ Nil = Nil
+-- lsmap f g (Tip k x) = let !gx = g x in Tip k (f gx)
+-- lsmap f g (Bin p m l r) = Bin p m (lsmap f g l) (lsmap f g r)
+{-# NOINLINE [1] mapWithKey #-}
+{-# RULES
+"mapWithKey/mapWithKey" forall f g xs . mapWithKey f (mapWithKey g xs) =
+ mapWithKey (\k a -> f k $! g k a) xs
+"mapWithKey/mapWithKeyL" forall f g xs . mapWithKey f (L.mapWithKey g xs) =
+ mapWithKey (\k a -> f k (g k a)) xs
+"mapWithKey/map" forall f g xs . mapWithKey f (map g xs) =
+ mapWithKey (\k a -> f k $! g a) xs
+"mapWithKey/mapL" forall f g xs . mapWithKey f (L.map g xs) =
+ mapWithKey (\k a -> f k (g a)) xs
+"map/mapWithKey" forall f g xs . map f (mapWithKey g xs) =
+ mapWithKey (\k a -> f $! g k a) xs
+"map/mapWithKeyL" forall f g xs . map f (L.mapWithKey g xs) =
+ mapWithKey (\k a -> f (g k a)) xs
+ #-}
+#endif
+
+-- | \(O(n)\).
+-- @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@
+-- That is, behaves exactly like a regular 'traverse' except that the traversing
+-- function also has access to the key associated with a value.
+--
+-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')])
+-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')]) == Nothing
+traverseWithKey :: Applicative t => (Key -> a -> t b) -> Word64Map a -> t (Word64Map b)
+traverseWithKey f = go
+ where
+ go Nil = pure Nil
+ go (Tip k v) = (\ !v' -> Tip k v') <$> f k v
+ go (Bin p m l r)
+ | m < 0 = liftA2 (flip (Bin p m)) (go r) (go l)
+ | otherwise = liftA2 (Bin p m) (go l) (go r)
+{-# INLINE traverseWithKey #-}
+
+-- | \(O(n)\). Traverse keys\/values and collect the 'Just' results.
+--
+-- @since 0.6.4
+traverseMaybeWithKey
+ :: Applicative f => (Key -> a -> f (Maybe b)) -> Word64Map a -> f (Word64Map b)
+traverseMaybeWithKey f = go
+ where
+ go Nil = pure Nil
+ go (Tip k x) = maybe Nil (Tip k $!) <$> f k x
+ go (Bin p m l r)
+ | m < 0 = liftA2 (flip (bin p m)) (go r) (go l)
+ | otherwise = liftA2 (bin p m) (go l) (go r)
+
+-- | \(O(n)\). The function @'mapAccum'@ threads an accumulating
+-- argument through the map in ascending order of keys.
+--
+-- > let f a b = (a ++ b, b ++ "X")
+-- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")])
+
+mapAccum :: (a -> b -> (a,c)) -> a -> Word64Map b -> (a,Word64Map c)
+mapAccum f = mapAccumWithKey (\a' _ x -> f a' x)
+
+-- | \(O(n)\). The function @'mapAccumWithKey'@ threads an accumulating
+-- argument through the map in ascending order of keys.
+--
+-- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")
+-- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])
+
+mapAccumWithKey :: (a -> Key -> b -> (a,c)) -> a -> Word64Map b -> (a,Word64Map c)
+mapAccumWithKey f a t
+ = mapAccumL f a t
+
+-- | \(O(n)\). The function @'mapAccumL'@ threads an accumulating
+-- argument through the map in ascending order of keys. Strict in
+-- the accumulating argument and the both elements of the
+-- result of the function.
+mapAccumL :: (a -> Key -> b -> (a,c)) -> a -> Word64Map b -> (a,Word64Map c)
+mapAccumL f0 a0 t0 = toPair $ go f0 a0 t0
+ where
+ go f a t
+ = case t of
+ Bin p m l r
+ | m < 0 ->
+ let (a1 :*: r') = go f a r
+ (a2 :*: l') = go f a1 l
+ in (a2 :*: Bin p m l' r')
+ | otherwise ->
+ let (a1 :*: l') = go f a l
+ (a2 :*: r') = go f a1 r
+ in (a2 :*: Bin p m l' r')
+ Tip k x -> let !(a',!x') = f a k x in (a' :*: Tip k x')
+ Nil -> (a :*: Nil)
+
+-- | \(O(n)\). The function @'mapAccumRWithKey'@ threads an accumulating
+-- argument through the map in descending order of keys.
+mapAccumRWithKey :: (a -> Key -> b -> (a,c)) -> a -> Word64Map b -> (a,Word64Map c)
+mapAccumRWithKey f0 a0 t0 = toPair $ go f0 a0 t0
+ where
+ go f a t
+ = case t of
+ Bin p m l r
+ | m < 0 ->
+ let (a1 :*: l') = go f a l
+ (a2 :*: r') = go f a1 r
+ in (a2 :*: Bin p m l' r')
+ | otherwise ->
+ let (a1 :*: r') = go f a r
+ (a2 :*: l') = go f a1 l
+ in (a2 :*: Bin p m l' r')
+ Tip k x -> let !(a',!x') = f a k x in (a' :*: Tip k x')
+ Nil -> (a :*: Nil)
+
+-- | \(O(n \log n)\).
+-- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.
+--
+-- The size of the result may be smaller if @f@ maps two or more distinct
+-- keys to the same new key. In this case the associated values will be
+-- combined using @c@.
+--
+-- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab"
+-- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab"
+
+mapKeysWith :: (a -> a -> a) -> (Key->Key) -> Word64Map a -> Word64Map a
+mapKeysWith c f = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) []
+
+{--------------------------------------------------------------------
+ Filter
+--------------------------------------------------------------------}
+-- | \(O(n)\). Map values and collect the 'Just' results.
+--
+-- > let f x = if x == "a" then Just "new a" else Nothing
+-- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a"
+
+mapMaybe :: (a -> Maybe b) -> Word64Map a -> Word64Map b
+mapMaybe f = mapMaybeWithKey (\_ x -> f x)
+
+-- | \(O(n)\). Map keys\/values and collect the 'Just' results.
+--
+-- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing
+-- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3"
+
+mapMaybeWithKey :: (Key -> a -> Maybe b) -> Word64Map a -> Word64Map b
+mapMaybeWithKey f (Bin p m l r)
+ = bin p m (mapMaybeWithKey f l) (mapMaybeWithKey f r)
+mapMaybeWithKey f (Tip k x) = case f k x of
+ Just !y -> Tip k y
+ Nothing -> Nil
+mapMaybeWithKey _ Nil = Nil
+
+-- | \(O(n)\). Map values and separate the 'Left' and 'Right' results.
+--
+-- > let f a = if a < "c" then Left a else Right a
+-- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
+-- > == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")])
+-- >
+-- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
+-- > == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
+
+mapEither :: (a -> Either b c) -> Word64Map a -> (Word64Map b, Word64Map c)
+mapEither f m
+ = mapEitherWithKey (\_ x -> f x) m
+
+-- | \(O(n)\). Map keys\/values and separate the 'Left' and 'Right' results.
+--
+-- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a)
+-- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
+-- > == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")])
+-- >
+-- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
+-- > == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])
+
+mapEitherWithKey :: (Key -> a -> Either b c) -> Word64Map a -> (Word64Map b, Word64Map c)
+mapEitherWithKey f0 t0 = toPair $ go f0 t0
+ where
+ go f (Bin p m l r)
+ = bin p m l1 r1 :*: bin p m l2 r2
+ where
+ (l1 :*: l2) = go f l
+ (r1 :*: r2) = go f r
+ go f (Tip k x) = case f k x of
+ Left !y -> (Tip k y :*: Nil)
+ Right !z -> (Nil :*: Tip k z)
+ go _ Nil = (Nil :*: Nil)
+
+{--------------------------------------------------------------------
+ Conversions
+--------------------------------------------------------------------}
+
+-- | \(O(n)\). Build a map from a set of keys and a function which for each key
+-- computes its value.
+--
+-- > fromSet (\k -> replicate k 'a') (Data.Word64Set.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")]
+-- > fromSet undefined Data.Word64Set.empty == empty
+
+fromSet :: (Key -> a) -> Word64Set.Word64Set -> Word64Map a
+fromSet _ Word64Set.Nil = Nil
+fromSet f (Word64Set.Bin p m l r) = Bin p m (fromSet f l) (fromSet f r)
+fromSet f (Word64Set.Tip kx bm) = buildTree f kx bm (Word64Set.suffixBitMask + 1)
+ where -- This is slightly complicated, as we to convert the dense
+ -- representation of Word64Set into tree representation of Word64Map.
+ --
+ -- We are given a nonzero bit mask 'bmask' of 'bits' bits with prefix 'prefix'.
+ -- We split bmask into halves corresponding to left and right subtree.
+ -- If they are both nonempty, we create a Bin node, otherwise exactly
+ -- one of them is nonempty and we construct the Word64Map from that half.
+ buildTree g !prefix !bmask bits = case bits of
+ 0 -> Tip prefix $! g prefix
+ _ -> case intFromNat ((natFromInt bits) `shiftRL` 1) of
+ bits2 | bmask .&. ((1 `shiftLL` fromIntegral bits2) - 1) == 0 ->
+ buildTree g (prefix + bits2) (bmask `shiftRL` fromIntegral bits2) bits2
+ | (bmask `shiftRL` fromIntegral bits2) .&. ((1 `shiftLL` fromIntegral bits2) - 1) == 0 ->
+ buildTree g prefix bmask bits2
+ | otherwise ->
+ Bin prefix bits2 (buildTree g prefix bmask bits2) (buildTree g (prefix + bits2) (bmask `shiftRL` fromIntegral bits2) bits2)
+
+{--------------------------------------------------------------------
+ Lists
+--------------------------------------------------------------------}
+-- | \(O(n \min(n,W))\). Create a map from a list of key\/value pairs.
+--
+-- > fromList [] == empty
+-- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]
+-- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")]
+
+fromList :: [(Key,a)] -> Word64Map a
+fromList xs
+ = Foldable.foldl' ins empty xs
+ where
+ ins t (k,x) = insert k x t
+
+-- | \(O(n \min(n,W))\). Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.
+--
+-- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")]
+-- > fromListWith (++) [] == empty
+
+fromListWith :: (a -> a -> a) -> [(Key,a)] -> Word64Map a
+fromListWith f xs
+ = fromListWithKey (\_ x y -> f x y) xs
+
+-- | \(O(n \min(n,W))\). Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'.
+--
+-- > let f key new_value old_value = show key ++ ":" ++ new_value ++ "|" ++ old_value
+-- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "3:a|b"), (5, "5:c|5:b|a")]
+-- > fromListWithKey f [] == empty
+
+fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> Word64Map a
+fromListWithKey f xs
+ = Foldable.foldl' ins empty xs
+ where
+ ins t (k,x) = insertWithKey f k x t
+
+-- | \(O(n)\). Build a map from a list of key\/value pairs where
+-- the keys are in ascending order.
+--
+-- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]
+-- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]
+
+fromAscList :: [(Key,a)] -> Word64Map a
+fromAscList = fromMonoListWithKey Nondistinct (\_ x _ -> x)
+{-# NOINLINE fromAscList #-}
+
+-- | \(O(n)\). Build a map from a list of key\/value pairs where
+-- the keys are in ascending order, with a combining function on equal keys.
+-- /The precondition (input list is ascending) is not checked./
+--
+-- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]
+
+fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> Word64Map a
+fromAscListWith f = fromMonoListWithKey Nondistinct (\_ x y -> f x y)
+{-# NOINLINE fromAscListWith #-}
+
+-- | \(O(n)\). Build a map from a list of key\/value pairs where
+-- the keys are in ascending order, with a combining function on equal keys.
+-- /The precondition (input list is ascending) is not checked./
+--
+-- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]
+
+fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> Word64Map a
+fromAscListWithKey f = fromMonoListWithKey Nondistinct f
+{-# NOINLINE fromAscListWithKey #-}
+
+-- | \(O(n)\). Build a map from a list of key\/value pairs where
+-- the keys are in ascending order and all distinct.
+-- /The precondition (input list is strictly ascending) is not checked./
+--
+-- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]
+
+fromDistinctAscList :: [(Key,a)] -> Word64Map a
+fromDistinctAscList = fromMonoListWithKey Distinct (\_ x _ -> x)
+{-# NOINLINE fromDistinctAscList #-}
+
+-- | \(O(n)\). Build a map from a list of key\/value pairs with monotonic keys
+-- and a combining function.
+--
+-- The precise conditions under which this function works are subtle:
+-- For any branch mask, keys with the same prefix w.r.t. the branch
+-- mask must occur consecutively in the list.
+
+fromMonoListWithKey :: Distinct -> (Key -> a -> a -> a) -> [(Key,a)] -> Word64Map a
+fromMonoListWithKey distinct f = go
+ where
+ go [] = Nil
+ go ((kx,vx) : zs1) = addAll' kx vx zs1
+
+ -- `addAll'` collects all keys equal to `kx` into a single value,
+ -- and then proceeds with `addAll`.
+ addAll' !kx vx []
+ = Tip kx $! vx
+ addAll' !kx vx ((ky,vy) : zs)
+ | Nondistinct <- distinct, kx == ky
+ = let !v = f kx vy vx in addAll' ky v zs
+ -- inlined: | otherwise = addAll kx (Tip kx $! vx) (ky : zs)
+ | m <- branchMask kx ky
+ , Inserted ty zs' <- addMany' m ky vy zs
+ = addAll kx (linkWithMask m ky ty {-kx-} (Tip kx $! vx)) zs'
+
+ -- for `addAll` and `addMany`, kx is /a/ key inside the tree `tx`
+ -- `addAll` consumes the rest of the list, adding to the tree `tx`
+ addAll !_kx !tx []
+ = tx
+ addAll !kx !tx ((ky,vy) : zs)
+ | m <- branchMask kx ky
+ , Inserted ty zs' <- addMany' m ky vy zs
+ = addAll kx (linkWithMask m ky ty {-kx-} tx) zs'
+
+ -- `addMany'` is similar to `addAll'`, but proceeds with `addMany'`.
+ addMany' !_m !kx vx []
+ = Inserted (Tip kx $! vx) []
+ addMany' !m !kx vx zs0@((ky,vy) : zs)
+ | Nondistinct <- distinct, kx == ky
+ = let !v = f kx vy vx in addMany' m ky v zs
+ -- inlined: | otherwise = addMany m kx (Tip kx $! vx) (ky : zs)
+ | mask kx m /= mask ky m
+ = Inserted (Tip kx $! vx) zs0
+ | mxy <- branchMask kx ky
+ , Inserted ty zs' <- addMany' mxy ky vy zs
+ = addMany m kx (linkWithMask mxy ky ty {-kx-} (Tip kx $! vx)) zs'
+
+ -- `addAll` adds to `tx` all keys whose prefix w.r.t. `m` agrees with `kx`.
+ addMany !_m !_kx tx []
+ = Inserted tx []
+ addMany !m !kx tx zs0@((ky,vy) : zs)
+ | mask kx m /= mask ky m
+ = Inserted tx zs0
+ | mxy <- branchMask kx ky
+ , Inserted ty zs' <- addMany' mxy ky vy zs
+ = addMany m kx (linkWithMask mxy ky ty {-kx-} tx) zs'
+{-# INLINE fromMonoListWithKey #-}
+
+data Inserted a = Inserted !(Word64Map a) ![(Key,a)]
+
+data Distinct = Distinct | Nondistinct
diff --git a/compiler/GHC/Data/Word64Set.hs b/compiler/GHC/Data/Word64Set.hs
new file mode 100644
index 0000000000000000000000000000000000000000..81cfcbd4efbab00fc203a5da905c0c0ccd9abb11
--- /dev/null
+++ b/compiler/GHC/Data/Word64Set.hs
@@ -0,0 +1,174 @@
+{-# LANGUAGE CPP #-}
+#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)
+{-# LANGUAGE Safe #-}
+#endif
+
+#include "containers.h"
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Data.Word64Set
+-- Copyright : (c) Daan Leijen 2002
+-- (c) Joachim Breitner 2011
+-- License : BSD-style
+-- Maintainer : libraries@haskell.org
+-- Portability : portable
+--
+--
+-- = Finite Int Sets
+--
+-- The @'Word64Set'@ type represents a set of elements of type @Int@.
+--
+-- For a walkthrough of the most commonly used functions see their
+-- <https://haskell-containers.readthedocs.io/en/latest/set.html sets introduction>.
+--
+-- These modules are intended to be imported qualified, to avoid name
+-- clashes with Prelude functions, e.g.
+--
+-- > import Data.Word64Set (Word64Set)
+-- > import qualified Data.Word64Set as Word64Set
+--
+--
+-- == Performance information
+--
+-- Many operations have a worst-case complexity of \(O(\min(n,W))\).
+-- This means that the operation can become linear in the number of
+-- elements with a maximum of \(W\) -- the number of bits in an 'Int'
+-- (32 or 64).
+--
+--
+-- == Implementation
+--
+-- The implementation is based on /big-endian patricia trees/. This data
+-- structure performs especially well on binary operations like 'union'
+-- and 'intersection'. However, my benchmarks show that it is also
+-- (much) faster on insertions and deletions when compared to a generic
+-- size-balanced set implementation (see "Data.Set").
+--
+-- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\",
+-- Workshop on ML, September 1998, pages 77-86,
+-- <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.37.5452>
+--
+-- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",
+-- Journal of the ACM, 15(4), October 1968, pages 514-534.
+--
+-- Additionally, this implementation places bitmaps in the leaves of the tree.
+-- Their size is the natural size of a machine word (32 or 64 bits) and greatly
+-- reduces the memory footprint and execution times for dense sets, e.g. sets
+-- where it is likely that many values lie close to each other. The asymptotics
+-- are not affected by this optimization.
+--
+-----------------------------------------------------------------------------
+
+module GHC.Data.Word64Set (
+ -- * Strictness properties
+ -- $strictness
+
+ -- * Set type
+#if !defined(TESTING)
+ Word64Set -- instance Eq,Show
+#else
+ Word64Set(..) -- instance Eq,Show
+#endif
+ , Key
+
+ -- * Construction
+ , empty
+ , singleton
+ , fromList
+ , fromAscList
+ , fromDistinctAscList
+
+ -- * Insertion
+ , insert
+
+ -- * Deletion
+ , delete
+
+ -- * Generalized insertion/deletion
+ , alterF
+
+ -- * Query
+ , member
+ , notMember
+ , lookupLT
+ , lookupGT
+ , lookupLE
+ , lookupGE
+ , WS.null
+ , size
+ , isSubsetOf
+ , isProperSubsetOf
+ , disjoint
+
+ -- * Combine
+ , union
+ , unions
+ , difference
+ , (\\)
+ , intersection
+
+ -- * Filter
+ , WS.filter
+ , partition
+
+ , takeWhileAntitone
+ , dropWhileAntitone
+ , spanAntitone
+
+ , split
+ , splitMember
+ , splitRoot
+
+ -- * Map
+ , WS.map
+ , mapMonotonic
+
+ -- * Folds
+ , WS.foldr
+ , WS.foldl
+ -- ** Strict folds
+ , foldr'
+ , foldl'
+ -- ** Legacy folds
+ , fold
+
+ -- * Min\/Max
+ , findMin
+ , findMax
+ , deleteMin
+ , deleteMax
+ , deleteFindMin
+ , deleteFindMax
+ , maxView
+ , minView
+
+ -- * Conversion
+
+ -- ** List
+ , elems
+ , toList
+ , toAscList
+ , toDescList
+
+ -- * Debugging
+ , showTree
+ , showTreeWith
+
+#if defined(TESTING)
+ -- * Internals
+ , match
+#endif
+ ) where
+
+import GHC.Data.Word64Set.Internal as WS
+
+-- $strictness
+--
+-- This module satisfies the following strictness property:
+--
+-- * Key arguments are evaluated to WHNF
+--
+-- Here are some examples that illustrate the property:
+--
+-- > delete undefined s == undefined
diff --git a/compiler/GHC/Data/Word64Set/Internal.hs b/compiler/GHC/Data/Word64Set/Internal.hs
new file mode 100644
index 0000000000000000000000000000000000000000..b2df095adfb1f363ed0fdfebc1516c5b699b8106
--- /dev/null
+++ b/compiler/GHC/Data/Word64Set/Internal.hs
@@ -0,0 +1,1704 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE PatternGuards #-}
+#ifdef __GLASGOW_HASKELL__
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+#endif
+#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)
+{-# LANGUAGE Trustworthy #-}
+#endif
+
+{-# OPTIONS_HADDOCK not-home #-}
+
+#include "containers.h"
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Data.Word64Set.Internal
+-- Copyright : (c) Daan Leijen 2002
+-- (c) Joachim Breitner 2011
+-- License : BSD-style
+-- Maintainer : libraries@haskell.org
+-- Portability : portable
+--
+-- = WARNING
+--
+-- This module is considered __internal__.
+--
+-- The Package Versioning Policy __does not apply__.
+--
+-- The contents of this module may change __in any way whatsoever__
+-- and __without any warning__ between minor versions of this package.
+--
+-- Authors importing this module are expected to track development
+-- closely.
+--
+-- = Description
+--
+-- An efficient implementation of integer sets.
+--
+-- These modules are intended to be imported qualified, to avoid name
+-- clashes with Prelude functions, e.g.
+--
+-- > import Data.Word64Set (Word64Set)
+-- > import qualified Data.Word64Set as Word64Set
+--
+-- The implementation is based on /big-endian patricia trees/. This data
+-- structure performs especially well on binary operations like 'union'
+-- and 'intersection'. However, my benchmarks show that it is also
+-- (much) faster on insertions and deletions when compared to a generic
+-- size-balanced set implementation (see "Data.Set").
+--
+-- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\",
+-- Workshop on ML, September 1998, pages 77-86,
+-- <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.37.5452>
+--
+-- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",
+-- Journal of the ACM, 15(4), October 1968, pages 514-534.
+--
+-- Additionally, this implementation places bitmaps in the leaves of the tree.
+-- Their size is the natural size of a machine word (32 or 64 bits) and greatly
+-- reduce memory footprint and execution times for dense sets, e.g. sets where
+-- it is likely that many values lie close to each other. The asymptotics are
+-- not affected by this optimization.
+--
+-- Many operations have a worst-case complexity of \(O(\min(n,W))\).
+-- This means that the operation can become linear in the number of
+-- elements with a maximum of \(W\) -- the number of bits in an 'Int'
+-- (32 or 64).
+--
+-- @since 0.5.9
+-----------------------------------------------------------------------------
+
+-- [Note: INLINE bit fiddling]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- It is essential that the bit fiddling functions like mask, zero, branchMask
+-- etc are inlined. If they do not, the memory allocation skyrockets. The GHC
+-- usually gets it right, but it is disastrous if it does not. Therefore we
+-- explicitly mark these functions INLINE.
+
+
+-- [Note: Local 'go' functions and capturing]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Care must be taken when using 'go' function which captures an argument.
+-- Sometimes (for example when the argument is passed to a data constructor,
+-- as in insert), GHC heap-allocates more than necessary. Therefore C-- code
+-- must be checked for increased allocation when creating and modifying such
+-- functions.
+
+
+-- [Note: Order of constructors]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- The order of constructors of Word64Set matters when considering performance.
+-- Currently in GHC 7.0, when type has 3 constructors, they are matched from
+-- the first to the last -- the best performance is achieved when the
+-- constructors are ordered by frequency.
+-- On GHC 7.0, reordering constructors from Nil | Tip | Bin to Bin | Tip | Nil
+-- improves the benchmark by circa 10%.
+
+module GHC.Data.Word64Set.Internal (
+ -- * Set type
+ Word64Set(..), Key -- instance Eq,Show
+ , Prefix, Mask, BitMap
+
+ -- * Operators
+ , (\\)
+
+ -- * Query
+ , null
+ , size
+ , member
+ , notMember
+ , lookupLT
+ , lookupGT
+ , lookupLE
+ , lookupGE
+ , isSubsetOf
+ , isProperSubsetOf
+ , disjoint
+
+ -- * Construction
+ , empty
+ , singleton
+ , insert
+ , delete
+ , alterF
+
+ -- * Combine
+ , union
+ , unions
+ , difference
+ , intersection
+
+ -- * Filter
+ , filter
+ , partition
+
+ , takeWhileAntitone
+ , dropWhileAntitone
+ , spanAntitone
+
+ , split
+ , splitMember
+ , splitRoot
+
+ -- * Map
+ , map
+ , mapMonotonic
+
+ -- * Folds
+ , foldr
+ , foldl
+ -- ** Strict folds
+ , foldr'
+ , foldl'
+ -- ** Legacy folds
+ , fold
+
+ -- * Min\/Max
+ , findMin
+ , findMax
+ , deleteMin
+ , deleteMax
+ , deleteFindMin
+ , deleteFindMax
+ , maxView
+ , minView
+
+ -- * Conversion
+
+ -- ** List
+ , elems
+ , toList
+ , fromList
+
+ -- ** Ordered list
+ , toAscList
+ , toDescList
+ , fromAscList
+ , fromDistinctAscList
+
+ -- * Debugging
+ , showTree
+ , showTreeWith
+
+ -- * Internals
+ , match
+ , suffixBitMask
+ , prefixBitMask
+ , bitmapOf
+ , zero
+ ) where
+
+import Control.Applicative (Const(..))
+import Control.DeepSeq (NFData(rnf))
+import Data.Bits
+import qualified Data.List as List
+import Data.Maybe (fromMaybe)
+import Data.Semigroup (Semigroup(stimes, (<>)), stimesIdempotentMonoid)
+import GHC.Prelude.Basic hiding
+ (filter, foldr, foldl, foldl', null, map)
+import Data.Word ( Word64 )
+
+import GHC.Utils.Containers.Internal.BitUtil
+import GHC.Utils.Containers.Internal.StrictPair
+
+#if __GLASGOW_HASKELL__
+import Data.Data (Data(..), Constr, mkConstr, constrIndex, DataType, mkDataType)
+import qualified Data.Data
+import Text.Read
+#endif
+
+#if __GLASGOW_HASKELL__
+import qualified GHC.Exts
+#endif
+
+import qualified Data.Foldable as Foldable
+import Data.Functor.Identity (Identity(..))
+
+infixl 9 \\{-This comment teaches CPP correct behaviour -}
+
+-- A "Nat" is a 64 bit machine word
+type Nat = Word64
+
+natFromInt :: Word64 -> Nat
+natFromInt = id
+{-# INLINE natFromInt #-}
+
+intFromNat :: Nat -> Word64
+intFromNat = id
+{-# INLINE intFromNat #-}
+
+{--------------------------------------------------------------------
+ Operators
+--------------------------------------------------------------------}
+-- | \(O(n+m)\). See 'difference'.
+(\\) :: Word64Set -> Word64Set -> Word64Set
+m1 \\ m2 = difference m1 m2
+
+{--------------------------------------------------------------------
+ Types
+--------------------------------------------------------------------}
+
+-- | A set of integers.
+
+-- See Note: Order of constructors
+data Word64Set = Bin {-# UNPACK #-} !Prefix {-# UNPACK #-} !Mask !Word64Set !Word64Set
+-- Invariant: Nil is never found as a child of Bin.
+-- Invariant: The Mask is a power of 2. It is the largest bit position at which
+-- two elements of the set differ.
+-- Invariant: Prefix is the common high-order bits that all elements share to
+-- the left of the Mask bit.
+-- Invariant: In Bin prefix mask left right, left consists of the elements that
+-- don't have the mask bit set; right is all the elements that do.
+ | Tip {-# UNPACK #-} !Prefix {-# UNPACK #-} !BitMap
+-- Invariant: The Prefix is zero for the last 6 bits. The values of the set
+-- represented by a tip are the prefix plus the indices of the set
+-- bits in the bit map.
+ | Nil
+
+-- A number stored in a set is stored as
+-- * Prefix (all but last 6 bits) and
+-- * BitMap (last 6 bits stored as a bitmask)
+-- Last 6 bits are called a Suffix.
+
+type Prefix = Word64
+type Mask = Word64
+type BitMap = Word64
+type Key = Word64
+
+instance Monoid Word64Set where
+ mempty = empty
+ mconcat = unions
+ mappend = (<>)
+
+-- | @since 0.5.7
+instance Semigroup Word64Set where
+ (<>) = union
+ stimes = stimesIdempotentMonoid
+
+#if __GLASGOW_HASKELL__
+
+{--------------------------------------------------------------------
+ A Data instance
+--------------------------------------------------------------------}
+
+-- This instance preserves data abstraction at the cost of inefficiency.
+-- We provide limited reflection services for the sake of data abstraction.
+
+instance Data Word64Set where
+ gfoldl f z is = z fromList `f` (toList is)
+ toConstr _ = fromListConstr
+ gunfold k z c = case constrIndex c of
+ 1 -> k (z fromList)
+ _ -> error "gunfold"
+ dataTypeOf _ = intSetDataType
+
+fromListConstr :: Constr
+fromListConstr = mkConstr intSetDataType "fromList" [] Data.Data.Prefix
+
+intSetDataType :: DataType
+intSetDataType = mkDataType "Data.Word64Set.Internal.Word64Set" [fromListConstr]
+
+#endif
+
+{--------------------------------------------------------------------
+ Query
+--------------------------------------------------------------------}
+-- | \(O(1)\). Is the set empty?
+null :: Word64Set -> Bool
+null Nil = True
+null _ = False
+{-# INLINE null #-}
+
+-- | \(O(n)\). Cardinality of the set.
+size :: Word64Set -> Int
+size = go 0
+ where
+ go !acc (Bin _ _ l r) = go (go acc l) r
+ go acc (Tip _ bm) = acc + bitcount 0 bm
+ go acc Nil = acc
+
+-- | \(O(\min(n,W))\). Is the value a member of the set?
+
+-- See Note: Local 'go' functions and capturing.
+member :: Key -> Word64Set -> Bool
+member !x = go
+ where
+ go (Bin p m l r)
+ | nomatch x p m = False
+ | zero x m = go l
+ | otherwise = go r
+ go (Tip y bm) = prefixOf x == y && bitmapOf x .&. bm /= 0
+ go Nil = False
+
+-- | \(O(\min(n,W))\). Is the element not in the set?
+notMember :: Key -> Word64Set -> Bool
+notMember k = not . member k
+
+-- | \(O(\min(n,W))\). Find largest element smaller than the given one.
+--
+-- > lookupLT 3 (fromList [3, 5]) == Nothing
+-- > lookupLT 5 (fromList [3, 5]) == Just 3
+
+-- See Note: Local 'go' functions and capturing.
+lookupLT :: Key -> Word64Set -> Maybe Key
+lookupLT !x t = case t of
+ Bin _ m l r | m < 0 -> if x >= 0 then go r l else go Nil r
+ _ -> go Nil t
+ where
+ go def (Bin p m l r) | nomatch x p m = if x < p then unsafeFindMax def else unsafeFindMax r
+ | zero x m = go def l
+ | otherwise = go l r
+ go def (Tip kx bm) | prefixOf x > kx = Just $ kx + highestBitSet bm
+ | prefixOf x == kx && maskLT /= 0 = Just $ kx + highestBitSet maskLT
+ | otherwise = unsafeFindMax def
+ where maskLT = (bitmapOf x - 1) .&. bm
+ go def Nil = unsafeFindMax def
+
+
+-- | \(O(\min(n,W))\). Find smallest element greater than the given one.
+--
+-- > lookupGT 4 (fromList [3, 5]) == Just 5
+-- > lookupGT 5 (fromList [3, 5]) == Nothing
+
+-- See Note: Local 'go' functions and capturing.
+lookupGT :: Key -> Word64Set -> Maybe Key
+lookupGT !x t = case t of
+ Bin _ m l r | m < 0 -> if x >= 0 then go Nil l else go l r
+ _ -> go Nil t
+ where
+ go def (Bin p m l r) | nomatch x p m = if x < p then unsafeFindMin l else unsafeFindMin def
+ | zero x m = go r l
+ | otherwise = go def r
+ go def (Tip kx bm) | prefixOf x < kx = Just $ kx + lowestBitSet bm
+ | prefixOf x == kx && maskGT /= 0 = Just $ kx + lowestBitSet maskGT
+ | otherwise = unsafeFindMin def
+ where maskGT = (- ((bitmapOf x) `shiftLL` 1)) .&. bm
+ go def Nil = unsafeFindMin def
+
+
+-- | \(O(\min(n,W))\). Find largest element smaller or equal to the given one.
+--
+-- > lookupLE 2 (fromList [3, 5]) == Nothing
+-- > lookupLE 4 (fromList [3, 5]) == Just 3
+-- > lookupLE 5 (fromList [3, 5]) == Just 5
+
+-- See Note: Local 'go' functions and capturing.
+lookupLE :: Key -> Word64Set -> Maybe Key
+lookupLE !x t = case t of
+ Bin _ m l r | m < 0 -> if x >= 0 then go r l else go Nil r
+ _ -> go Nil t
+ where
+ go def (Bin p m l r) | nomatch x p m = if x < p then unsafeFindMax def else unsafeFindMax r
+ | zero x m = go def l
+ | otherwise = go l r
+ go def (Tip kx bm) | prefixOf x > kx = Just $ kx + highestBitSet bm
+ | prefixOf x == kx && maskLE /= 0 = Just $ kx + highestBitSet maskLE
+ | otherwise = unsafeFindMax def
+ where maskLE = (((bitmapOf x) `shiftLL` 1) - 1) .&. bm
+ go def Nil = unsafeFindMax def
+
+
+-- | \(O(\min(n,W))\). Find smallest element greater or equal to the given one.
+--
+-- > lookupGE 3 (fromList [3, 5]) == Just 3
+-- > lookupGE 4 (fromList [3, 5]) == Just 5
+-- > lookupGE 6 (fromList [3, 5]) == Nothing
+
+-- See Note: Local 'go' functions and capturing.
+lookupGE :: Key -> Word64Set -> Maybe Key
+lookupGE !x t = case t of
+ Bin _ m l r | m < 0 -> if x >= 0 then go Nil l else go l r
+ _ -> go Nil t
+ where
+ go def (Bin p m l r) | nomatch x p m = if x < p then unsafeFindMin l else unsafeFindMin def
+ | zero x m = go r l
+ | otherwise = go def r
+ go def (Tip kx bm) | prefixOf x < kx = Just $ kx + lowestBitSet bm
+ | prefixOf x == kx && maskGE /= 0 = Just $ kx + lowestBitSet maskGE
+ | otherwise = unsafeFindMin def
+ where maskGE = (- (bitmapOf x)) .&. bm
+ go def Nil = unsafeFindMin def
+
+
+
+-- Helper function for lookupGE and lookupGT. It assumes that if a Bin node is
+-- given, it has m > 0.
+unsafeFindMin :: Word64Set -> Maybe Key
+unsafeFindMin Nil = Nothing
+unsafeFindMin (Tip kx bm) = Just $ kx + lowestBitSet bm
+unsafeFindMin (Bin _ _ l _) = unsafeFindMin l
+
+-- Helper function for lookupLE and lookupLT. It assumes that if a Bin node is
+-- given, it has m > 0.
+unsafeFindMax :: Word64Set -> Maybe Key
+unsafeFindMax Nil = Nothing
+unsafeFindMax (Tip kx bm) = Just $ kx + highestBitSet bm
+unsafeFindMax (Bin _ _ _ r) = unsafeFindMax r
+
+{--------------------------------------------------------------------
+ Construction
+--------------------------------------------------------------------}
+-- | \(O(1)\). The empty set.
+empty :: Word64Set
+empty
+ = Nil
+{-# INLINE empty #-}
+
+-- | \(O(1)\). A set of one element.
+singleton :: Key -> Word64Set
+singleton x
+ = Tip (prefixOf x) (bitmapOf x)
+{-# INLINE singleton #-}
+
+{--------------------------------------------------------------------
+ Insert
+--------------------------------------------------------------------}
+-- | \(O(\min(n,W))\). Add a value to the set. There is no left- or right bias for
+-- Word64Sets.
+insert :: Key -> Word64Set -> Word64Set
+insert !x = insertBM (prefixOf x) (bitmapOf x)
+
+-- Helper function for insert and union.
+insertBM :: Prefix -> BitMap -> Word64Set -> Word64Set
+insertBM !kx !bm t@(Bin p m l r)
+ | nomatch kx p m = link kx (Tip kx bm) p t
+ | zero kx m = Bin p m (insertBM kx bm l) r
+ | otherwise = Bin p m l (insertBM kx bm r)
+insertBM kx bm t@(Tip kx' bm')
+ | kx' == kx = Tip kx' (bm .|. bm')
+ | otherwise = link kx (Tip kx bm) kx' t
+insertBM kx bm Nil = Tip kx bm
+
+-- | \(O(\min(n,W))\). Delete a value in the set. Returns the
+-- original set when the value was not present.
+delete :: Key -> Word64Set -> Word64Set
+delete !x = deleteBM (prefixOf x) (bitmapOf x)
+
+-- Deletes all values mentioned in the BitMap from the set.
+-- Helper function for delete and difference.
+deleteBM :: Prefix -> BitMap -> Word64Set -> Word64Set
+deleteBM !kx !bm t@(Bin p m l r)
+ | nomatch kx p m = t
+ | zero kx m = bin p m (deleteBM kx bm l) r
+ | otherwise = bin p m l (deleteBM kx bm r)
+deleteBM kx bm t@(Tip kx' bm')
+ | kx' == kx = tip kx (bm' .&. complement bm)
+ | otherwise = t
+deleteBM _ _ Nil = Nil
+
+-- | \(O(\min(n,W))\). @('alterF' f x s)@ can delete or insert @x@ in @s@ depending
+-- on whether it is already present in @s@.
+--
+-- In short:
+--
+-- @
+-- 'member' x \<$\> 'alterF' f x s = f ('member' x s)
+-- @
+--
+-- Note: 'alterF' is a variant of the @at@ combinator from "Control.Lens.At".
+--
+-- @since 0.6.3.1
+alterF :: Functor f => (Bool -> f Bool) -> Key -> Word64Set -> f Word64Set
+alterF f k s = fmap choose (f member_)
+ where
+ member_ = member k s
+
+ (inserted, deleted)
+ | member_ = (s , delete k s)
+ | otherwise = (insert k s, s )
+
+ choose True = inserted
+ choose False = deleted
+#ifndef __GLASGOW_HASKELL__
+{-# INLINE alterF #-}
+#else
+{-# INLINABLE [2] alterF #-}
+
+{-# RULES
+"alterF/Const" forall k (f :: Bool -> Const a Bool) . alterF f k = \s -> Const . getConst . f $ member k s
+ #-}
+#endif
+
+{-# SPECIALIZE alterF :: (Bool -> Identity Bool) -> Key -> Word64Set -> Identity Word64Set #-}
+
+{--------------------------------------------------------------------
+ Union
+--------------------------------------------------------------------}
+-- | The union of a list of sets.
+unions :: Foldable f => f Word64Set -> Word64Set
+unions xs
+ = Foldable.foldl' union empty xs
+
+
+-- | \(O(n+m)\). The union of two sets.
+union :: Word64Set -> Word64Set -> Word64Set
+union t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
+ | shorter m1 m2 = union1
+ | shorter m2 m1 = union2
+ | p1 == p2 = Bin p1 m1 (union l1 l2) (union r1 r2)
+ | otherwise = link p1 t1 p2 t2
+ where
+ union1 | nomatch p2 p1 m1 = link p1 t1 p2 t2
+ | zero p2 m1 = Bin p1 m1 (union l1 t2) r1
+ | otherwise = Bin p1 m1 l1 (union r1 t2)
+
+ union2 | nomatch p1 p2 m2 = link p1 t1 p2 t2
+ | zero p1 m2 = Bin p2 m2 (union t1 l2) r2
+ | otherwise = Bin p2 m2 l2 (union t1 r2)
+
+union t@(Bin _ _ _ _) (Tip kx bm) = insertBM kx bm t
+union t@(Bin _ _ _ _) Nil = t
+union (Tip kx bm) t = insertBM kx bm t
+union Nil t = t
+
+
+{--------------------------------------------------------------------
+ Difference
+--------------------------------------------------------------------}
+-- | \(O(n+m)\). Difference between two sets.
+difference :: Word64Set -> Word64Set -> Word64Set
+difference t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
+ | shorter m1 m2 = difference1
+ | shorter m2 m1 = difference2
+ | p1 == p2 = bin p1 m1 (difference l1 l2) (difference r1 r2)
+ | otherwise = t1
+ where
+ difference1 | nomatch p2 p1 m1 = t1
+ | zero p2 m1 = bin p1 m1 (difference l1 t2) r1
+ | otherwise = bin p1 m1 l1 (difference r1 t2)
+
+ difference2 | nomatch p1 p2 m2 = t1
+ | zero p1 m2 = difference t1 l2
+ | otherwise = difference t1 r2
+
+difference t@(Bin _ _ _ _) (Tip kx bm) = deleteBM kx bm t
+difference t@(Bin _ _ _ _) Nil = t
+
+difference t1@(Tip kx bm) t2 = differenceTip t2
+ where differenceTip (Bin p2 m2 l2 r2) | nomatch kx p2 m2 = t1
+ | zero kx m2 = differenceTip l2
+ | otherwise = differenceTip r2
+ differenceTip (Tip kx2 bm2) | kx == kx2 = tip kx (bm .&. complement bm2)
+ | otherwise = t1
+ differenceTip Nil = t1
+
+difference Nil _ = Nil
+
+
+
+{--------------------------------------------------------------------
+ Intersection
+--------------------------------------------------------------------}
+-- | \(O(n+m)\). The intersection of two sets.
+intersection :: Word64Set -> Word64Set -> Word64Set
+intersection t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
+ | shorter m1 m2 = intersection1
+ | shorter m2 m1 = intersection2
+ | p1 == p2 = bin p1 m1 (intersection l1 l2) (intersection r1 r2)
+ | otherwise = Nil
+ where
+ intersection1 | nomatch p2 p1 m1 = Nil
+ | zero p2 m1 = intersection l1 t2
+ | otherwise = intersection r1 t2
+
+ intersection2 | nomatch p1 p2 m2 = Nil
+ | zero p1 m2 = intersection t1 l2
+ | otherwise = intersection t1 r2
+
+intersection t1@(Bin _ _ _ _) (Tip kx2 bm2) = intersectBM t1
+ where intersectBM (Bin p1 m1 l1 r1) | nomatch kx2 p1 m1 = Nil
+ | zero kx2 m1 = intersectBM l1
+ | otherwise = intersectBM r1
+ intersectBM (Tip kx1 bm1) | kx1 == kx2 = tip kx1 (bm1 .&. bm2)
+ | otherwise = Nil
+ intersectBM Nil = Nil
+
+intersection (Bin _ _ _ _) Nil = Nil
+
+intersection (Tip kx1 bm1) t2 = intersectBM t2
+ where intersectBM (Bin p2 m2 l2 r2) | nomatch kx1 p2 m2 = Nil
+ | zero kx1 m2 = intersectBM l2
+ | otherwise = intersectBM r2
+ intersectBM (Tip kx2 bm2) | kx1 == kx2 = tip kx1 (bm1 .&. bm2)
+ | otherwise = Nil
+ intersectBM Nil = Nil
+
+intersection Nil _ = Nil
+
+{--------------------------------------------------------------------
+ Subset
+--------------------------------------------------------------------}
+-- | \(O(n+m)\). Is this a proper subset? (ie. a subset but not equal).
+isProperSubsetOf :: Word64Set -> Word64Set -> Bool
+isProperSubsetOf t1 t2
+ = case subsetCmp t1 t2 of
+ LT -> True
+ _ -> False
+
+subsetCmp :: Word64Set -> Word64Set -> Ordering
+subsetCmp t1@(Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
+ | shorter m1 m2 = GT
+ | shorter m2 m1 = case subsetCmpLt of
+ GT -> GT
+ _ -> LT
+ | p1 == p2 = subsetCmpEq
+ | otherwise = GT -- disjoint
+ where
+ subsetCmpLt | nomatch p1 p2 m2 = GT
+ | zero p1 m2 = subsetCmp t1 l2
+ | otherwise = subsetCmp t1 r2
+ subsetCmpEq = case (subsetCmp l1 l2, subsetCmp r1 r2) of
+ (GT,_ ) -> GT
+ (_ ,GT) -> GT
+ (EQ,EQ) -> EQ
+ _ -> LT
+
+subsetCmp (Bin _ _ _ _) _ = GT
+subsetCmp (Tip kx1 bm1) (Tip kx2 bm2)
+ | kx1 /= kx2 = GT -- disjoint
+ | bm1 == bm2 = EQ
+ | bm1 .&. complement bm2 == 0 = LT
+ | otherwise = GT
+subsetCmp t1@(Tip kx _) (Bin p m l r)
+ | nomatch kx p m = GT
+ | zero kx m = case subsetCmp t1 l of GT -> GT ; _ -> LT
+ | otherwise = case subsetCmp t1 r of GT -> GT ; _ -> LT
+subsetCmp (Tip _ _) Nil = GT -- disjoint
+subsetCmp Nil Nil = EQ
+subsetCmp Nil _ = LT
+
+-- | \(O(n+m)\). Is this a subset?
+-- @(s1 \`isSubsetOf\` s2)@ tells whether @s1@ is a subset of @s2@.
+
+isSubsetOf :: Word64Set -> Word64Set -> Bool
+isSubsetOf t1@(Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
+ | shorter m1 m2 = False
+ | shorter m2 m1 = match p1 p2 m2 && (if zero p1 m2 then isSubsetOf t1 l2
+ else isSubsetOf t1 r2)
+ | otherwise = (p1==p2) && isSubsetOf l1 l2 && isSubsetOf r1 r2
+isSubsetOf (Bin _ _ _ _) _ = False
+isSubsetOf (Tip kx1 bm1) (Tip kx2 bm2) = kx1 == kx2 && bm1 .&. complement bm2 == 0
+isSubsetOf t1@(Tip kx _) (Bin p m l r)
+ | nomatch kx p m = False
+ | zero kx m = isSubsetOf t1 l
+ | otherwise = isSubsetOf t1 r
+isSubsetOf (Tip _ _) Nil = False
+isSubsetOf Nil _ = True
+
+
+{--------------------------------------------------------------------
+ Disjoint
+--------------------------------------------------------------------}
+-- | \(O(n+m)\). Check whether two sets are disjoint (i.e. their intersection
+-- is empty).
+--
+-- > disjoint (fromList [2,4,6]) (fromList [1,3]) == True
+-- > disjoint (fromList [2,4,6,8]) (fromList [2,3,5,7]) == False
+-- > disjoint (fromList [1,2]) (fromList [1,2,3,4]) == False
+-- > disjoint (fromList []) (fromList []) == True
+--
+-- @since 0.5.11
+disjoint :: Word64Set -> Word64Set -> Bool
+disjoint t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
+ | shorter m1 m2 = disjoint1
+ | shorter m2 m1 = disjoint2
+ | p1 == p2 = disjoint l1 l2 && disjoint r1 r2
+ | otherwise = True
+ where
+ disjoint1 | nomatch p2 p1 m1 = True
+ | zero p2 m1 = disjoint l1 t2
+ | otherwise = disjoint r1 t2
+
+ disjoint2 | nomatch p1 p2 m2 = True
+ | zero p1 m2 = disjoint t1 l2
+ | otherwise = disjoint t1 r2
+
+disjoint t1@(Bin _ _ _ _) (Tip kx2 bm2) = disjointBM t1
+ where disjointBM (Bin p1 m1 l1 r1) | nomatch kx2 p1 m1 = True
+ | zero kx2 m1 = disjointBM l1
+ | otherwise = disjointBM r1
+ disjointBM (Tip kx1 bm1) | kx1 == kx2 = (bm1 .&. bm2) == 0
+ | otherwise = True
+ disjointBM Nil = True
+
+disjoint (Bin _ _ _ _) Nil = True
+
+disjoint (Tip kx1 bm1) t2 = disjointBM t2
+ where disjointBM (Bin p2 m2 l2 r2) | nomatch kx1 p2 m2 = True
+ | zero kx1 m2 = disjointBM l2
+ | otherwise = disjointBM r2
+ disjointBM (Tip kx2 bm2) | kx1 == kx2 = (bm1 .&. bm2) == 0
+ | otherwise = True
+ disjointBM Nil = True
+
+disjoint Nil _ = True
+
+
+{--------------------------------------------------------------------
+ Filter
+--------------------------------------------------------------------}
+-- | \(O(n)\). Filter all elements that satisfy some predicate.
+filter :: (Key -> Bool) -> Word64Set -> Word64Set
+filter predicate t
+ = case t of
+ Bin p m l r
+ -> bin p m (filter predicate l) (filter predicate r)
+ Tip kx bm
+ -> tip kx (foldl'Bits 0 (bitPred kx) 0 bm)
+ Nil -> Nil
+ where bitPred kx bm bi | predicate (kx + bi) = bm .|. bitmapOfSuffix bi
+ | otherwise = bm
+ {-# INLINE bitPred #-}
+
+-- | \(O(n)\). partition the set according to some predicate.
+partition :: (Key -> Bool) -> Word64Set -> (Word64Set,Word64Set)
+partition predicate0 t0 = toPair $ go predicate0 t0
+ where
+ go predicate t
+ = case t of
+ Bin p m l r
+ -> let (l1 :*: l2) = go predicate l
+ (r1 :*: r2) = go predicate r
+ in bin p m l1 r1 :*: bin p m l2 r2
+ Tip kx bm
+ -> let bm1 = foldl'Bits 0 (bitPred kx) 0 bm
+ in tip kx bm1 :*: tip kx (bm `xor` bm1)
+ Nil -> (Nil :*: Nil)
+ where bitPred kx bm bi | predicate (kx + bi) = bm .|. bitmapOfSuffix bi
+ | otherwise = bm
+ {-# INLINE bitPred #-}
+
+-- | \(O(\min(n,W))\). Take while a predicate on the elements holds.
+-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@.
+-- See note at 'spanAntitone'.
+--
+-- @
+-- takeWhileAntitone p = 'fromDistinctAscList' . 'Data.List.takeWhile' p . 'toList'
+-- takeWhileAntitone p = 'filter' p
+-- @
+--
+-- @since 0.6.7
+takeWhileAntitone :: (Key -> Bool) -> Word64Set -> Word64Set
+takeWhileAntitone predicate t =
+ case t of
+ Bin p m l r
+ | m < 0 ->
+ if predicate 0 -- handle negative numbers.
+ then bin p m (go predicate l) r
+ else go predicate r
+ _ -> go predicate t
+ where
+ go predicate' (Bin p m l r)
+ | predicate' $! p+m = bin p m l (go predicate' r)
+ | otherwise = go predicate' l
+ go predicate' (Tip kx bm) = tip kx (takeWhileAntitoneBits kx predicate' bm)
+ go _ Nil = Nil
+
+-- | \(O(\min(n,W))\). Drop while a predicate on the elements holds.
+-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@.
+-- See note at 'spanAntitone'.
+--
+-- @
+-- dropWhileAntitone p = 'fromDistinctAscList' . 'Data.List.dropWhile' p . 'toList'
+-- dropWhileAntitone p = 'filter' (not . p)
+-- @
+--
+-- @since 0.6.7
+dropWhileAntitone :: (Key -> Bool) -> Word64Set -> Word64Set
+dropWhileAntitone predicate t =
+ case t of
+ Bin p m l r
+ | m < 0 ->
+ if predicate 0 -- handle negative numbers.
+ then go predicate l
+ else bin p m l (go predicate r)
+ _ -> go predicate t
+ where
+ go predicate' (Bin p m l r)
+ | predicate' $! p+m = go predicate' r
+ | otherwise = bin p m (go predicate' l) r
+ go predicate' (Tip kx bm) = tip kx (bm `xor` takeWhileAntitoneBits kx predicate' bm)
+ go _ Nil = Nil
+
+-- | \(O(\min(n,W))\). Divide a set at the point where a predicate on the elements stops holding.
+-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@.
+--
+-- @
+-- spanAntitone p xs = ('takeWhileAntitone' p xs, 'dropWhileAntitone' p xs)
+-- spanAntitone p xs = 'partition' p xs
+-- @
+--
+-- Note: if @p@ is not actually antitone, then @spanAntitone@ will split the set
+-- at some /unspecified/ point.
+--
+-- @since 0.6.7
+spanAntitone :: (Key -> Bool) -> Word64Set -> (Word64Set, Word64Set)
+spanAntitone predicate t =
+ case t of
+ Bin p m l r
+ | m < 0 ->
+ if predicate 0 -- handle negative numbers.
+ then
+ case go predicate l of
+ (lt :*: gt) ->
+ let !lt' = bin p m lt r
+ in (lt', gt)
+ else
+ case go predicate r of
+ (lt :*: gt) ->
+ let !gt' = bin p m l gt
+ in (lt, gt')
+ _ -> case go predicate t of
+ (lt :*: gt) -> (lt, gt)
+ where
+ go predicate' (Bin p m l r)
+ | predicate' $! p+m = case go predicate' r of (lt :*: gt) -> bin p m l lt :*: gt
+ | otherwise = case go predicate' l of (lt :*: gt) -> lt :*: bin p m gt r
+ go predicate' (Tip kx bm) = let bm' = takeWhileAntitoneBits kx predicate' bm
+ in (tip kx bm' :*: tip kx (bm `xor` bm'))
+ go _ Nil = (Nil :*: Nil)
+
+-- | \(O(\min(n,W))\). The expression (@'split' x set@) is a pair @(set1,set2)@
+-- where @set1@ comprises the elements of @set@ less than @x@ and @set2@
+-- comprises the elements of @set@ greater than @x@.
+--
+-- > split 3 (fromList [1..5]) == (fromList [1,2], fromList [4,5])
+split :: Key -> Word64Set -> (Word64Set,Word64Set)
+split x t =
+ case t of
+ Bin p m l r
+ | m < 0 ->
+ if x >= 0 -- handle negative numbers.
+ then
+ case go x l of
+ (lt :*: gt) ->
+ let !lt' = bin p m lt r
+ in (lt', gt)
+ else
+ case go x r of
+ (lt :*: gt) ->
+ let !gt' = bin p m l gt
+ in (lt, gt')
+ _ -> case go x t of
+ (lt :*: gt) -> (lt, gt)
+ where
+ go !x' t'@(Bin p m l r)
+ | nomatch x' p m = if x' < p then (Nil :*: t') else (t' :*: Nil)
+ | zero x' m = case go x' l of (lt :*: gt) -> lt :*: bin p m gt r
+ | otherwise = case go x' r of (lt :*: gt) -> bin p m l lt :*: gt
+ go x' t'@(Tip kx' bm)
+ | kx' > x' = (Nil :*: t')
+ -- equivalent to kx' > prefixOf x'
+ | kx' < prefixOf x' = (t' :*: Nil)
+ | otherwise = tip kx' (bm .&. lowerBitmap) :*: tip kx' (bm .&. higherBitmap)
+ where lowerBitmap = bitmapOf x' - 1
+ higherBitmap = complement (lowerBitmap + bitmapOf x')
+ go _ Nil = (Nil :*: Nil)
+
+-- | \(O(\min(n,W))\). Performs a 'split' but also returns whether the pivot
+-- element was found in the original set.
+splitMember :: Key -> Word64Set -> (Word64Set,Bool,Word64Set)
+splitMember x t =
+ case t of
+ Bin p m l r
+ | m < 0 ->
+ if x >= 0 -- handle negative numbers.
+ then
+ case go x l of
+ (lt, fnd, gt) ->
+ let !lt' = bin p m lt r
+ in (lt', fnd, gt)
+ else
+ case go x r of
+ (lt, fnd, gt) ->
+ let !gt' = bin p m l gt
+ in (lt, fnd, gt')
+ _ -> go x t
+ where
+ go x' t'@(Bin p m l r)
+ | nomatch x' p m = if x' < p then (Nil, False, t') else (t', False, Nil)
+ | zero x' m =
+ case go x' l of
+ (lt, fnd, gt) ->
+ let !gt' = bin p m gt r
+ in (lt, fnd, gt')
+ | otherwise =
+ case go x' r of
+ (lt, fnd, gt) ->
+ let !lt' = bin p m l lt
+ in (lt', fnd, gt)
+ go x' t'@(Tip kx' bm)
+ | kx' > x' = (Nil, False, t')
+ -- equivalent to kx' > prefixOf x'
+ | kx' < prefixOf x' = (t', False, Nil)
+ | otherwise = let !lt = tip kx' (bm .&. lowerBitmap)
+ !found = (bm .&. bitmapOfx') /= 0
+ !gt = tip kx' (bm .&. higherBitmap)
+ in (lt, found, gt)
+ where bitmapOfx' = bitmapOf x'
+ lowerBitmap = bitmapOfx' - 1
+ higherBitmap = complement (lowerBitmap + bitmapOfx')
+ go _ Nil = (Nil, False, Nil)
+
+{----------------------------------------------------------------------
+ Min/Max
+----------------------------------------------------------------------}
+
+-- | \(O(\min(n,W))\). Retrieves the maximal key of the set, and the set
+-- stripped of that element, or 'Nothing' if passed an empty set.
+maxView :: Word64Set -> Maybe (Key, Word64Set)
+maxView t =
+ case t of Nil -> Nothing
+ Bin p m l r | m < 0 -> case go l of (result, l') -> Just (result, bin p m l' r)
+ _ -> Just (go t)
+ where
+ go (Bin p m l r) = case go r of (result, r') -> (result, bin p m l r')
+ go (Tip kx bm) = case highestBitSet bm of bi -> (kx + bi, tip kx (bm .&. complement (bitmapOfSuffix bi)))
+ go Nil = error "maxView Nil"
+
+-- | \(O(\min(n,W))\). Retrieves the minimal key of the set, and the set
+-- stripped of that element, or 'Nothing' if passed an empty set.
+minView :: Word64Set -> Maybe (Key, Word64Set)
+minView t =
+ case t of Nil -> Nothing
+ Bin p m l r | m < 0 -> case go r of (result, r') -> Just (result, bin p m l r')
+ _ -> Just (go t)
+ where
+ go (Bin p m l r) = case go l of (result, l') -> (result, bin p m l' r)
+ go (Tip kx bm) = case lowestBitSet bm of bi -> (kx + bi, tip kx (bm .&. complement (bitmapOfSuffix bi)))
+ go Nil = error "minView Nil"
+
+-- | \(O(\min(n,W))\). Delete and find the minimal element.
+--
+-- > deleteFindMin set = (findMin set, deleteMin set)
+deleteFindMin :: Word64Set -> (Key, Word64Set)
+deleteFindMin = fromMaybe (error "deleteFindMin: empty set has no minimal element") . minView
+
+-- | \(O(\min(n,W))\). Delete and find the maximal element.
+--
+-- > deleteFindMax set = (findMax set, deleteMax set)
+deleteFindMax :: Word64Set -> (Key, Word64Set)
+deleteFindMax = fromMaybe (error "deleteFindMax: empty set has no maximal element") . maxView
+
+
+-- | \(O(\min(n,W))\). The minimal element of the set.
+findMin :: Word64Set -> Key
+findMin Nil = error "findMin: empty set has no minimal element"
+findMin (Tip kx bm) = kx + lowestBitSet bm
+findMin (Bin _ m l r)
+ | m < 0 = find r
+ | otherwise = find l
+ where find (Tip kx bm) = kx + lowestBitSet bm
+ find (Bin _ _ l' _) = find l'
+ find Nil = error "findMin Nil"
+
+-- | \(O(\min(n,W))\). The maximal element of a set.
+findMax :: Word64Set -> Key
+findMax Nil = error "findMax: empty set has no maximal element"
+findMax (Tip kx bm) = kx + highestBitSet bm
+findMax (Bin _ m l r)
+ | m < 0 = find l
+ | otherwise = find r
+ where find (Tip kx bm) = kx + highestBitSet bm
+ find (Bin _ _ _ r') = find r'
+ find Nil = error "findMax Nil"
+
+
+-- | \(O(\min(n,W))\). Delete the minimal element. Returns an empty set if the set is empty.
+--
+-- Note that this is a change of behaviour for consistency with 'Data.Set.Set' –
+-- versions prior to 0.5 threw an error if the 'Word64Set' was already empty.
+deleteMin :: Word64Set -> Word64Set
+deleteMin = maybe Nil snd . minView
+
+-- | \(O(\min(n,W))\). Delete the maximal element. Returns an empty set if the set is empty.
+--
+-- Note that this is a change of behaviour for consistency with 'Data.Set.Set' –
+-- versions prior to 0.5 threw an error if the 'Word64Set' was already empty.
+deleteMax :: Word64Set -> Word64Set
+deleteMax = maybe Nil snd . maxView
+
+{----------------------------------------------------------------------
+ Map
+----------------------------------------------------------------------}
+
+-- | \(O(n \min(n,W))\).
+-- @'map' f s@ is the set obtained by applying @f@ to each element of @s@.
+--
+-- It's worth noting that the size of the result may be smaller if,
+-- for some @(x,y)@, @x \/= y && f x == f y@
+
+map :: (Key -> Key) -> Word64Set -> Word64Set
+map f = fromList . List.map f . toList
+
+-- | \(O(n)\). The
+--
+-- @'mapMonotonic' f s == 'map' f s@, but works only when @f@ is strictly increasing.
+-- /The precondition is not checked./
+-- Semi-formally, we have:
+--
+-- > and [x < y ==> f x < f y | x <- ls, y <- ls]
+-- > ==> mapMonotonic f s == map f s
+-- > where ls = toList s
+--
+-- @since 0.6.3.1
+
+-- Note that for now the test is insufficient to support any fancier implementation.
+mapMonotonic :: (Key -> Key) -> Word64Set -> Word64Set
+mapMonotonic f = fromDistinctAscList . List.map f . toAscList
+
+
+{--------------------------------------------------------------------
+ Fold
+--------------------------------------------------------------------}
+-- | \(O(n)\). Fold the elements in the set using the given right-associative
+-- binary operator. This function is an equivalent of 'foldr' and is present
+-- for compatibility only.
+--
+-- /Please note that fold will be deprecated in the future and removed./
+fold :: (Key -> b -> b) -> b -> Word64Set -> b
+fold = foldr
+{-# INLINE fold #-}
+
+-- | \(O(n)\). Fold the elements in the set using the given right-associative
+-- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'toAscList'@.
+--
+-- For example,
+--
+-- > toAscList set = foldr (:) [] set
+foldr :: (Key -> b -> b) -> b -> Word64Set -> b
+foldr f z = \t -> -- Use lambda t to be inlinable with two arguments only.
+ case t of Bin _ m l r | m < 0 -> go (go z l) r -- put negative numbers before
+ | otherwise -> go (go z r) l
+ _ -> go z t
+ where
+ go z' Nil = z'
+ go z' (Tip kx bm) = foldrBits kx f z' bm
+ go z' (Bin _ _ l r) = go (go z' r) l
+{-# INLINE foldr #-}
+
+-- | \(O(n)\). A strict version of 'foldr'. Each application of the operator is
+-- evaluated before using the result in the next application. This
+-- function is strict in the starting value.
+foldr' :: (Key -> b -> b) -> b -> Word64Set -> b
+foldr' f z = \t -> -- Use lambda t to be inlinable with two arguments only.
+ case t of Bin _ m l r | m < 0 -> go (go z l) r -- put negative numbers before
+ | otherwise -> go (go z r) l
+ _ -> go z t
+ where
+ go !z' Nil = z'
+ go z' (Tip kx bm) = foldr'Bits kx f z' bm
+ go z' (Bin _ _ l r) = go (go z' r) l
+{-# INLINE foldr' #-}
+
+-- | \(O(n)\). Fold the elements in the set using the given left-associative
+-- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'toAscList'@.
+--
+-- For example,
+--
+-- > toDescList set = foldl (flip (:)) [] set
+foldl :: (a -> Key -> a) -> a -> Word64Set -> a
+foldl f z = \t -> -- Use lambda t to be inlinable with two arguments only.
+ case t of Bin _ m l r | m < 0 -> go (go z r) l -- put negative numbers before
+ | otherwise -> go (go z l) r
+ _ -> go z t
+ where
+ go z' Nil = z'
+ go z' (Tip kx bm) = foldlBits kx f z' bm
+ go z' (Bin _ _ l r) = go (go z' l) r
+{-# INLINE foldl #-}
+
+-- | \(O(n)\). A strict version of 'foldl'. Each application of the operator is
+-- evaluated before using the result in the next application. This
+-- function is strict in the starting value.
+foldl' :: (a -> Key -> a) -> a -> Word64Set -> a
+foldl' f z = \t -> -- Use lambda t to be inlinable with two arguments only.
+ case t of Bin _ m l r | m < 0 -> go (go z r) l -- put negative numbers before
+ | otherwise -> go (go z l) r
+ _ -> go z t
+ where
+ go !z' Nil = z'
+ go z' (Tip kx bm) = foldl'Bits kx f z' bm
+ go z' (Bin _ _ l r) = go (go z' l) r
+{-# INLINE foldl' #-}
+
+{--------------------------------------------------------------------
+ List variations
+--------------------------------------------------------------------}
+-- | \(O(n)\). An alias of 'toAscList'. The elements of a set in ascending order.
+-- Subject to list fusion.
+elems :: Word64Set -> [Key]
+elems
+ = toAscList
+
+{--------------------------------------------------------------------
+ Lists
+--------------------------------------------------------------------}
+
+#ifdef __GLASGOW_HASKELL__
+-- | @since 0.5.6.2
+instance GHC.Exts.IsList Word64Set where
+ type Item Word64Set = Key
+ fromList = fromList
+ toList = toList
+#endif
+
+-- | \(O(n)\). Convert the set to a list of elements. Subject to list fusion.
+toList :: Word64Set -> [Key]
+toList
+ = toAscList
+
+-- | \(O(n)\). Convert the set to an ascending list of elements. Subject to list
+-- fusion.
+toAscList :: Word64Set -> [Key]
+toAscList = foldr (:) []
+
+-- | \(O(n)\). Convert the set to a descending list of elements. Subject to list
+-- fusion.
+toDescList :: Word64Set -> [Key]
+toDescList = foldl (flip (:)) []
+
+-- List fusion for the list generating functions.
+#if __GLASGOW_HASKELL__
+-- The foldrFB and foldlFB are foldr and foldl equivalents, used for list fusion.
+-- They are important to convert unfused to{Asc,Desc}List back, see mapFB in prelude.
+foldrFB :: (Key -> b -> b) -> b -> Word64Set -> b
+foldrFB = foldr
+{-# INLINE[0] foldrFB #-}
+foldlFB :: (a -> Key -> a) -> a -> Word64Set -> a
+foldlFB = foldl
+{-# INLINE[0] foldlFB #-}
+
+-- Inline elems and toList, so that we need to fuse only toAscList.
+{-# INLINE elems #-}
+{-# INLINE toList #-}
+
+-- The fusion is enabled up to phase 2 included. If it does not succeed,
+-- convert in phase 1 the expanded to{Asc,Desc}List calls back to
+-- to{Asc,Desc}List. In phase 0, we inline fold{lr}FB (which were used in
+-- a list fusion, otherwise it would go away in phase 1), and let compiler do
+-- whatever it wants with to{Asc,Desc}List -- it was forbidden to inline it
+-- before phase 0, otherwise the fusion rules would not fire at all.
+{-# NOINLINE[0] toAscList #-}
+{-# NOINLINE[0] toDescList #-}
+{-# RULES "Word64Set.toAscList" [~1] forall s . toAscList s = GHC.Exts.build (\c n -> foldrFB c n s) #-}
+{-# RULES "Word64Set.toAscListBack" [1] foldrFB (:) [] = toAscList #-}
+{-# RULES "Word64Set.toDescList" [~1] forall s . toDescList s = GHC.Exts.build (\c n -> foldlFB (\xs x -> c x xs) n s) #-}
+{-# RULES "Word64Set.toDescListBack" [1] foldlFB (\xs x -> x : xs) [] = toDescList #-}
+#endif
+
+
+-- | \(O(n \min(n,W))\). Create a set from a list of integers.
+fromList :: [Key] -> Word64Set
+fromList xs
+ = Foldable.foldl' ins empty xs
+ where
+ ins t x = insert x t
+
+-- | \(O(n)\). Build a set from an ascending list of elements.
+-- /The precondition (input list is ascending) is not checked./
+fromAscList :: [Key] -> Word64Set
+fromAscList = fromMonoList
+{-# NOINLINE fromAscList #-}
+
+-- | \(O(n)\). Build a set from an ascending list of distinct elements.
+-- /The precondition (input list is strictly ascending) is not checked./
+fromDistinctAscList :: [Key] -> Word64Set
+fromDistinctAscList = fromAscList
+{-# INLINE fromDistinctAscList #-}
+
+-- | \(O(n)\). Build a set from a monotonic list of elements.
+--
+-- The precise conditions under which this function works are subtle:
+-- For any branch mask, keys with the same prefix w.r.t. the branch
+-- mask must occur consecutively in the list.
+fromMonoList :: [Key] -> Word64Set
+fromMonoList [] = Nil
+fromMonoList (kx : zs1) = addAll' (prefixOf kx) (bitmapOf kx) zs1
+ where
+ -- `addAll'` collects all keys with the prefix `px` into a single
+ -- bitmap, and then proceeds with `addAll`.
+ addAll' !px !bm []
+ = Tip px bm
+ addAll' !px !bm (ky : zs)
+ | px == prefixOf ky
+ = addAll' px (bm .|. bitmapOf ky) zs
+ -- inlined: | otherwise = addAll px (Tip px bm) (ky : zs)
+ | py <- prefixOf ky
+ , m <- branchMask px py
+ , Inserted ty zs' <- addMany' m py (bitmapOf ky) zs
+ = addAll px (linkWithMask m py ty {-px-} (Tip px bm)) zs'
+
+ -- for `addAll` and `addMany`, px is /a/ prefix inside the tree `tx`
+ -- `addAll` consumes the rest of the list, adding to the tree `tx`
+ addAll !_px !tx []
+ = tx
+ addAll !px !tx (ky : zs)
+ | py <- prefixOf ky
+ , m <- branchMask px py
+ , Inserted ty zs' <- addMany' m py (bitmapOf ky) zs
+ = addAll px (linkWithMask m py ty {-px-} tx) zs'
+
+ -- `addMany'` is similar to `addAll'`, but proceeds with `addMany'`.
+ addMany' !_m !px !bm []
+ = Inserted (Tip px bm) []
+ addMany' !m !px !bm zs0@(ky : zs)
+ | px == prefixOf ky
+ = addMany' m px (bm .|. bitmapOf ky) zs
+ -- inlined: | otherwise = addMany m px (Tip px bm) (ky : zs)
+ | mask px m /= mask ky m
+ = Inserted (Tip (prefixOf px) bm) zs0
+ | py <- prefixOf ky
+ , mxy <- branchMask px py
+ , Inserted ty zs' <- addMany' mxy py (bitmapOf ky) zs
+ = addMany m px (linkWithMask mxy py ty {-px-} (Tip px bm)) zs'
+
+ -- `addAll` adds to `tx` all keys whose prefix w.r.t. `m` agrees with `px`.
+ addMany !_m !_px tx []
+ = Inserted tx []
+ addMany !m !px tx zs0@(ky : zs)
+ | mask px m /= mask ky m
+ = Inserted tx zs0
+ | py <- prefixOf ky
+ , mxy <- branchMask px py
+ , Inserted ty zs' <- addMany' mxy py (bitmapOf ky) zs
+ = addMany m px (linkWithMask mxy py ty {-px-} tx) zs'
+{-# INLINE fromMonoList #-}
+
+data Inserted = Inserted !Word64Set ![Key]
+
+{--------------------------------------------------------------------
+ Eq
+--------------------------------------------------------------------}
+instance Eq Word64Set where
+ t1 == t2 = equal t1 t2
+ t1 /= t2 = nequal t1 t2
+
+equal :: Word64Set -> Word64Set -> Bool
+equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
+ = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2)
+equal (Tip kx1 bm1) (Tip kx2 bm2)
+ = kx1 == kx2 && bm1 == bm2
+equal Nil Nil = True
+equal _ _ = False
+
+nequal :: Word64Set -> Word64Set -> Bool
+nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
+ = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2)
+nequal (Tip kx1 bm1) (Tip kx2 bm2)
+ = kx1 /= kx2 || bm1 /= bm2
+nequal Nil Nil = False
+nequal _ _ = True
+
+{--------------------------------------------------------------------
+ Ord
+--------------------------------------------------------------------}
+
+instance Ord Word64Set where
+ compare s1 s2 = compare (toAscList s1) (toAscList s2)
+ -- tentative implementation. See if more efficient exists.
+
+{--------------------------------------------------------------------
+ Show
+--------------------------------------------------------------------}
+instance Show Word64Set where
+ showsPrec p xs = showParen (p > 10) $
+ showString "fromList " . shows (toList xs)
+
+{--------------------------------------------------------------------
+ Read
+--------------------------------------------------------------------}
+instance Read Word64Set where
+#ifdef __GLASGOW_HASKELL__
+ readPrec = parens $ prec 10 $ do
+ Ident "fromList" <- lexP
+ xs <- readPrec
+ return (fromList xs)
+
+ readListPrec = readListPrecDefault
+#else
+ readsPrec p = readParen (p > 10) $ \ r -> do
+ ("fromList",s) <- lex r
+ (xs,t) <- reads s
+ return (fromList xs,t)
+#endif
+
+{--------------------------------------------------------------------
+ NFData
+--------------------------------------------------------------------}
+
+-- The Word64Set constructors consist only of strict fields of Ints and
+-- Word64Sets, thus the default NFData instance which evaluates to whnf
+-- should suffice
+instance NFData Word64Set where rnf x = seq x ()
+
+{--------------------------------------------------------------------
+ Debugging
+--------------------------------------------------------------------}
+-- | \(O(n \min(n,W))\). Show the tree that implements the set. The tree is shown
+-- in a compressed, hanging format.
+showTree :: Word64Set -> String
+showTree s
+ = showTreeWith True False s
+
+
+{- | \(O(n \min(n,W))\). The expression (@'showTreeWith' hang wide map@) shows
+ the tree that implements the set. If @hang@ is
+ 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If
+ @wide@ is 'True', an extra wide version is shown.
+-}
+showTreeWith :: Bool -> Bool -> Word64Set -> String
+showTreeWith hang wide t
+ | hang = (showsTreeHang wide [] t) ""
+ | otherwise = (showsTree wide [] [] t) ""
+
+showsTree :: Bool -> [String] -> [String] -> Word64Set -> ShowS
+showsTree wide lbars rbars t
+ = case t of
+ Bin p m l r
+ -> showsTree wide (withBar rbars) (withEmpty rbars) r .
+ showWide wide rbars .
+ showsBars lbars . showString (showBin p m) . showString "\n" .
+ showWide wide lbars .
+ showsTree wide (withEmpty lbars) (withBar lbars) l
+ Tip kx bm
+ -> showsBars lbars . showString " " . shows kx . showString " + " .
+ showsBitMap bm . showString "\n"
+ Nil -> showsBars lbars . showString "|\n"
+
+showsTreeHang :: Bool -> [String] -> Word64Set -> ShowS
+showsTreeHang wide bars t
+ = case t of
+ Bin p m l r
+ -> showsBars bars . showString (showBin p m) . showString "\n" .
+ showWide wide bars .
+ showsTreeHang wide (withBar bars) l .
+ showWide wide bars .
+ showsTreeHang wide (withEmpty bars) r
+ Tip kx bm
+ -> showsBars bars . showString " " . shows kx . showString " + " .
+ showsBitMap bm . showString "\n"
+ Nil -> showsBars bars . showString "|\n"
+
+showBin :: Prefix -> Mask -> String
+showBin _ _
+ = "*" -- ++ show (p,m)
+
+showWide :: Bool -> [String] -> String -> String
+showWide wide bars
+ | wide = showString (concat (reverse bars)) . showString "|\n"
+ | otherwise = id
+
+showsBars :: [String] -> ShowS
+showsBars [] = id
+showsBars (_ : tl) = showString (concat (reverse tl)) . showString node
+
+showsBitMap :: Word64 -> ShowS
+showsBitMap = showString . showBitMap
+
+showBitMap :: Word64 -> String
+showBitMap w = show $ foldrBits 0 (:) [] w
+
+node :: String
+node = "+--"
+
+withBar, withEmpty :: [String] -> [String]
+withBar bars = "| ":bars
+withEmpty bars = " ":bars
+
+
+{--------------------------------------------------------------------
+ Helpers
+--------------------------------------------------------------------}
+{--------------------------------------------------------------------
+ Link
+--------------------------------------------------------------------}
+link :: Prefix -> Word64Set -> Prefix -> Word64Set -> Word64Set
+link p1 t1 p2 t2 = linkWithMask (branchMask p1 p2) p1 t1 {-p2-} t2
+{-# INLINE link #-}
+
+-- `linkWithMask` is useful when the `branchMask` has already been computed
+linkWithMask :: Mask -> Prefix -> Word64Set -> Word64Set -> Word64Set
+linkWithMask m p1 t1 {-p2-} t2
+ | zero p1 m = Bin p m t1 t2
+ | otherwise = Bin p m t2 t1
+ where
+ p = mask p1 m
+{-# INLINE linkWithMask #-}
+
+{--------------------------------------------------------------------
+ @bin@ assures that we never have empty trees within a tree.
+--------------------------------------------------------------------}
+bin :: Prefix -> Mask -> Word64Set -> Word64Set -> Word64Set
+bin _ _ l Nil = l
+bin _ _ Nil r = r
+bin p m l r = Bin p m l r
+{-# INLINE bin #-}
+
+{--------------------------------------------------------------------
+ @tip@ assures that we never have empty bitmaps within a tree.
+--------------------------------------------------------------------}
+tip :: Prefix -> BitMap -> Word64Set
+tip _ 0 = Nil
+tip kx bm = Tip kx bm
+{-# INLINE tip #-}
+
+
+{----------------------------------------------------------------------
+ Functions that generate Prefix and BitMap of a Key or a Suffix.
+----------------------------------------------------------------------}
+
+suffixBitMask :: Word64
+suffixBitMask = fromIntegral (finiteBitSize (undefined::Word64)) - 1
+{-# INLINE suffixBitMask #-}
+
+prefixBitMask :: Word64
+prefixBitMask = complement suffixBitMask
+{-# INLINE prefixBitMask #-}
+
+prefixOf :: Word64 -> Prefix
+prefixOf x = x .&. prefixBitMask
+{-# INLINE prefixOf #-}
+
+suffixOf :: Word64 -> Word64
+suffixOf x = x .&. suffixBitMask
+{-# INLINE suffixOf #-}
+
+bitmapOfSuffix :: Word64 -> BitMap
+bitmapOfSuffix s = 1 `shiftLL` fromIntegral s
+{-# INLINE bitmapOfSuffix #-}
+
+bitmapOf :: Word64 -> BitMap
+bitmapOf x = bitmapOfSuffix (suffixOf x)
+{-# INLINE bitmapOf #-}
+
+
+{--------------------------------------------------------------------
+ Endian independent bit twiddling
+--------------------------------------------------------------------}
+-- Returns True iff the bits set in i and the Mask m are disjoint.
+zero :: Word64 -> Mask -> Bool
+zero i m
+ = (natFromInt i) .&. (natFromInt m) == 0
+{-# INLINE zero #-}
+
+nomatch,match :: Word64 -> Prefix -> Mask -> Bool
+nomatch i p m
+ = (mask i m) /= p
+{-# INLINE nomatch #-}
+
+match i p m
+ = (mask i m) == p
+{-# INLINE match #-}
+
+-- Suppose a is largest such that 2^a divides 2*m.
+-- Then mask i m is i with the low a bits zeroed out.
+mask :: Word64 -> Mask -> Prefix
+mask i m
+ = maskW (natFromInt i) (natFromInt m)
+{-# INLINE mask #-}
+
+{--------------------------------------------------------------------
+ Big endian operations
+--------------------------------------------------------------------}
+maskW :: Nat -> Nat -> Prefix
+maskW i m
+ = intFromNat (i .&. (complement (m-1) `xor` m))
+{-# INLINE maskW #-}
+
+shorter :: Mask -> Mask -> Bool
+shorter m1 m2
+ = (natFromInt m1) > (natFromInt m2)
+{-# INLINE shorter #-}
+
+branchMask :: Prefix -> Prefix -> Mask
+branchMask p1 p2
+ = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))
+{-# INLINE branchMask #-}
+
+{----------------------------------------------------------------------
+ To get best performance, we provide fast implementations of
+ lowestBitSet, highestBitSet and fold[lr][l]Bits for GHC.
+ If the intel bsf and bsr instructions ever become GHC primops,
+ this code should be reimplemented using these.
+
+ Performance of this code is crucial for folds, toList, filter, partition.
+
+ The signatures of methods in question are placed after this comment.
+----------------------------------------------------------------------}
+
+lowestBitSet :: Nat -> Word64
+highestBitSet :: Nat -> Word64
+foldlBits :: Word64 -> (a -> Word64 -> a) -> a -> Nat -> a
+foldl'Bits :: Word64 -> (a -> Word64 -> a) -> a -> Nat -> a
+foldrBits :: Word64 -> (Word64 -> a -> a) -> a -> Nat -> a
+foldr'Bits :: Word64 -> (Word64 -> a -> a) -> a -> Nat -> a
+takeWhileAntitoneBits :: Word64 -> (Word64 -> Bool) -> Nat -> Nat
+
+{-# INLINE lowestBitSet #-}
+{-# INLINE highestBitSet #-}
+{-# INLINE foldlBits #-}
+{-# INLINE foldl'Bits #-}
+{-# INLINE foldrBits #-}
+{-# INLINE foldr'Bits #-}
+{-# INLINE takeWhileAntitoneBits #-}
+
+#if defined(__GLASGOW_HASKELL__)
+indexOfTheOnlyBit :: Nat -> Word64
+{-# INLINE indexOfTheOnlyBit #-}
+indexOfTheOnlyBit bitmask = fromIntegral $ countTrailingZeros bitmask
+
+lowestBitSet x = fromIntegral $ countTrailingZeros x
+
+highestBitSet x = fromIntegral $ 63 - countLeadingZeros x
+
+lowestBitMask :: Nat -> Nat
+lowestBitMask x = x .&. negate x
+{-# INLINE lowestBitMask #-}
+
+-- Reverse the order of bits in the Nat.
+revNat :: Nat -> Nat
+revNat x1 = case ((x1 `shiftRL` 1) .&. 0x5555555555555555) .|. ((x1 .&. 0x5555555555555555) `shiftLL` 1) of
+ x2 -> case ((x2 `shiftRL` 2) .&. 0x3333333333333333) .|. ((x2 .&. 0x3333333333333333) `shiftLL` 2) of
+ x3 -> case ((x3 `shiftRL` 4) .&. 0x0F0F0F0F0F0F0F0F) .|. ((x3 .&. 0x0F0F0F0F0F0F0F0F) `shiftLL` 4) of
+ x4 -> case ((x4 `shiftRL` 8) .&. 0x00FF00FF00FF00FF) .|. ((x4 .&. 0x00FF00FF00FF00FF) `shiftLL` 8) of
+ x5 -> case ((x5 `shiftRL` 16) .&. 0x0000FFFF0000FFFF) .|. ((x5 .&. 0x0000FFFF0000FFFF) `shiftLL` 16) of
+ x6 -> ( x6 `shiftRL` 32 ) .|. ( x6 `shiftLL` 32);
+
+foldlBits prefix f z bitmap = go bitmap z
+ where go 0 acc = acc
+ go bm acc = go (bm `xor` bitmask) ((f acc) $! (prefix+bi))
+ where
+ !bitmask = lowestBitMask bm
+ !bi = indexOfTheOnlyBit bitmask
+
+foldl'Bits prefix f z bitmap = go bitmap z
+ where go 0 acc = acc
+ go bm !acc = go (bm `xor` bitmask) ((f acc) $! (prefix+bi))
+ where !bitmask = lowestBitMask bm
+ !bi = indexOfTheOnlyBit bitmask
+
+foldrBits prefix f z bitmap = go (revNat bitmap) z
+ where go 0 acc = acc
+ go bm acc = go (bm `xor` bitmask) ((f $! (prefix+63-bi)) acc)
+ where !bitmask = lowestBitMask bm
+ !bi = indexOfTheOnlyBit bitmask
+
+
+foldr'Bits prefix f z bitmap = go (revNat bitmap) z
+ where go 0 acc = acc
+ go bm !acc = go (bm `xor` bitmask) ((f $! (prefix+63-bi)) acc)
+ where !bitmask = lowestBitMask bm
+ !bi = indexOfTheOnlyBit bitmask
+
+takeWhileAntitoneBits prefix predicate bitmap =
+ -- Binary search for the first index where the predicate returns false, but skip a predicate
+ -- call if the high half of the current range is empty. This ensures
+ -- min (log2 64 + 1 = 7) (popcount bitmap) predicate calls.
+ let next d h (n',b') =
+ if n' .&. h /= 0 && (predicate $! prefix + fromIntegral (b'+d)) then (n' `shiftRL` d, b'+d) else (n',b')
+ {-# INLINE next #-}
+ (_,b) = next 1 0x2 $
+ next 2 0xC $
+ next 4 0xF0 $
+ next 8 0xFF00 $
+ next 16 0xFFFF0000 $
+ next 32 0xFFFFFFFF00000000 $
+ (bitmap,0)
+ m = if b /= 0 || (bitmap .&. 0x1 /= 0 && predicate prefix)
+ then ((2 `shiftLL` b) - 1)
+ else ((1 `shiftLL` b) - 1)
+ in bitmap .&. m
+
+#else
+{----------------------------------------------------------------------
+ In general case we use logarithmic implementation of
+ lowestBitSet and highestBitSet, which works up to bit sizes of 64.
+
+ Folds are linear scans.
+----------------------------------------------------------------------}
+
+lowestBitSet n0 =
+ let (n1,b1) = if n0 .&. 0xFFFFFFFF /= 0 then (n0,0) else (n0 `shiftRL` 32, 32)
+ (n2,b2) = if n1 .&. 0xFFFF /= 0 then (n1,b1) else (n1 `shiftRL` 16, 16+b1)
+ (n3,b3) = if n2 .&. 0xFF /= 0 then (n2,b2) else (n2 `shiftRL` 8, 8+b2)
+ (n4,b4) = if n3 .&. 0xF /= 0 then (n3,b3) else (n3 `shiftRL` 4, 4+b3)
+ (n5,b5) = if n4 .&. 0x3 /= 0 then (n4,b4) else (n4 `shiftRL` 2, 2+b4)
+ b6 = if n5 .&. 0x1 /= 0 then b5 else 1+b5
+ in b6
+
+highestBitSet n0 =
+ let (n1,b1) = if n0 .&. 0xFFFFFFFF00000000 /= 0 then (n0 `shiftRL` 32, 32) else (n0,0)
+ (n2,b2) = if n1 .&. 0xFFFF0000 /= 0 then (n1 `shiftRL` 16, 16+b1) else (n1,b1)
+ (n3,b3) = if n2 .&. 0xFF00 /= 0 then (n2 `shiftRL` 8, 8+b2) else (n2,b2)
+ (n4,b4) = if n3 .&. 0xF0 /= 0 then (n3 `shiftRL` 4, 4+b3) else (n3,b3)
+ (n5,b5) = if n4 .&. 0xC /= 0 then (n4 `shiftRL` 2, 2+b4) else (n4,b4)
+ b6 = if n5 .&. 0x2 /= 0 then 1+b5 else b5
+ in b6
+
+foldlBits prefix f z bm = let lb = lowestBitSet bm
+ in go (prefix+lb) z (bm `shiftRL` lb)
+ where go !_ acc 0 = acc
+ go bi acc n | n `testBit` 0 = go (bi + 1) (f acc bi) (n `shiftRL` 1)
+ | otherwise = go (bi + 1) acc (n `shiftRL` 1)
+
+foldl'Bits prefix f z bm = let lb = lowestBitSet bm
+ in go (prefix+lb) z (bm `shiftRL` lb)
+ where go !_ !acc 0 = acc
+ go bi acc n | n `testBit` 0 = go (bi + 1) (f acc bi) (n `shiftRL` 1)
+ | otherwise = go (bi + 1) acc (n `shiftRL` 1)
+
+foldrBits prefix f z bm = let lb = lowestBitSet bm
+ in go (prefix+lb) (bm `shiftRL` lb)
+ where go !_ 0 = z
+ go bi n | n `testBit` 0 = f bi (go (bi + 1) (n `shiftRL` 1))
+ | otherwise = go (bi + 1) (n `shiftRL` 1)
+
+foldr'Bits prefix f z bm = let lb = lowestBitSet bm
+ in go (prefix+lb) (bm `shiftRL` lb)
+ where
+ go !_ 0 = z
+ go bi n | n `testBit` 0 = f bi $! go (bi + 1) (n `shiftRL` 1)
+ | otherwise = go (bi + 1) (n `shiftRL` 1)
+
+takeWhileAntitoneBits prefix predicate = foldl'Bits prefix f 0 -- Does not use antitone property
+ where
+ f acc bi | predicate bi = acc .|. bitmapOf bi
+ | otherwise = acc
+
+#endif
+
+
+{--------------------------------------------------------------------
+ Utilities
+--------------------------------------------------------------------}
+
+-- | \(O(1)\). Decompose a set into pieces based on the structure of the underlying
+-- tree. This function is useful for consuming a set in parallel.
+--
+-- No guarantee is made as to the sizes of the pieces; an internal, but
+-- deterministic process determines this. However, it is guaranteed that the
+-- pieces returned will be in ascending order (all elements in the first submap
+-- less than all elements in the second, and so on).
+--
+-- Examples:
+--
+-- > splitRoot (fromList [1..120]) == [fromList [1..63],fromList [64..120]]
+-- > splitRoot empty == []
+--
+-- Note that the current implementation does not return more than two subsets,
+-- but you should not depend on this behaviour because it can change in the
+-- future without notice. Also, the current version does not continue
+-- splitting all the way to individual singleton sets -- it stops at some
+-- point.
+splitRoot :: Word64Set -> [Word64Set]
+splitRoot Nil = []
+-- NOTE: we don't currently split below Tip, but we could.
+splitRoot x@(Tip _ _) = [x]
+splitRoot (Bin _ m l r) | m < 0 = [r, l]
+ | otherwise = [l, r]
+{-# INLINE splitRoot #-}
diff --git a/compiler/GHC/Driver/CmdLine.hs b/compiler/GHC/Driver/CmdLine.hs
index a4bc77766f249acd329d0832e4aed2cec0793992..3e1b1bdf9c41312dcde9b4ea027728185c9765bf 100644
--- a/compiler/GHC/Driver/CmdLine.hs
+++ b/compiler/GHC/Driver/CmdLine.hs
@@ -37,6 +37,7 @@ import GHC.Utils.Outputable (text)
import Data.Function
import Data.List (sortBy, intercalate, stripPrefix)
+import Data.Word
import GHC.ResponseFile
import Control.Exception (IOException, catch)
@@ -75,7 +76,7 @@ hoistFlag f (Flag a b c) = Flag a (go b) c
go (OptPrefix k) = OptPrefix (\s -> go2 (k s))
go (OptIntSuffix k) = OptIntSuffix (\n -> go2 (k n))
go (IntSuffix k) = IntSuffix (\n -> go2 (k n))
- go (WordSuffix k) = WordSuffix (\s -> go2 (k s))
+ go (Word64Suffix k) = Word64Suffix (\s -> go2 (k s))
go (FloatSuffix k) = FloatSuffix (\s -> go2 (k s))
go (PassFlag k) = PassFlag (\s -> go2 (k s))
go (AnySuffix k) = AnySuffix (\s -> go2 (k s))
@@ -98,7 +99,7 @@ data OptKind m -- Suppose the flag is -f
| OptPrefix (String -> EwM m ()) -- -f or -farg (i.e. the arg is optional)
| OptIntSuffix (Maybe Int -> EwM m ()) -- -f or -f=n; pass n to fn
| IntSuffix (Int -> EwM m ()) -- -f or -f=n; pass n to fn
- | WordSuffix (Word -> EwM m ()) -- -f or -f=n; pass n to fn
+ | Word64Suffix (Word64 -> EwM m ()) -- -f or -f=n; pass n to fn
| FloatSuffix (Float -> EwM m ()) -- -f or -f=n; pass n to fn
| PassFlag (String -> EwM m ()) -- -f; pass "-f" fn
| AnySuffix (String -> EwM m ()) -- -f or -farg; pass entire "-farg" to fn
@@ -240,7 +241,7 @@ processOneArg opt_kind rest arg args
IntSuffix f | Just n <- parseInt rest_no_eq -> Right (f n, args)
| otherwise -> Left ("malformed integer argument in " ++ dash_arg)
- WordSuffix f | Just n <- parseWord rest_no_eq -> Right (f n, args)
+ Word64Suffix f | Just n <- parseWord64 rest_no_eq -> Right (f n, args)
| otherwise -> Left ("malformed natural argument in " ++ dash_arg)
FloatSuffix f | Just n <- parseFloat rest_no_eq -> Right (f n, args)
@@ -269,7 +270,7 @@ arg_ok (Prefix _) _ _ = True -- Missing argument checked for in p
-- to improve error message (#12625)
arg_ok (OptIntSuffix _) _ _ = True
arg_ok (IntSuffix _) _ _ = True
-arg_ok (WordSuffix _) _ _ = True
+arg_ok (Word64Suffix _) _ _ = True
arg_ok (FloatSuffix _) _ _ = True
arg_ok (OptPrefix _) _ _ = True
arg_ok (PassFlag _) rest _ = null rest
@@ -285,8 +286,8 @@ parseInt s = case reads s of
((n,""):_) -> Just n
_ -> Nothing
-parseWord :: String -> Maybe Word
-parseWord s = case reads s of
+parseWord64 :: String -> Maybe Word64
+parseWord64 s = case reads s of
((n,""):_) -> Just n
_ -> Nothing
diff --git a/compiler/GHC/Driver/DynFlags.hs b/compiler/GHC/Driver/DynFlags.hs
index 2570b33d8cdea2caf892536bc3949a183b31f7ca..6f80550336e6c3ac53eb568000ea035aa197a9f4 100644
--- a/compiler/GHC/Driver/DynFlags.hs
+++ b/compiler/GHC/Driver/DynFlags.hs
@@ -116,6 +116,7 @@ import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (ExceptT)
import Control.Monad.Trans.Reader (ReaderT)
import Control.Monad.Trans.Writer (WriterT)
+import Data.Word
import System.IO
import System.IO.Error (catchIOError)
import System.Environment (lookupEnv)
@@ -439,7 +440,7 @@ data DynFlags = DynFlags {
maxErrors :: Maybe Int,
-- | Unique supply configuration for testing build determinism
- initialUnique :: Word,
+ initialUnique :: Word64,
uniqueIncrement :: Int,
-- 'Int' because it can be used to test uniques in decreasing order.
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index db97b2ba3882686154a7b0be17896ae9521b6829..1bd25a7afdab61856bd7cbe96a030ca26979a837 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -248,7 +248,7 @@ import GHC.Types.Name.Ppr
import GHC.Types.Name.Set (NonCaffySet)
import GHC.Types.TyThing
import GHC.Types.HpcInfo
-import GHC.Types.Unique.Supply (uniqFromMask)
+import GHC.Types.Unique.Supply (uniqFromTag)
import GHC.Types.Unique.Set
import GHC.Utils.Fingerprint ( Fingerprint )
@@ -2543,7 +2543,7 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr = do
--
-- The id has to be exported for the JS backend. This isn't required for the
-- byte-code interpreter but it does no harm to always do it.
- u <- uniqFromMask 'I'
+ u <- uniqFromTag 'I'
let binding_name = mkSystemVarName u (fsLit ("BCO_toplevel"))
let binding_id = mkExportedVanillaId binding_name (exprType simpl_expr)
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index 47e6a24b7258abc908148ff0fa43f814329038a3..c3d69347efea94b62a23695ac23f247cc66b6a26 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -155,7 +155,7 @@ import GHC.Types.Unique.DFM (udfmRestrictKeysSet)
import GHC.Types.Unique
import GHC.Iface.Errors.Types
-import qualified Data.IntSet as I
+import qualified GHC.Data.Word64Set as W
-- -----------------------------------------------------------------------------
-- Loading the program
@@ -2823,12 +2823,12 @@ See test "jspace" for an example which used to trigger this problem.
-}
-- See Note [ModuleNameSet, efficiency and space leaks]
-type ModuleNameSet = M.Map UnitId I.IntSet
+type ModuleNameSet = M.Map UnitId W.Word64Set
addToModuleNameSet :: UnitId -> ModuleName -> ModuleNameSet -> ModuleNameSet
addToModuleNameSet uid mn s =
let k = (getKey $ getUnique $ mn)
- in M.insertWith (I.union) uid (I.singleton k) s
+ in M.insertWith (W.union) uid (W.singleton k) s
-- | Wait for some dependencies to finish and then read from the given MVar.
wait_deps_hug :: MVar HomeUnitGraph -> [BuildResult] -> ReaderT MakeEnv (MaybeT IO) (HomeUnitGraph, ModuleNameSet)
@@ -2839,7 +2839,7 @@ wait_deps_hug hug_var deps = do
let -- Restrict to things which are in the transitive closure to avoid retaining
-- reference to loop modules which have already been compiled by other threads.
-- See Note [ModuleNameSet, efficiency and space leaks]
- !new = udfmRestrictKeysSet (homeUnitEnv_hpt hme) (fromMaybe I.empty $ M.lookup uid module_deps)
+ !new = udfmRestrictKeysSet (homeUnitEnv_hpt hme) (fromMaybe W.empty $ M.lookup uid module_deps)
in hme { homeUnitEnv_hpt = new }
return (unitEnv_mapWithKey pruneHomeUnitEnv hug, module_deps)
@@ -2854,7 +2854,7 @@ wait_deps (x:xs) = do
Nothing -> return (hmis, new_deps)
Just hmi -> return (hmi:hmis, new_deps)
where
- unionModuleNameSet = M.unionWith I.union
+ unionModuleNameSet = M.unionWith W.union
-- Executing the pipelines
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 3c27704b6885dc8636c78650f9a98db69c4482e8..174d902e38877dbf06a4f4303d6ccda8a006509b 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -277,6 +277,7 @@ import Data.List (intercalate, sortBy)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import qualified Data.Set as Set
+import Data.Word
import System.FilePath
import Text.ParserCombinators.ReadP hiding (char)
import Text.ParserCombinators.ReadP as R
@@ -960,8 +961,8 @@ add_dep_message (OptIntSuffix f) message =
OptIntSuffix $ \oi -> f oi >> deprecate message
add_dep_message (IntSuffix f) message =
IntSuffix $ \i -> f i >> deprecate message
-add_dep_message (WordSuffix f) message =
- WordSuffix $ \i -> f i >> deprecate message
+add_dep_message (Word64Suffix f) message =
+ Word64Suffix $ \i -> f i >> deprecate message
add_dep_message (FloatSuffix f) message =
FloatSuffix $ \fl -> f fl >> deprecate message
add_dep_message (PassFlag f) message =
@@ -1750,7 +1751,7 @@ dynamic_flags_deps = [
, make_ord_flag defGhcFlag "fmax-inline-memset-insns"
(intSuffix (\n d -> d { maxInlineMemsetInsns = n }))
, make_ord_flag defGhcFlag "dinitial-unique"
- (wordSuffix (\n d -> d { initialUnique = n }))
+ (word64Suffix (\n d -> d { initialUnique = n }))
, make_ord_flag defGhcFlag "dunique-increment"
(intSuffix (\n d -> d { uniqueIncrement = n }))
@@ -2980,8 +2981,8 @@ intSuffix fn = IntSuffix (\n -> upd (fn n))
intSuffixM :: (Int -> DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags)
intSuffixM fn = IntSuffix (\n -> updM (fn n))
-wordSuffix :: (Word -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)
-wordSuffix fn = WordSuffix (\n -> upd (fn n))
+word64Suffix :: (Word64 -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)
+word64Suffix fn = Word64Suffix (\n -> upd (fn n))
floatSuffix :: (Float -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)
floatSuffix fn = FloatSuffix (\n -> upd (fn n))
diff --git a/compiler/GHC/HsToCore/Foreign/JavaScript.hs b/compiler/GHC/HsToCore/Foreign/JavaScript.hs
index a3f6a796c2cf530f0e376e7998d6c590f20bd3e4..651c744954d2db93d7eb5fa7610c049e50489604 100644
--- a/compiler/GHC/HsToCore/Foreign/JavaScript.hs
+++ b/compiler/GHC/HsToCore/Foreign/JavaScript.hs
@@ -156,7 +156,7 @@ mkFExportJSBits platform c_nm maybe_target arg_htys res_hty is_IO_res_ty _cconv
header_bits = maybe mempty idTag maybe_target
idTag i = let (tag, u) = unpkUnique (getUnique i)
- in CHeader (char tag <> int u)
+ in CHeader (char tag <> word64 u)
fun_args
| null arg_info = empty -- text "void"
diff --git a/compiler/GHC/HsToCore/Match/Literal.hs b/compiler/GHC/HsToCore/Match/Literal.hs
index fd308ccb14dcac7961aefe5f3f88259fcc92be82..d9296202ed21f0bcd573201201e721fe4ad30939 100644
--- a/compiler/GHC/HsToCore/Match/Literal.hs
+++ b/compiler/GHC/HsToCore/Match/Literal.hs
@@ -64,6 +64,7 @@ import GHC.Utils.Outputable as Outputable
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
+import GHC.Utils.Unique (sameUnique)
import GHC.Data.FastString
@@ -319,29 +320,29 @@ warnAboutOverflowedLiterals dflags lit
, Just (i, tc) <- lit
= if
-- These only show up via the 'HsOverLit' route
- | tc == intTyConName -> check i tc minInt maxInt
- | tc == wordTyConName -> check i tc minWord maxWord
- | tc == int8TyConName -> check i tc (min' @Int8) (max' @Int8)
- | tc == int16TyConName -> check i tc (min' @Int16) (max' @Int16)
- | tc == int32TyConName -> check i tc (min' @Int32) (max' @Int32)
- | tc == int64TyConName -> check i tc (min' @Int64) (max' @Int64)
- | tc == word8TyConName -> check i tc (min' @Word8) (max' @Word8)
- | tc == word16TyConName -> check i tc (min' @Word16) (max' @Word16)
- | tc == word32TyConName -> check i tc (min' @Word32) (max' @Word32)
- | tc == word64TyConName -> check i tc (min' @Word64) (max' @Word64)
- | tc == naturalTyConName -> checkPositive i tc
+ | sameUnique tc intTyConName -> check i tc minInt maxInt
+ | sameUnique tc wordTyConName -> check i tc minWord maxWord
+ | sameUnique tc int8TyConName -> check i tc (min' @Int8) (max' @Int8)
+ | sameUnique tc int16TyConName -> check i tc (min' @Int16) (max' @Int16)
+ | sameUnique tc int32TyConName -> check i tc (min' @Int32) (max' @Int32)
+ | sameUnique tc int64TyConName -> check i tc (min' @Int64) (max' @Int64)
+ | sameUnique tc word8TyConName -> check i tc (min' @Word8) (max' @Word8)
+ | sameUnique tc word16TyConName -> check i tc (min' @Word16) (max' @Word16)
+ | sameUnique tc word32TyConName -> check i tc (min' @Word32) (max' @Word32)
+ | sameUnique tc word64TyConName -> check i tc (min' @Word64) (max' @Word64)
+ | sameUnique tc naturalTyConName -> checkPositive i tc
-- These only show up via the 'HsLit' route
- | tc == intPrimTyConName -> check i tc minInt maxInt
- | tc == wordPrimTyConName -> check i tc minWord maxWord
- | tc == int8PrimTyConName -> check i tc (min' @Int8) (max' @Int8)
- | tc == int16PrimTyConName -> check i tc (min' @Int16) (max' @Int16)
- | tc == int32PrimTyConName -> check i tc (min' @Int32) (max' @Int32)
- | tc == int64PrimTyConName -> check i tc (min' @Int64) (max' @Int64)
- | tc == word8PrimTyConName -> check i tc (min' @Word8) (max' @Word8)
- | tc == word16PrimTyConName -> check i tc (min' @Word16) (max' @Word16)
- | tc == word32PrimTyConName -> check i tc (min' @Word32) (max' @Word32)
- | tc == word64PrimTyConName -> check i tc (min' @Word64) (max' @Word64)
+ | sameUnique tc intPrimTyConName -> check i tc minInt maxInt
+ | sameUnique tc wordPrimTyConName -> check i tc minWord maxWord
+ | sameUnique tc int8PrimTyConName -> check i tc (min' @Int8) (max' @Int8)
+ | sameUnique tc int16PrimTyConName -> check i tc (min' @Int16) (max' @Int16)
+ | sameUnique tc int32PrimTyConName -> check i tc (min' @Int32) (max' @Int32)
+ | sameUnique tc int64PrimTyConName -> check i tc (min' @Int64) (max' @Int64)
+ | sameUnique tc word8PrimTyConName -> check i tc (min' @Word8) (max' @Word8)
+ | sameUnique tc word16PrimTyConName -> check i tc (min' @Word16) (max' @Word16)
+ | sameUnique tc word32PrimTyConName -> check i tc (min' @Word32) (max' @Word32)
+ | sameUnique tc word64PrimTyConName -> check i tc (min' @Word64) (max' @Word64)
| otherwise -> return ()
@@ -398,22 +399,22 @@ warnAboutEmptyEnumerations fam_envs dflags fromExpr mThnExpr toExpr
platform <- targetPlatform <$> getDynFlags
-- Be careful to use target Int/Word sizes! cf #17336
- if | tc == intTyConName -> case platformWordSize platform of
- PW4 -> check @Int32
- PW8 -> check @Int64
- | tc == wordTyConName -> case platformWordSize platform of
- PW4 -> check @Word32
- PW8 -> check @Word64
- | tc == int8TyConName -> check @Int8
- | tc == int16TyConName -> check @Int16
- | tc == int32TyConName -> check @Int32
- | tc == int64TyConName -> check @Int64
- | tc == word8TyConName -> check @Word8
- | tc == word16TyConName -> check @Word16
- | tc == word32TyConName -> check @Word32
- | tc == word64TyConName -> check @Word64
- | tc == integerTyConName -> check @Integer
- | tc == naturalTyConName -> check @Integer
+ if | sameUnique tc intTyConName -> case platformWordSize platform of
+ PW4 -> check @Int32
+ PW8 -> check @Int64
+ | sameUnique tc wordTyConName -> case platformWordSize platform of
+ PW4 -> check @Word32
+ PW8 -> check @Word64
+ | sameUnique tc int8TyConName -> check @Int8
+ | sameUnique tc int16TyConName -> check @Int16
+ | sameUnique tc int32TyConName -> check @Int32
+ | sameUnique tc int64TyConName -> check @Int64
+ | sameUnique tc word8TyConName -> check @Word8
+ | sameUnique tc word16TyConName -> check @Word16
+ | sameUnique tc word32TyConName -> check @Word32
+ | sameUnique tc word64TyConName -> check @Word64
+ | sameUnique tc integerTyConName -> check @Integer
+ | sameUnique tc naturalTyConName -> check @Integer
-- We use 'Integer' because otherwise a negative 'Natural' literal
-- could cause a compile time crash (instead of a runtime one).
-- See the T10930b test case for an example of where this matters.
diff --git a/compiler/GHC/Linker/Deps.hs b/compiler/GHC/Linker/Deps.hs
index 0854b608e48f3cdeaa0bcb79fbeae3feb0822a9a..64210b14789c90c23962dc1fa21150d9cbacff55 100644
--- a/compiler/GHC/Linker/Deps.hs
+++ b/compiler/GHC/Linker/Deps.hs
@@ -1,3 +1,8 @@
+-- The transition from Int to Word64 for uniques makes functions slightly larger
+-- without this GHC option some optimizations fail to fire.
+-- See https://gitlab.haskell.org/ghc/ghc/-/merge_requests/10568#note_505751
+{-# OPTIONS_GHC -fspec-constr-threshold=10000 #-}
+
{-# LANGUAGE CPP #-}
{-# LANGUAGE TupleSections, RecordWildCards #-}
{-# LANGUAGE BangPatterns #-}
diff --git a/compiler/GHC/Stg/Pipeline.hs b/compiler/GHC/Stg/Pipeline.hs
index 25dadc6dcb3f20da66544cf6ea6e003673767b30..c2bde7470a4f09cd063cbe8af9517688ace26ac0 100644
--- a/compiler/GHC/Stg/Pipeline.hs
+++ b/compiler/GHC/Stg/Pipeline.hs
@@ -58,10 +58,10 @@ newtype StgM a = StgM { _unStgM :: ReaderT Char IO a }
deriving (Functor, Applicative, Monad, MonadIO)
instance MonadUnique StgM where
- getUniqueSupplyM = StgM $ do { mask <- ask
- ; liftIO $! mkSplitUniqSupply mask}
- getUniqueM = StgM $ do { mask <- ask
- ; liftIO $! uniqFromMask mask}
+ getUniqueSupplyM = StgM $ do { tag <- ask
+ ; liftIO $! mkSplitUniqSupply tag}
+ getUniqueM = StgM $ do { tag <- ask
+ ; liftIO $! uniqFromTag tag}
runStgM :: Char -> StgM a -> IO a
runStgM mask (StgM m) = runReaderT m mask
diff --git a/compiler/GHC/StgToCmm/Ticky.hs b/compiler/GHC/StgToCmm/Ticky.hs
index 325ebde71ccc641e403c8befeae38ac600ff29bb..3f3d9e4da21584798bf62b66e0b9b77042d09879 100644
--- a/compiler/GHC/StgToCmm/Ticky.hs
+++ b/compiler/GHC/StgToCmm/Ticky.hs
@@ -157,6 +157,7 @@ import GHC.Types.Id.Info
import GHC.StgToCmm.Env (getCgInfo_maybe)
import Data.Coerce (coerce)
import GHC.Utils.Json
+import GHC.Utils.Unique (anyOfUnique)
-----------------------------------------------------------------------------
--
@@ -884,20 +885,19 @@ showTypeCategory ty
| otherwise = case tcSplitTyConApp_maybe ty of
Nothing -> '.'
Just (tycon, _) ->
- let anyOf us = getUnique tycon `elem` us in
case () of
- _ | anyOf [fUNTyConKey] -> '>'
- | anyOf [charTyConKey] -> 'C'
- | anyOf [charPrimTyConKey] -> 'c'
- | anyOf [doubleTyConKey] -> 'D'
- | anyOf [doublePrimTyConKey] -> 'd'
- | anyOf [floatTyConKey] -> 'F'
- | anyOf [floatPrimTyConKey] -> 'f'
- | anyOf [intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey] -> 'I'
- | anyOf [intPrimTyConKey, int8PrimTyConKey, int16PrimTyConKey, int32PrimTyConKey, int64PrimTyConKey] -> 'i'
- | anyOf [wordTyConKey, word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey] -> 'W'
- | anyOf [wordPrimTyConKey, word8PrimTyConKey, word16PrimTyConKey, word32PrimTyConKey, word64PrimTyConKey] -> 'w'
- | anyOf [listTyConKey] -> 'L'
+ _ | anyOfUnique tycon [fUNTyConKey] -> '>'
+ | anyOfUnique tycon [charTyConKey] -> 'C'
+ | anyOfUnique tycon [charPrimTyConKey] -> 'c'
+ | anyOfUnique tycon [doubleTyConKey] -> 'D'
+ | anyOfUnique tycon [doublePrimTyConKey] -> 'd'
+ | anyOfUnique tycon [floatTyConKey] -> 'F'
+ | anyOfUnique tycon [floatPrimTyConKey] -> 'f'
+ | anyOfUnique tycon [intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey] -> 'I'
+ | anyOfUnique tycon [intPrimTyConKey, int8PrimTyConKey, int16PrimTyConKey, int32PrimTyConKey, int64PrimTyConKey] -> 'i'
+ | anyOfUnique tycon [wordTyConKey, word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey] -> 'W'
+ | anyOfUnique tycon [wordPrimTyConKey, word8PrimTyConKey, word16PrimTyConKey, word32PrimTyConKey, word64PrimTyConKey] -> 'w'
+ | anyOfUnique tycon [listTyConKey] -> 'L'
| isUnboxedTupleTyCon tycon -> 't'
| isTupleTyCon tycon -> 'T'
| isPrimTyCon tycon -> 'P'
diff --git a/compiler/GHC/StgToJS/Deps.hs b/compiler/GHC/StgToJS/Deps.hs
index 52628b3eee98798af6f54299cd57dd33a5340b80..4fdfa0a7ed026eadc9efafe8713c65d040817052 100644
--- a/compiler/GHC/StgToJS/Deps.hs
+++ b/compiler/GHC/StgToJS/Deps.hs
@@ -45,18 +45,19 @@ import Data.Map (Map)
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.IntSet as IS
-import qualified Data.IntMap as IM
-import Data.IntMap (IntMap)
+import qualified GHC.Data.Word64Map as WM
+import GHC.Data.Word64Map (Word64Map)
import Data.Array
import Data.Either
+import Data.Word
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.State
data DependencyDataCache = DDC
- { ddcModule :: !(IntMap Unit) -- ^ Unique Module -> Unit
- , ddcId :: !(IntMap ExportedFun) -- ^ Unique Id -> ExportedFun (only to other modules)
+ { ddcModule :: !(Word64Map Unit) -- ^ Unique Module -> Unit
+ , ddcId :: !(Word64Map ExportedFun) -- ^ Unique Id -> ExportedFun (only to other modules)
, ddcOther :: !(Map OtherSymb ExportedFun)
}
@@ -71,7 +72,7 @@ genDependencyData
-> G BlockInfo
genDependencyData mod units = do
ds <- evalStateT (mapM (uncurry oneDep) blocks)
- (DDC IM.empty IM.empty M.empty)
+ (DDC WM.empty WM.empty M.empty)
return $ BlockInfo
{ bi_module = mod
, bi_must_link = IS.fromList [ n | (n, _, True, _) <- ds ]
@@ -144,7 +145,7 @@ genDependencyData mod units = do
in if m == mod
then pprPanic "local id not found" (ppr m)
else Left <$> do
- mr <- gets (IM.lookup k . ddcId)
+ mr <- gets (WM.lookup k . ddcId)
maybe addEntry return mr
-- get the function for an OtherSymb from the cache, add it if necessary
@@ -167,7 +168,7 @@ genDependencyData mod units = do
-- lookup a dependency to another module, add to the id cache if there's
-- an id key, otherwise add to other cache
- lookupExternalFun :: Maybe Int
+ lookupExternalFun :: Maybe Word64
-> OtherSymb -> StateT DependencyDataCache G ExportedFun
lookupExternalFun mbIdKey od@(OtherSymb m idTxt) = do
let mk = getKey . getUnique $ m
@@ -175,17 +176,17 @@ genDependencyData mod units = do
exp_fun = ExportedFun m (LexicalFastString idTxt)
addCache = do
ms <- gets ddcModule
- let !cache' = IM.insert mk mpk ms
+ let !cache' = WM.insert mk mpk ms
modify (\s -> s { ddcModule = cache'})
pure exp_fun
f <- do
- mbm <- gets (IM.member mk . ddcModule)
+ mbm <- gets (WM.member mk . ddcModule)
case mbm of
False -> addCache
True -> pure exp_fun
case mbIdKey of
Nothing -> modify (\s -> s { ddcOther = M.insert od f (ddcOther s) })
- Just k -> modify (\s -> s { ddcId = IM.insert k f (ddcId s) })
+ Just k -> modify (\s -> s { ddcId = WM.insert k f (ddcId s) })
return f
diff --git a/compiler/GHC/StgToJS/Ids.hs b/compiler/GHC/StgToJS/Ids.hs
index 0b5d9f2fd68d64440dd5377cee45c3c5492b3687..aa9a9c54ad0756a87753bd5ceb99f6abe280567b 100644
--- a/compiler/GHC/StgToJS/Ids.hs
+++ b/compiler/GHC/StgToJS/Ids.hs
@@ -131,7 +131,7 @@ makeIdentForId i num id_type current_module = TxtI ident
, if exported
then mempty
else let (c,u) = unpkUnique (getUnique i)
- in mconcat [BSC.pack ['_',c,'_'], intBS u]
+ in mconcat [BSC.pack ['_',c,'_'], word64BS u]
]
-- | Retrieve the cached Ident for the given Id if there is one. Otherwise make
diff --git a/compiler/GHC/StgToJS/Symbols.hs b/compiler/GHC/StgToJS/Symbols.hs
index 999c654fa866b00ff600b862d93d290deaa4c663..aa634690487b6af4f70f3d2465aae411c2257a6a 100644
--- a/compiler/GHC/StgToJS/Symbols.hs
+++ b/compiler/GHC/StgToJS/Symbols.hs
@@ -8,23 +8,32 @@ module GHC.StgToJS.Symbols
, mkFreshJsSymbol
, mkRawSymbol
, intBS
+ , word64BS
) where
import GHC.Prelude
import GHC.Data.FastString
import GHC.Unit.Module
+import GHC.Utils.Word64 (intToWord64)
import Data.ByteString (ByteString)
+import Data.Word (Word64)
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Builder as BSB
import qualified Data.ByteString.Lazy as BSL
-- | Hexadecimal representation of an int
--
+-- Used for the sub indices.
+intBS :: Int -> ByteString
+intBS = word64BS . intToWord64
+
+-- | Hexadecimal representation of a 64-bit word
+--
-- Used for uniques. We could use base-62 as GHC usually does but this is likely
-- faster.
-intBS :: Int -> ByteString
-intBS = BSL.toStrict . BSB.toLazyByteString . BSB.wordHex . fromIntegral
+word64BS :: Word64 -> ByteString
+word64BS = BSL.toStrict . BSB.toLazyByteString . BSB.word64Hex
-- | Return z-encoded unit:module
unitModuleStringZ :: Module -> ByteString
diff --git a/compiler/GHC/StgToJS/Types.hs b/compiler/GHC/StgToJS/Types.hs
index 908f1fc1bc0f5ba509ca0b856f289413d2efa04d..415d1b159fe0d9c3d1859f3fdbcab42b74debbc4 100644
--- a/compiler/GHC/StgToJS/Types.hs
+++ b/compiler/GHC/StgToJS/Types.hs
@@ -47,6 +47,7 @@ import qualified Data.Map as M
import Data.Set (Set)
import qualified Data.ByteString as BS
import Data.Monoid
+import Data.Word
-- | A State monad over IO holding the generator state.
type G = StateT GenState IO
@@ -190,7 +191,7 @@ data IdType
-- | Keys to differentiate Ident's in the ID Cache
data IdKey
- = IdKey !Int !Int !IdType
+ = IdKey !Word64 !Int !IdType
deriving (Eq, Ord)
-- | Some other symbol
diff --git a/compiler/GHC/Tc/Deriv/Utils.hs b/compiler/GHC/Tc/Deriv/Utils.hs
index 6e754c11b6f0f4080089eb84abc4aa9361c8210c..a5fe83097dbb7de87400077506e4cdee0e4e675a 100644
--- a/compiler/GHC/Tc/Deriv/Utils.hs
+++ b/compiler/GHC/Tc/Deriv/Utils.hs
@@ -66,6 +66,7 @@ import GHC.Builtin.Names.TH (liftClassKey)
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Error
+import GHC.Utils.Unique (sameUnique)
import Control.Monad.Trans.Reader
import Data.Foldable (traverse_)
@@ -893,37 +894,37 @@ classArgsErr cls cls_tys = DerivErrNotAClass (mkClassPred cls cls_tys)
-- class for which stock deriving isn't possible.
stockSideConditions :: DerivContext -> Class -> Maybe Condition
stockSideConditions deriv_ctxt cls
- | cls_key == eqClassKey = Just (cond_std `andCond` cond_args cls)
- | cls_key == ordClassKey = Just (cond_std `andCond` cond_args cls)
- | cls_key == showClassKey = Just (cond_std `andCond` cond_args cls)
- | cls_key == readClassKey = Just (cond_std `andCond` cond_args cls)
- | cls_key == enumClassKey = Just (cond_std `andCond` cond_isEnumeration)
- | cls_key == ixClassKey = Just (cond_std `andCond` cond_enumOrProduct cls)
- | cls_key == boundedClassKey = Just (cond_std `andCond` cond_enumOrProduct cls)
- | cls_key == dataClassKey = Just (checkFlag LangExt.DeriveDataTypeable `andCond`
- cond_vanilla `andCond`
- cond_args cls)
- | cls_key == functorClassKey = Just (checkFlag LangExt.DeriveFunctor `andCond`
- cond_vanilla `andCond`
- cond_functorOK True False)
- | cls_key == foldableClassKey = Just (checkFlag LangExt.DeriveFoldable `andCond`
- cond_vanilla `andCond`
- cond_functorOK False True)
- -- Functor/Fold/Trav works ok
- -- for rank-n types
- | cls_key == traversableClassKey = Just (checkFlag LangExt.DeriveTraversable `andCond`
- cond_vanilla `andCond`
- cond_functorOK False False)
- | cls_key == genClassKey = Just (checkFlag LangExt.DeriveGeneric `andCond`
- cond_vanilla `andCond`
- cond_RepresentableOk)
- | cls_key == gen1ClassKey = Just (checkFlag LangExt.DeriveGeneric `andCond`
- cond_vanilla `andCond`
- cond_Representable1Ok)
- | cls_key == liftClassKey = Just (checkFlag LangExt.DeriveLift `andCond`
- cond_vanilla `andCond`
- cond_args cls)
- | otherwise = Nothing
+ | sameUnique cls_key eqClassKey = Just (cond_std `andCond` cond_args cls)
+ | sameUnique cls_key ordClassKey = Just (cond_std `andCond` cond_args cls)
+ | sameUnique cls_key showClassKey = Just (cond_std `andCond` cond_args cls)
+ | sameUnique cls_key readClassKey = Just (cond_std `andCond` cond_args cls)
+ | sameUnique cls_key enumClassKey = Just (cond_std `andCond` cond_isEnumeration)
+ | sameUnique cls_key ixClassKey = Just (cond_std `andCond` cond_enumOrProduct cls)
+ | sameUnique cls_key boundedClassKey = Just (cond_std `andCond` cond_enumOrProduct cls)
+ | sameUnique cls_key dataClassKey = Just (checkFlag LangExt.DeriveDataTypeable `andCond`
+ cond_vanilla `andCond`
+ cond_args cls)
+ | sameUnique cls_key functorClassKey = Just (checkFlag LangExt.DeriveFunctor `andCond`
+ cond_vanilla `andCond`
+ cond_functorOK True False)
+ | sameUnique cls_key foldableClassKey = Just (checkFlag LangExt.DeriveFoldable `andCond`
+ cond_vanilla `andCond`
+ cond_functorOK False True)
+ -- Functor/Fold/Trav works ok
+ -- for rank-n types
+ | sameUnique cls_key traversableClassKey = Just (checkFlag LangExt.DeriveTraversable `andCond`
+ cond_vanilla `andCond`
+ cond_functorOK False False)
+ | sameUnique cls_key genClassKey = Just (checkFlag LangExt.DeriveGeneric `andCond`
+ cond_vanilla `andCond`
+ cond_RepresentableOk)
+ | sameUnique cls_key gen1ClassKey = Just (checkFlag LangExt.DeriveGeneric `andCond`
+ cond_vanilla `andCond`
+ cond_Representable1Ok)
+ | sameUnique cls_key liftClassKey = Just (checkFlag LangExt.DeriveLift `andCond`
+ cond_vanilla `andCond`
+ cond_args cls)
+ | otherwise = Nothing
where
cls_key = getUnique cls
cond_std = cond_stdOK deriv_ctxt False
diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs
index 2b20416f0e1c023ad504d1d4663e6eaac30b9205..fbf34a6689afc3f2b58ecc0b4ae8c9372a6e5059 100644
--- a/compiler/GHC/Tc/Gen/Foreign.hs
+++ b/compiler/GHC/Tc/Gen/Foreign.hs
@@ -71,6 +71,7 @@ import GHC.Driver.Backend
import GHC.Utils.Error
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
+import GHC.Utils.Unique
import GHC.Platform
import GHC.Data.Bag
@@ -741,16 +742,16 @@ marshalableTyCon dflags tc
boxedMarshalableTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason
boxedMarshalableTyCon tc
- | getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey
- , int32TyConKey, int64TyConKey
- , wordTyConKey, word8TyConKey, word16TyConKey
- , word32TyConKey, word64TyConKey
- , floatTyConKey, doubleTyConKey
- , ptrTyConKey, funPtrTyConKey
- , charTyConKey
- , stablePtrTyConKey
- , boolTyConKey
- ]
+ | anyOfUnique tc [ intTyConKey, int8TyConKey, int16TyConKey
+ , int32TyConKey, int64TyConKey
+ , wordTyConKey, word8TyConKey, word16TyConKey
+ , word32TyConKey, word64TyConKey
+ , floatTyConKey, doubleTyConKey
+ , ptrTyConKey, funPtrTyConKey
+ , charTyConKey
+ , stablePtrTyConKey
+ , boolTyConKey
+ ]
= IsValid
| otherwise = NotValid NotABoxedMarshalableTyCon
diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs
index a93c7e03985501f3a5318467e0e3c4c8b6fc9de3..c1ba3bee373368d3de10f647f4bda9820bf932fc 100644
--- a/compiler/GHC/Tc/Types.hs
+++ b/compiler/GHC/Tc/Types.hs
@@ -244,7 +244,7 @@ data Env gbl lcl
-- Includes all info about imported things
-- BangPattern is to fix leak, see #15111
- env_um :: {-# UNPACK #-} !Char, -- Mask for Uniques
+ env_ut :: {-# UNPACK #-} !Char, -- Tag for Uniques
env_gbl :: gbl, -- Info about things defined at the top level
-- of the module being compiled
diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs
index 18248e84d55dff28ffd4e68b527b8c734e62b229..97f66cc800f8f505fad3a69da3d790ec37be84a1 100644
--- a/compiler/GHC/Tc/Types/Origin.hs
+++ b/compiler/GHC/Tc/Types/Origin.hs
@@ -322,7 +322,7 @@ unkSkolAnon = UnkSkol callStack
-- shares a certain 'Unique'.
mkSkolemInfo :: MonadIO m => SkolemInfoAnon -> m SkolemInfo
mkSkolemInfo sk_anon = do
- u <- liftIO $! uniqFromMask 's'
+ u <- liftIO $! uniqFromTag 's'
return (SkolemInfo u sk_anon)
getSkolemInfo :: SkolemInfo -> SkolemInfoAnon
diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs
index e2b25da1e9a1ddf4eabb807e95628344108ab293..7c06ba7fc87037d9b852fe526a42dc03af1ae16a 100644
--- a/compiler/GHC/Tc/Utils/Instantiate.hs
+++ b/compiler/GHC/Tc/Utils/Instantiate.hs
@@ -89,6 +89,7 @@ import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Outputable
+import GHC.Utils.Unique (sameUnique)
import GHC.Unit.State
import GHC.Unit.External
@@ -791,17 +792,17 @@ hasFixedRuntimeRepRes std_nm user_expr ty = mapM_ do_check mb_arity
in hasFixedRuntimeRep_syntactic (FRRArrow $ ArrowFun user_expr) res_ty
mb_arity :: Maybe Arity
mb_arity -- arity of the arrow operation, counting type-level arguments
- | std_nm == arrAName -- result used as an argument in, e.g., do_premap
+ | sameUnique std_nm arrAName -- result used as an argument in, e.g., do_premap
= Just 3
- | std_nm == composeAName -- result used as an argument in, e.g., dsCmdStmt/BodyStmt
+ | sameUnique std_nm composeAName -- result used as an argument in, e.g., dsCmdStmt/BodyStmt
= Just 5
- | std_nm == firstAName -- result used as an argument in, e.g., dsCmdStmt/BodyStmt
+ | sameUnique std_nm firstAName -- result used as an argument in, e.g., dsCmdStmt/BodyStmt
= Just 4
- | std_nm == appAName -- result used as an argument in, e.g., dsCmd/HsCmdArrApp/HsHigherOrderApp
+ | sameUnique std_nm appAName -- result used as an argument in, e.g., dsCmd/HsCmdArrApp/HsHigherOrderApp
= Just 2
- | std_nm == choiceAName -- result used as an argument in, e.g., HsCmdIf
+ | sameUnique std_nm choiceAName -- result used as an argument in, e.g., HsCmdIf
= Just 5
- | std_nm == loopAName -- result used as an argument in, e.g., HsCmdIf
+ | sameUnique std_nm loopAName -- result used as an argument in, e.g., HsCmdIf
= Just 4
| otherwise
= Nothing
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index 2dd212b95742541f7922eac7477a042ca9af07c1..ecc8bca4a3a3d7b02fccff41298bc5587c889d0e 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -453,14 +453,14 @@ an actual crash (attempting to look up the Integer type).
************************************************************************
-}
-initTcRnIf :: Char -- ^ Mask for unique supply
+initTcRnIf :: Char -- ^ Tag for unique supply
-> HscEnv
-> gbl -> lcl
-> TcRnIf gbl lcl a
-> IO a
-initTcRnIf uniq_mask hsc_env gbl_env lcl_env thing_inside
+initTcRnIf uniq_tag hsc_env gbl_env lcl_env thing_inside
= do { let { env = Env { env_top = hsc_env,
- env_um = uniq_mask,
+ env_ut = uniq_tag,
env_gbl = gbl_env,
env_lcl = lcl_env} }
@@ -716,14 +716,14 @@ escapeArrowScope
newUnique :: TcRnIf gbl lcl Unique
newUnique
= do { env <- getEnv
- ; let mask = env_um env
- ; liftIO $! uniqFromMask mask }
+ ; let tag = env_ut env
+ ; liftIO $! uniqFromTag tag }
newUniqueSupply :: TcRnIf gbl lcl UniqSupply
newUniqueSupply
= do { env <- getEnv
- ; let mask = env_um env
- ; liftIO $! mkSplitUniqSupply mask }
+ ; let tag = env_ut env
+ ; liftIO $! mkSplitUniqSupply tag }
cloneLocalName :: Name -> TcM Name
-- Make a fresh Internal name with the same OccName and SrcSpan
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 812aa2ea89cb63f352290c37634c6f0e25eaae85..25ddebeebc47cdf9794b7d0b41d703b88c0a0969 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -64,6 +64,7 @@ import Data.Foldable (for_)
import Data.List.NonEmpty( NonEmpty (..), nonEmpty )
import qualified Data.List.NonEmpty as NE
import Data.Maybe( catMaybes, isNothing )
+import Data.Word (Word64)
import Language.Haskell.TH as TH hiding (sigP)
import Language.Haskell.TH.Syntax as TH
import Foreign.ForeignPtr
@@ -2199,7 +2200,7 @@ mk_mod mod = mkModuleName (TH.modString mod)
mk_pkg :: TH.PkgName -> Unit
mk_pkg pkg = stringToUnit (TH.pkgString pkg)
-mk_uniq :: Int -> Unique
+mk_uniq :: Word64 -> Unique
mk_uniq u = mkUniqueGrimily u
{-
diff --git a/compiler/GHC/Types/Name/Cache.hs b/compiler/GHC/Types/Name/Cache.hs
index ef25b25f803a3aa89727c031fed35de87870719d..82756b887c91f78eb6d0de41f5475bd5d494662a 100644
--- a/compiler/GHC/Types/Name/Cache.hs
+++ b/compiler/GHC/Types/Name/Cache.hs
@@ -100,7 +100,7 @@ data NameCache = NameCache
type OrigNameCache = ModuleEnv (OccEnv Name)
takeUniqFromNameCache :: NameCache -> IO Unique
-takeUniqFromNameCache (NameCache c _) = uniqFromMask c
+takeUniqFromNameCache (NameCache c _) = uniqFromTag c
lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name
lookupOrigNameCache nc mod occ
diff --git a/compiler/GHC/Types/Unique.hs b/compiler/GHC/Types/Unique.hs
index c17d080f6f88e2b77914e95ff475d047f81923ef..3286740fc063608bab72174eb239fcfe50936955 100644
--- a/compiler/GHC/Types/Unique.hs
+++ b/compiler/GHC/Types/Unique.hs
@@ -30,9 +30,12 @@ module GHC.Types.Unique (
pprUniqueAlways,
+ mkTag,
mkUniqueGrimily,
+ mkUniqueIntGrimily,
getKey,
mkUnique, unpkUnique,
+ mkUniqueInt,
eqUnique, ltUnique,
incrUnique, stepUnique,
@@ -52,11 +55,12 @@ import GHC.Prelude
import GHC.Data.FastString
import GHC.Utils.Outputable
-import GHC.Utils.Panic.Plain
+import GHC.Utils.Word64 (intToWord64, word64ToInt)
-- just for implementing a fast [0,61) -> Char function
import GHC.Exts (indexCharOffAddr#, Char(..), Int(..))
+import GHC.Word ( Word64 )
import Data.Char ( chr, ord )
import Language.Haskell.Syntax.Module.Name
@@ -68,19 +72,19 @@ import Language.Haskell.Syntax.Module.Name
* *
************************************************************************
-Note [Uniques and masks]
+Note [Uniques and tags]
~~~~~~~~~~~~~~~~~~~~~~~~
-A `Unique` in GHC is a Word-sized value composed of two pieces:
-* A "mask", of width `UNIQUE_TAG_BITS`, in the high order bits
-* A number, of width `uNIQUE_BITS`, which fills up the remainder of the Word
+A `Unique` in GHC is a 64 bit value composed of two pieces:
+* A "tag", of width `UNIQUE_TAG_BITS`, in the high order bits
+* A number, of width `uNIQUE_BITS`, which fills up the remainder of the Word64
-The mask is typically an ASCII character. It is typically used to make it easier
+The tag is typically an ASCII character. It is typically used to make it easier
to distinguish uniques constructed by different parts of the compiler.
-There is a (potentially incomplete) list of unique masks used given in
-GHC.Builtin.Uniques. See Note [Uniques for wired-in prelude things and known masks]
+There is a (potentially incomplete) list of unique tags used given in
+GHC.Builtin.Uniques. See Note [Uniques for wired-in prelude things and known tags]
`mkUnique` constructs a `Unique` from its pieces
- mkUnique :: Char -> Int -> Unique
+ mkUnique :: Char -> Word64 -> Unique
-}
@@ -91,24 +95,24 @@ GHC.Builtin.Uniques. See Note [Uniques for wired-in prelude things and known mas
-- the functions from the 'UniqSupply' module
--
-- These are sometimes also referred to as \"keys\" in comments in GHC.
-newtype Unique = MkUnique Int
+newtype Unique = MkUnique Word64
{-# INLINE uNIQUE_BITS #-}
uNIQUE_BITS :: Int
-uNIQUE_BITS = finiteBitSize (0 :: Int) - UNIQUE_TAG_BITS
+uNIQUE_BITS = 64 - UNIQUE_TAG_BITS
{-
Now come the functions which construct uniques from their pieces, and vice versa.
The stuff about unique *supplies* is handled further down this module.
-}
-unpkUnique :: Unique -> (Char, Int) -- The reverse
+unpkUnique :: Unique -> (Char, Word64) -- The reverse
-mkUniqueGrimily :: Int -> Unique -- A trap-door for UniqSupply
-getKey :: Unique -> Int -- for Var
+mkUniqueGrimily :: Word64 -> Unique -- A trap-door for UniqSupply
+getKey :: Unique -> Word64 -- for Var
incrUnique :: Unique -> Unique
-stepUnique :: Unique -> Int -> Unique
+stepUnique :: Unique -> Word64 -> Unique
newTagUnique :: Unique -> Char -> Unique
mkUniqueGrimily = MkUnique
@@ -119,7 +123,7 @@ getKey (MkUnique x) = x
incrUnique (MkUnique i) = MkUnique (i + 1)
stepUnique (MkUnique i) n = MkUnique (i + n)
-mkLocalUnique :: Int -> Unique
+mkLocalUnique :: Word64 -> Unique
mkLocalUnique i = mkUnique 'X' i
minLocalUnique :: Unique
@@ -131,30 +135,42 @@ maxLocalUnique = mkLocalUnique uniqueMask
-- newTagUnique changes the "domain" of a unique to a different char
newTagUnique u c = mkUnique c i where (_,i) = unpkUnique u
--- | How many bits are devoted to the unique index (as opposed to the class
--- character).
-uniqueMask :: Int
+-- | Bitmask that has zeros for the tag bits and ones for the rest.
+uniqueMask :: Word64
uniqueMask = (1 `shiftL` uNIQUE_BITS) - 1
+-- | Put the character in the highest bits of the Word64.
+-- This may truncate the character to UNIQUE_TAG_BITS.
+-- This function is used in @`mkSplitUniqSupply`@ so that it can
+-- precompute and share the tag part of the uniques it generates.
+mkTag :: Char -> Word64
+mkTag c = intToWord64 (ord c) `shiftL` uNIQUE_BITS
+
-- pop the Char in the top 8 bits of the Unique(Supply)
-- No 64-bit bugs here, as long as we have at least 32 bits. --JSM
-- and as long as the Char fits in 8 bits, which we assume anyway!
-mkUnique :: Char -> Int -> Unique -- Builds a unique from pieces
+mkUnique :: Char -> Word64 -> Unique -- Builds a unique from pieces
-- EXPORTED and used only in GHC.Builtin.Uniques
mkUnique c i
= MkUnique (tag .|. bits)
where
- tag = ord c `shiftL` uNIQUE_BITS
+ tag = mkTag c
bits = i .&. uniqueMask
+mkUniqueInt :: Char -> Int -> Unique
+mkUniqueInt c i = mkUnique c (intToWord64 i)
+
+mkUniqueIntGrimily :: Int -> Unique
+mkUniqueIntGrimily = MkUnique . intToWord64
+
unpkUnique (MkUnique u)
= let
- -- as long as the Char may have its eighth bit set, we
- -- really do need the logical right-shift here!
- tag = chr (u `shiftR` uNIQUE_BITS)
+ -- The potentially truncating use of fromIntegral here is safe
+ -- because the argument is just the tag bits after shifting.
+ tag = chr (word64ToInt (u `shiftR` uNIQUE_BITS))
i = u .&. uniqueMask
in
(tag, i)
@@ -184,10 +200,10 @@ hasKey :: Uniquable a => a -> Unique -> Bool
x `hasKey` k = getUnique x == k
instance Uniquable FastString where
- getUnique fs = mkUniqueGrimily (uniqueOfFS fs)
+ getUnique fs = mkUniqueIntGrimily (uniqueOfFS fs)
instance Uniquable Int where
- getUnique i = mkUniqueGrimily i
+ getUnique i = mkUniqueIntGrimily i
instance Uniquable ModuleName where
getUnique (ModuleName nm) = getUnique nm
@@ -261,7 +277,7 @@ The alternatives are:
1) Use UniqFM or UniqDFM, see Note [Deterministic UniqFM] to decide which
2) Create a newtype wrapper based on Unique ordering where nondeterminism
- is controlled. See Module.ModuleEnv
+ is controlled. See GHC.Unit.Module.Env.ModuleEnv
3) Change the algorithm to use nonDetCmpUnique and document why it's still
deterministic
4) Use TrieMap as done in GHC.Cmm.CommonBlockElim.groupByLabel
@@ -279,7 +295,7 @@ instance Uniquable Unique where
showUnique :: Unique -> String
showUnique uniq
= case unpkUnique uniq of
- (tag, u) -> tag : iToBase62 u
+ (tag, u) -> tag : w64ToBase62 u
pprUniqueAlways :: IsLine doc => Unique -> doc
-- The "always" means regardless of -dsuppress-uniques
@@ -305,19 +321,20 @@ instance Show Unique where
************************************************************************
A character-stingy way to read/write numbers (notably Uniques).
-The ``62-its'' are \tr{[0-9a-zA-Z]}. We don't handle negative Ints.
+The ``62-its'' are \tr{[0-9a-zA-Z]}.
Code stolen from Lennart.
-}
-iToBase62 :: Int -> String
-iToBase62 n_
- = assert (n_ >= 0) $ go n_ ""
+w64ToBase62 :: Word64 -> String
+w64ToBase62 n_ = go n_ ""
where
+ -- The potentially truncating uses of fromIntegral here are safe
+ -- because the argument is guaranteed to be less than 62 in both cases.
go n cs | n < 62
- = let !c = chooseChar62 n in c : cs
+ = let !c = chooseChar62 (word64ToInt n) in c : cs
| otherwise
= go q (c : cs) where (!q, r) = quotRem n 62
- !c = chooseChar62 r
+ !c = chooseChar62 (word64ToInt r)
chooseChar62 :: Int -> Char
{-# INLINE chooseChar62 #-}
diff --git a/compiler/GHC/Types/Unique/DFM.hs b/compiler/GHC/Types/Unique/DFM.hs
index d590f90a285d95c3161f6120a32bc0ed9cac014e..48065823d7b4958e4ad4a70f41ec6f5260687ab9 100644
--- a/compiler/GHC/Types/Unique/DFM.hs
+++ b/compiler/GHC/Types/Unique/DFM.hs
@@ -71,18 +71,18 @@ module GHC.Types.Unique.DFM (
import GHC.Prelude
-import GHC.Types.Unique ( Uniquable(..), Unique, getKey )
+import GHC.Types.Unique ( Uniquable(..), Unique, getKey, mkUniqueGrimily )
import GHC.Utils.Outputable
-import qualified Data.IntMap.Strict as MS
-import qualified Data.IntMap as M
+import qualified GHC.Data.Word64Map.Strict as MS
+import qualified GHC.Data.Word64Map as M
import Data.Data
import Data.Functor.Classes (Eq1 (..))
import Data.List (sortBy)
import Data.Function (on)
import GHC.Types.Unique.FM (UniqFM, nonDetUFMToList, ufmToIntMap, unsafeIntMapToUFM)
import Unsafe.Coerce
-import qualified Data.IntSet as I
+import qualified GHC.Data.Word64Set as W
-- Note [Deterministic UniqFM]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -147,7 +147,7 @@ instance Eq val => Eq (TaggedVal val) where
-- very much discouraged.
data UniqDFM key ele =
UDFM
- !(M.IntMap (TaggedVal ele)) -- A map where keys are Unique's values and
+ !(M.Word64Map (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
@@ -290,6 +290,8 @@ 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 key elt -> a
+{-# INLINE foldUDFM #-}
+-- This INLINE prevents a regression in !10568
foldUDFM k z m = foldr k z (eltsUDFM m)
-- | Performs a nondeterministic strict fold over the UniqDFM.
@@ -306,7 +308,7 @@ eltsUDFM :: UniqDFM key elt -> [elt]
-- The INLINE makes it a good producer (from the map)
eltsUDFM (UDFM m _i) = map taggedFst (sort_it m)
-sort_it :: M.IntMap (TaggedVal elt) -> [TaggedVal elt]
+sort_it :: M.Word64Map (TaggedVal elt) -> [TaggedVal elt]
sort_it m = sortBy (compare `on` taggedSnd) (M.elems m)
filterUDFM :: (elt -> Bool) -> UniqDFM key elt -> UniqDFM key elt
@@ -315,12 +317,12 @@ filterUDFM p (UDFM m i) = UDFM (M.filter (\(TaggedVal v _) -> p v) m) i
filterUDFM_Directly :: (Unique -> elt -> Bool) -> UniqDFM key elt -> UniqDFM key elt
filterUDFM_Directly p (UDFM m i) = UDFM (M.filterWithKey p' m) i
where
- p' k (TaggedVal v _) = p (getUnique k) v
+ p' k (TaggedVal v _) = p (mkUniqueGrimily k) v
udfmRestrictKeys :: UniqDFM key elt -> UniqDFM key elt2 -> UniqDFM key elt
udfmRestrictKeys (UDFM a i) (UDFM b _) = UDFM (M.restrictKeys a (M.keysSet b)) i
-udfmRestrictKeysSet :: UniqDFM key elt -> I.IntSet -> UniqDFM key elt
+udfmRestrictKeysSet :: UniqDFM key elt -> W.Word64Set -> UniqDFM key elt
udfmRestrictKeysSet (UDFM val_set i) set =
let key_set = set
in UDFM (M.restrictKeys val_set key_set) i
@@ -329,7 +331,7 @@ udfmRestrictKeysSet (UDFM val_set i) set =
-- It's O(n log n) while the corresponding function on `UniqFM` is O(n).
udfmToList :: UniqDFM key elt -> [(Unique, elt)]
udfmToList (UDFM m _i) =
- [ (getUnique k, taggedFst v)
+ [ (mkUniqueGrimily k, taggedFst v)
| (k, v) <- sortBy (compare `on` (taggedSnd . snd)) $ M.toList m ]
-- Determines whether two 'UniqDFM's contain the same keys.
diff --git a/compiler/GHC/Types/Unique/FM.hs b/compiler/GHC/Types/Unique/FM.hs
index f610582a1a4d89e9b867295a8b3f1d4fa37cf71b..6b191c81043ee7a36a5b5cea5f438bf0cb4aabf2 100644
--- a/compiler/GHC/Types/Unique/FM.hs
+++ b/compiler/GHC/Types/Unique/FM.hs
@@ -86,12 +86,12 @@ module GHC.Types.Unique.FM (
import GHC.Prelude
-import GHC.Types.Unique ( Uniquable(..), Unique, getKey )
+import GHC.Types.Unique ( Uniquable(..), Unique, getKey, mkUniqueGrimily )
import GHC.Utils.Outputable
import GHC.Utils.Panic.Plain
-import qualified Data.IntMap as M
-import qualified Data.IntMap.Strict as MS
-import qualified Data.IntSet as S
+import qualified GHC.Data.Word64Map as M
+import qualified GHC.Data.Word64Map.Strict as MS
+import qualified GHC.Data.Word64Set as S
import Data.Data
import qualified Data.Semigroup as Semi
import Data.Functor.Classes (Eq1 (..))
@@ -105,7 +105,7 @@ import Data.Coerce
-- If two types don't overlap in their uniques it's also safe
-- to index the same map at multiple key types. But this is
-- very much discouraged.
-newtype UniqFM key ele = UFM (M.IntMap ele)
+newtype UniqFM key ele = UFM (M.Word64Map ele)
deriving (Data, Eq, Functor)
-- Nondeterministic Foldable and Traversable instances are accessible through
-- use of the 'NonDetUniqFM' wrapper.
@@ -379,7 +379,7 @@ nonDetFoldUFM f z (UFM m) = M.foldr f z m
nonDetFoldWithKeyUFM :: (Unique -> elt -> a -> a) -> a -> UniqFM key elt -> a
nonDetFoldWithKeyUFM f z (UFM m) = M.foldrWithKey f' z m
where
- f' k e a = f (getUnique k) e a
+ f' k e a = f (mkUniqueGrimily k) e a
mapUFM :: (elt1 -> elt2) -> UniqFM key elt1 -> UniqFM key elt2
mapUFM f (UFM m) = UFM (M.map f m)
@@ -388,10 +388,10 @@ mapMaybeUFM :: (elt1 -> Maybe elt2) -> UniqFM key elt1 -> UniqFM key elt2
mapMaybeUFM f (UFM m) = UFM (M.mapMaybe f m)
mapMaybeWithKeyUFM :: (Unique -> elt1 -> Maybe elt2) -> UniqFM key elt1 -> UniqFM key elt2
-mapMaybeWithKeyUFM f (UFM m) = UFM (M.mapMaybeWithKey (f . getUnique) m)
+mapMaybeWithKeyUFM f (UFM m) = UFM (M.mapMaybeWithKey (f . mkUniqueGrimily) m)
mapUFM_Directly :: (Unique -> elt1 -> elt2) -> UniqFM key elt1 -> UniqFM key elt2
-mapUFM_Directly f (UFM m) = UFM (M.mapWithKey (f . getUnique) m)
+mapUFM_Directly f (UFM m) = UFM (M.mapWithKey (f . mkUniqueGrimily) m)
strictMapUFM :: (a -> b) -> UniqFM k a -> UniqFM k b
strictMapUFM f (UFM a) = UFM $ MS.map f a
@@ -400,7 +400,7 @@ filterUFM :: (elt -> Bool) -> UniqFM key elt -> UniqFM key elt
filterUFM p (UFM m) = UFM (M.filter p m)
filterUFM_Directly :: (Unique -> elt -> Bool) -> UniqFM key elt -> UniqFM key elt
-filterUFM_Directly p (UFM m) = UFM (M.filterWithKey (p . getUnique) m)
+filterUFM_Directly p (UFM m) = UFM (M.filterWithKey (p . mkUniqueGrimily) m)
partitionUFM :: (elt -> Bool) -> UniqFM key elt -> (UniqFM key elt, UniqFM key elt)
partitionUFM p (UFM m) =
@@ -429,7 +429,7 @@ lookupWithDefaultUFM (UFM m) v k = M.findWithDefault v (getKey $ getUnique k) m
lookupWithDefaultUFM_Directly :: UniqFM key elt -> elt -> Unique -> elt
lookupWithDefaultUFM_Directly (UFM m) v u = M.findWithDefault v (getKey u) m
-ufmToSet_Directly :: UniqFM key elt -> S.IntSet
+ufmToSet_Directly :: UniqFM key elt -> S.Word64Set
ufmToSet_Directly (UFM m) = M.keysSet m
anyUFM :: (elt -> Bool) -> UniqFM key elt -> Bool
@@ -451,7 +451,7 @@ nonDetEltsUFM (UFM m) = M.elems m
-- If you use this please provide a justification why it doesn't introduce
-- nondeterminism.
nonDetKeysUFM :: UniqFM key elt -> [Unique]
-nonDetKeysUFM (UFM m) = map getUnique $ M.keys m
+nonDetKeysUFM (UFM m) = map mkUniqueGrimily $ M.keys m
-- See Note [Deterministic UniqFM] to learn about nondeterminism.
-- If you use this please provide a justification why it doesn't introduce
@@ -468,18 +468,18 @@ nonDetStrictFoldUFM k z (UFM m) = M.foldl' (flip k) z m
nonDetStrictFoldUFM_DirectlyM :: (Monad m) => (Unique -> b -> elt -> m b) -> b -> UniqFM key elt -> m b
nonDetStrictFoldUFM_DirectlyM f z0 (UFM xs) = M.foldrWithKey c return xs z0
-- See Note [List fusion and continuations in 'c']
- where c u x k z = f (getUnique u) z x >>= k
+ where c u x k z = f (mkUniqueGrimily u) z x >>= k
{-# INLINE c #-}
nonDetStrictFoldUFM_Directly:: (Unique -> elt -> a -> a) -> a -> UniqFM key elt -> a
-nonDetStrictFoldUFM_Directly k z (UFM m) = M.foldlWithKey' (\z' i x -> k (getUnique i) x z') z m
+nonDetStrictFoldUFM_Directly k z (UFM m) = M.foldlWithKey' (\z' i x -> k (mkUniqueGrimily i) x z') z m
{-# INLINE nonDetStrictFoldUFM_Directly #-}
-- See Note [Deterministic UniqFM] to learn about nondeterminism.
-- If you use this please provide a justification why it doesn't introduce
-- nondeterminism.
nonDetUFMToList :: UniqFM key elt -> [(Unique, elt)]
-nonDetUFMToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m
+nonDetUFMToList (UFM m) = map (\(k, v) -> (mkUniqueGrimily 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
@@ -504,10 +504,10 @@ instance forall key. Foldable (NonDetUniqFM key) where
instance forall key. Traversable (NonDetUniqFM key) where
traverse f (NonDetUniqFM (UFM m)) = NonDetUniqFM . UFM <$> traverse f m
-ufmToIntMap :: UniqFM key elt -> M.IntMap elt
+ufmToIntMap :: UniqFM key elt -> M.Word64Map elt
ufmToIntMap (UFM m) = m
-unsafeIntMapToUFM :: M.IntMap elt -> UniqFM key elt
+unsafeIntMapToUFM :: M.Word64Map elt -> UniqFM key elt
unsafeIntMapToUFM = UFM
-- | Cast the key domain of a UniqFM.
diff --git a/compiler/GHC/Types/Unique/Supply.hs b/compiler/GHC/Types/Unique/Supply.hs
index 0e8c562a5b7b0183a96ed9871c5be0c95acb14fc..c05b100c9d8b3c3a58103aec41a66d1656e0f2db 100644
--- a/compiler/GHC/Types/Unique/Supply.hs
+++ b/compiler/GHC/Types/Unique/Supply.hs
@@ -15,7 +15,7 @@ module GHC.Types.Unique.Supply (
-- ** Operations on supplies
uniqFromSupply, uniqsFromSupply, -- basic ops
- takeUniqFromSupply, uniqFromMask,
+ takeUniqFromSupply, uniqFromTag,
mkSplitUniqSupply,
splitUniqSupply, listSplitUniqSupply,
@@ -39,13 +39,20 @@ import GHC.IO
import GHC.Utils.Monad
import Control.Monad
-import Data.Char
+import Data.Word
import GHC.Exts( Ptr(..), noDuplicate#, oneShot )
-#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)
-import GHC.Exts( Int(..), word2Int#, fetchAddWordAddr#, plusWord#, readWordOffAddr# )
-#endif
import Foreign.Storable
+#include "MachDeps.h"
+
+#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0) && WORD_SIZE_IN_BITS == 64
+import GHC.Word( Word64(..) )
+import GHC.Exts( fetchAddWordAddr#, plusWord#, readWordOffAddr# )
+#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)
+import GHC.Exts( wordToWord64# )
+#endif
+#endif
+
#include "Unique.h"
{-
@@ -61,17 +68,17 @@ import Foreign.Storable
The basic idea (due to Lennart Augustsson) is that a UniqSupply is
lazily-evaluated infinite tree.
-* At each MkSplitUniqSupply node is a unique Int, and two
+* At each MkSplitUniqSupply node is a unique Word64, and two
sub-trees (see data UniqSupply)
* takeUniqFromSupply :: UniqSupply -> (Unique, UniqSupply)
- returns the unique Int and one of the sub-trees
+ returns the unique Word64 and one of the sub-trees
* splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply)
returns the two sub-trees
* When you poke on one of the thunks, it does a foreign call
- to get a fresh Int from a thread-safe counter, and returns
+ to get a fresh Word64 from a thread-safe counter, and returns
a fresh MkSplitUniqSupply node. This has to be as efficient
as possible: it should allocate only
* The fresh node
@@ -83,25 +90,25 @@ The general design (used throughout GHC) is to:
* For creating new uniques either a UniqSupply is used and threaded through
or for monadic code a MonadUnique instance might conjure up uniques using
- `uniqFromMask`.
+ `uniqFromTag`.
* Different parts of the compiler will use a UniqSupply or MonadUnique instance
- with a specific mask. This way the different parts of the compiler will
- generate uniques with different masks.
+ with a specific tag. This way the different parts of the compiler will
+ generate uniques with different tags.
-If different code shares the same mask then care has to be taken that all uniques
+If different code shares the same tag then care has to be taken that all uniques
still get distinct numbers. Usually this is done by relying on genSym which
has *one* counter per GHC invocation that is relied on by all calls to it.
But using something like the address for pinned objects works as well and in fact is done
for fast strings.
This is important for example in the simplifier. Most passes of the simplifier use
-the same mask 's'. However in some places we create a unique supply using `mkSplitUniqSupply`
+the same tag 's'. However in some places we create a unique supply using `mkSplitUniqSupply`
and thread it through the code, while in GHC.Core.Opt.Simplify.Monad we use the
`instance MonadUnique SimplM`, which uses `mkSplitUniqSupply` in getUniqueSupplyM
-and `uniqFromMask` in getUniqueM.
+and `uniqFromTag` in getUniqueM.
-Ultimately all these boil down to each new unique consisting of the mask and the result from
-a call to `genSym`. The later producing a distinct number for each invocation ensuring
+Ultimately all these boil down to each new unique consisting of the tag and the result from
+a call to `genSym`. The latter producing a distinct number for each invocation ensuring
uniques are distinct.
Note [Optimising the unique supply]
@@ -113,7 +120,7 @@ The inner loop of mkSplitUniqSupply is a function closure
case unIO genSym s1 of { (# s2, u #) ->
case unIO (unsafeDupableInterleaveIO (IO mk_supply)) s2 of { (# s3, x #) ->
case unIO (unsafeDupableInterleaveIO (IO mk_supply)) s3 of { (# s4, y #) ->
- (# s4, MkSplitUniqSupply (mask .|. u) x y #)
+ (# s4, MkSplitUniqSupply (tag .|. u) x y #)
}}}}
It's a classic example of an IO action that is captured and then called
@@ -127,7 +134,7 @@ We used to write it as:
genSym >>= \ u ->
mk_supply >>= \ s1 ->
mk_supply >>= \ s2 ->
- return (MkSplitUniqSupply (mask .|. u) s1 s2)
+ return (MkSplitUniqSupply (tag .|. u) s1 s2)
and to rely on -fno-state-hack, full laziness and inlining to get the same
result. It was very brittle and required enabling -fno-state-hack globally. So
@@ -146,29 +153,29 @@ The code for this is about as optimized as it gets, but we can't
get around the need to allocate one `UniqSupply` for each Unique
we need.
-For code in IO we can improve on this by threading only the *mask*
-we are going to use for Uniques. Using `uniqFromMask` to
+For code in IO we can improve on this by threading only the *tag*
+we are going to use for Uniques. Using `uniqFromTag` to
generate uniques as needed. This gets rid of the overhead of
allocating a new UniqSupply for each unique generated. It also avoids
-frequent state updates when the Unique/Mask is part of the state in a
+frequent state updates when the Unique/Tag is part of the state in a
state monad.
-For monadic code in IO which always uses the same mask we can go further
-and hardcode the mask into the MonadUnique instance. On top of all the
-benefits of threading the mask this *also* has the benefit of avoiding
-the mask getting captured in thunks, or being passed around at runtime.
-It does however come at the cost of having to use a fixed Mask for all
-code run in this Monad. But remember, the Mask is purely cosmetic:
-See Note [Uniques and masks].
+For monadic code in IO which always uses the same tag we can go further
+and hardcode the tag into the MonadUnique instance. On top of all the
+benefits of threading the tag this *also* has the benefit of avoiding
+the tag getting captured in thunks, or being passed around at runtime.
+It does however come at the cost of having to use a fixed tag for all
+code run in this Monad. But remember, the tag is purely cosmetic:
+See Note [Uniques and tags].
NB: It's *not* an optimization to pass around the UniqSupply inside an
-IORef instead of the mask. While this would avoid frequent state updates
+IORef instead of the tag. While this would avoid frequent state updates
it still requires allocating one UniqSupply per Unique. On top of some
overhead for reading/writing to/from the IORef.
All of this hinges on the assumption that UniqSupply and
-uniqFromMask use the same source of distinct numbers (`genSym`) which
-allows both to be used at the same time, with the same mask, while still
+uniqFromTag use the same source of distinct numbers (`genSym`) which
+allows both to be used at the same time, with the same tag, while still
ensuring distinct uniques.
One might consider this fact to be an "accident". But GHC worked like this
as far back as source control history goes. It also allows the later two
@@ -184,18 +191,18 @@ optimizations to be used. So it seems safe to depend on this fact.
-- 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
+ = MkSplitUniqSupply {-# UNPACK #-} !Word64 -- 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 "mask" (Char) supplied is purely cosmetic, making it easier
+-- The "tag" (Char) supplied is purely cosmetic, making it easier
-- to figure out where a Unique was born. See
--- Note [Uniques and masks].
+-- Note [Uniques and tags].
--
-- The payload part of the Uniques allocated from this UniqSupply are
--- guaranteed distinct wrt all other supplies, regardless of their "mask".
+-- guaranteed distinct wrt all other supplies, regardless of their "tag".
-- This is achieved by allocating the payload part from
-- a single source of Uniques, namely `genSym`, shared across
-- all UniqSupply's.
@@ -206,7 +213,7 @@ mkSplitUniqSupply c
= unsafeDupableInterleaveIO (IO mk_supply)
where
- !mask = ord c `unsafeShiftL` uNIQUE_BITS
+ !tag = mkTag c
-- Here comes THE MAGIC: see Note [How the unique supply works]
-- This is one of the most hammered bits in the whole compiler
@@ -218,21 +225,28 @@ mkSplitUniqSupply c
-- deferred IO computations
case unIO (unsafeDupableInterleaveIO (IO mk_supply)) s2 of { (# s3, x #) ->
case unIO (unsafeDupableInterleaveIO (IO mk_supply)) s3 of { (# s4, y #) ->
- (# s4, MkSplitUniqSupply (mask .|. u) x y #)
+ (# s4, MkSplitUniqSupply (tag .|. u) x y #)
}}}}
-#if !MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)
-foreign import ccall unsafe "genSym" genSym :: IO Int
+-- If a word is not 64 bits then we would need a fetchAddWord64Addr# primitive,
+-- which does not exist. So we fall back on the C implementation in that case.
+
+#if !MIN_VERSION_GLASGOW_HASKELL(9,1,0,0) || WORD_SIZE_IN_BITS != 64
+foreign import ccall unsafe "genSym" genSym :: IO Word64
#else
-genSym :: IO Int
+genSym :: IO Word64
genSym = do
let !mask = (1 `unsafeShiftL` uNIQUE_BITS) - 1
- let !(Ptr counter) = ghc_unique_counter
+ let !(Ptr counter) = ghc_unique_counter64
let !(Ptr inc_ptr) = ghc_unique_inc
u <- IO $ \s0 -> case readWordOffAddr# inc_ptr 0# s0 of
(# s1, inc #) -> case fetchAddWordAddr# counter inc s1 of
(# s2, val #) ->
- let !u = I# (word2Int# (val `plusWord#` inc)) .&. mask
+#if !MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)
+ let !u = W64# (val `plusWord#` inc) .&. mask
+#else
+ let !u = W64# (wordToWord64# (val `plusWord#` inc)) .&. mask
+#endif
in (# s2, u #)
#if defined(DEBUG)
-- Uh oh! We will overflow next time a unique is requested.
@@ -242,19 +256,19 @@ genSym = do
return u
#endif
-foreign import ccall unsafe "&ghc_unique_counter" ghc_unique_counter :: Ptr Word
-foreign import ccall unsafe "&ghc_unique_inc" ghc_unique_inc :: Ptr Int
+foreign import ccall unsafe "&ghc_unique_counter64" ghc_unique_counter64 :: Ptr Word64
+foreign import ccall unsafe "&ghc_unique_inc" ghc_unique_inc :: Ptr Int
-initUniqSupply :: Word -> Int -> IO ()
+initUniqSupply :: Word64 -> Int -> IO ()
initUniqSupply counter inc = do
- poke ghc_unique_counter counter
- poke ghc_unique_inc inc
+ poke ghc_unique_counter64 counter
+ poke ghc_unique_inc inc
-uniqFromMask :: Char -> IO Unique
-uniqFromMask !mask
+uniqFromTag :: Char -> IO Unique
+uniqFromTag !tag
= do { uqNum <- genSym
- ; return $! mkUnique mask uqNum }
-{-# NOINLINE uniqFromMask #-} -- We'll unbox everything, but we don't want to inline it
+ ; return $! mkUnique tag uqNum }
+{-# NOINLINE uniqFromTag #-} -- We'll unbox everything, but we don't want to inline it
splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply)
-- ^ Build two 'UniqSupply' from a single one, each of which
diff --git a/compiler/GHC/Types/Var.hs b/compiler/GHC/Types/Var.hs
index e95abc0855c2872dd25eb61591e2f936d78a7831..0471688aa6771a5f51aad4c7e9b1dc71adc83391 100644
--- a/compiler/GHC/Types/Var.hs
+++ b/compiler/GHC/Types/Var.hs
@@ -117,7 +117,7 @@ import {-# SOURCE #-} GHC.Types.Id.Info( IdDetails, IdInfo, coVarDetails, isCo
import {-# SOURCE #-} GHC.Builtin.Types ( manyDataConTy )
import GHC.Types.Name hiding (varName)
import GHC.Types.Unique ( Uniquable, Unique, getKey, getUnique
- , mkUniqueGrimily, nonDetCmpUnique )
+ , nonDetCmpUnique )
import GHC.Types.Basic( TypeOrConstraint(..) )
import GHC.Utils.Misc
import GHC.Utils.Binary
@@ -247,7 +247,7 @@ data Var
= TyVar { -- Type and kind variables
-- see Note [Kind and type variables]
varName :: !Name,
- realUnique :: {-# UNPACK #-} !Int,
+ realUnique :: {-# UNPACK #-} !Unique,
-- ^ Key for fast comparison
-- Identical to the Unique in the name,
-- cached here for speed
@@ -258,14 +258,14 @@ data Var
-- Used for kind variables during
-- inference, as well
varName :: !Name,
- realUnique :: {-# UNPACK #-} !Int,
+ realUnique :: {-# UNPACK #-} !Unique,
varType :: Kind,
tc_tv_details :: TcTyVarDetails
}
| Id {
varName :: !Name,
- realUnique :: {-# UNPACK #-} !Int,
+ realUnique :: {-# UNPACK #-} !Unique,
varType :: Type,
varMult :: Mult, -- See Note [Multiplicity of let binders]
idScope :: IdScope,
@@ -374,10 +374,10 @@ instance Eq Var where
a == b = realUnique a == realUnique b
instance Ord Var where
- a <= b = realUnique a <= realUnique b
- a < b = realUnique a < realUnique b
- a >= b = realUnique a >= realUnique b
- a > b = realUnique a > realUnique b
+ a <= b = getKey (realUnique a) <= getKey (realUnique b)
+ a < b = getKey (realUnique a) < getKey (realUnique b)
+ a >= b = getKey (realUnique a) >= getKey (realUnique b)
+ a > b = getKey (realUnique a) > getKey (realUnique b)
a `compare` b = a `nonDetCmpVar` b
-- | Compare Vars by their Uniques.
@@ -397,7 +397,7 @@ instance HasOccName Var where
occName = nameOccName . varName
varUnique :: Var -> Unique
-varUnique var = mkUniqueGrimily (realUnique var)
+varUnique var = realUnique var
varMultMaybe :: Id -> Maybe Mult
varMultMaybe (Id { varMult = mult }) = Just mult
@@ -405,12 +405,12 @@ varMultMaybe _ = Nothing
setVarUnique :: Var -> Unique -> Var
setVarUnique var uniq
- = var { realUnique = getKey uniq,
+ = var { realUnique = uniq,
varName = setNameUnique (varName var) uniq }
setVarName :: Var -> Name -> Var
setVarName var new_name
- = var { realUnique = getKey (getUnique new_name),
+ = var { realUnique = getUnique new_name,
varName = new_name }
setVarType :: Var -> Type -> Var
@@ -1074,7 +1074,7 @@ updateTyVarKindM update tv
mkTyVar :: Name -> Kind -> TyVar
mkTyVar name kind = TyVar { varName = name
- , realUnique = getKey (nameUnique name)
+ , realUnique = nameUnique name
, varType = kind
}
@@ -1082,7 +1082,7 @@ mkTcTyVar :: Name -> Kind -> TcTyVarDetails -> TyVar
mkTcTyVar name kind details
= -- NB: 'kind' may be a coercion kind; cf, 'GHC.Tc.Utils.TcMType.newMetaCoVar'
TcTyVar { varName = name,
- realUnique = getKey (nameUnique name),
+ realUnique = nameUnique name,
varType = kind,
tc_tv_details = details
}
@@ -1138,7 +1138,7 @@ mkExportedLocalVar details name ty info
mk_id :: Name -> Mult -> Type -> IdScope -> IdDetails -> IdInfo -> Id
mk_id name !w ty scope details info
= Id { varName = name,
- realUnique = getKey (nameUnique name),
+ realUnique = nameUnique name,
varMult = w,
varType = ty,
idScope = scope,
diff --git a/compiler/GHC/Types/Var/Env.hs b/compiler/GHC/Types/Var/Env.hs
index 59bd1dbf567970df085a67a00e8922fb18402063..66a63e1b8de91ae168890138e94ee30758958cc5 100644
--- a/compiler/GHC/Types/Var/Env.hs
+++ b/compiler/GHC/Types/Var/Env.hs
@@ -78,7 +78,7 @@ module GHC.Types.Var.Env (
) where
import GHC.Prelude
-import qualified Data.IntMap.Strict as IntMap -- TODO: Move this to UniqFM
+import qualified GHC.Data.Word64Map.Strict as Word64Map -- TODO: Move this to UniqFM
import GHC.Types.Name.Occurrence
import GHC.Types.Name
@@ -228,7 +228,7 @@ uniqAway' in_scope var
-- introduce non-unique 'Unique's this way. See Note [Local uniques].
unsafeGetFreshLocalUnique :: InScopeSet -> Unique
unsafeGetFreshLocalUnique (InScope set)
- | Just (uniq,_) <- IntMap.lookupLT (getKey maxLocalUnique) (ufmToIntMap $ getUniqSet set)
+ | Just (uniq,_) <- Word64Map.lookupLT (getKey maxLocalUnique) (ufmToIntMap $ getUniqSet set)
, let uniq' = mkLocalUnique uniq
, not $ uniq' `ltUnique` minLocalUnique
= incrUnique uniq'
diff --git a/compiler/GHC/Utils/Containers/Internal/BitUtil.hs b/compiler/GHC/Utils/Containers/Internal/BitUtil.hs
new file mode 100644
index 0000000000000000000000000000000000000000..b7484cfc2e07b00b717e64f507aed0779c39f649
--- /dev/null
+++ b/compiler/GHC/Utils/Containers/Internal/BitUtil.hs
@@ -0,0 +1,71 @@
+{-# LANGUAGE CPP #-}
+#if __GLASGOW_HASKELL__
+{-# LANGUAGE MagicHash #-}
+#endif
+#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)
+{-# LANGUAGE Safe #-}
+#endif
+
+#include "containers.h"
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Utils.Containers.Internal.BitUtil
+-- Copyright : (c) Clark Gaebel 2012
+-- (c) Johan Tibel 2012
+-- License : BSD-style
+-- Maintainer : libraries@haskell.org
+-- Portability : portable
+-----------------------------------------------------------------------------
+--
+-- = WARNING
+--
+-- This module is considered __internal__.
+--
+-- The Package Versioning Policy __does not apply__.
+--
+-- The contents of this module may change __in any way whatsoever__
+-- and __without any warning__ between minor versions of this package.
+--
+-- Authors importing this module are expected to track development
+-- closely.
+
+module GHC.Utils.Containers.Internal.BitUtil
+ ( bitcount
+ , highestBitMask
+ , shiftLL
+ , shiftRL
+ ) where
+
+import GHC.Prelude.Basic
+import Data.Word
+
+{----------------------------------------------------------------------
+ [bitcount] as posted by David F. Place to haskell-cafe on April 11, 2006,
+ based on the code on
+ http://graphics.stanford.edu/~seander/bithacks.html#CountBitsSetKernighan,
+ where the following source is given:
+ Published in 1988, the C Programming Language 2nd Ed. (by Brian W.
+ Kernighan and Dennis M. Ritchie) mentions this in exercise 2-9. On April
+ 19, 2006 Don Knuth pointed out to me that this method "was first published
+ by Peter Wegner in CACM 3 (1960), 322. (Also discovered independently by
+ Derrick Lehmer and published in 1964 in a book edited by Beckenbach.)"
+----------------------------------------------------------------------}
+
+bitcount :: Int -> Word64 -> Int
+bitcount a x = a + popCount x
+{-# INLINE bitcount #-}
+
+-- The highestBitMask implementation is based on
+-- http://graphics.stanford.edu/~seander/bithacks.html#RoundUpPowerOf2
+-- which has been put in the public domain.
+
+-- | Return a word where only the highest bit is set.
+highestBitMask :: Word64 -> Word64
+highestBitMask w = shiftLL 1 (63 - countLeadingZeros w)
+{-# INLINE highestBitMask #-}
+
+-- Right and left logical shifts.
+shiftRL, shiftLL :: Word64 -> Int -> Word64
+shiftRL = unsafeShiftR
+shiftLL = unsafeShiftL
\ No newline at end of file
diff --git a/compiler/GHC/Utils/Containers/Internal/StrictPair.hs b/compiler/GHC/Utils/Containers/Internal/StrictPair.hs
new file mode 100644
index 0000000000000000000000000000000000000000..65d3780ef071f2b9fc2f4b3ff5502314f6426abd
--- /dev/null
+++ b/compiler/GHC/Utils/Containers/Internal/StrictPair.hs
@@ -0,0 +1,24 @@
+{-# LANGUAGE CPP #-}
+#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)
+{-# LANGUAGE Safe #-}
+#endif
+
+#include "containers.h"
+
+-- | A strict pair
+
+module GHC.Utils.Containers.Internal.StrictPair (StrictPair(..), toPair) where
+
+-- | The same as a regular Haskell pair, but
+--
+-- @
+-- (x :*: _|_) = (_|_ :*: y) = _|_
+-- @
+data StrictPair a b = !a :*: !b
+
+infixr 1 :*:
+
+-- | Convert a strict pair to a standard pair.
+toPair :: StrictPair a b -> (a, b)
+toPair (x :*: y) = (x, y)
+{-# INLINE toPair #-}
diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs
index 8fc1467527a7eb42dd660ab60b3b30b7342f49dd..fc668111e0402ed982a742a19a1b46a33328cf80 100644
--- a/compiler/GHC/Utils/Outputable.hs
+++ b/compiler/GHC/Utils/Outputable.hs
@@ -37,7 +37,7 @@ module GHC.Utils.Outputable (
spaceIfSingleQuote,
isEmpty, nest,
ptext,
- int, intWithCommas, integer, word, float, double, rational, doublePrec,
+ int, intWithCommas, integer, word64, word, float, double, rational, doublePrec,
parens, cparen, brackets, braces, quotes, quote,
doubleQuotes, angleBrackets,
semi, comma, colon, dcolon, space, equals, dot, vbar,
@@ -141,7 +141,7 @@ import Data.Int
import qualified Data.IntMap as IM
import Data.Set (Set)
import qualified Data.Set as Set
-import qualified Data.IntSet as IntSet
+import qualified GHC.Data.Word64Set as Word64Set
import Data.String
import Data.Word
import System.IO ( Handle )
@@ -681,6 +681,7 @@ ptext :: PtrString -> SDoc
int :: IsLine doc => Int -> doc
integer :: IsLine doc => Integer -> doc
word :: Integer -> SDoc
+word64 :: IsLine doc => Word64 -> doc
float :: IsLine doc => Float -> doc
double :: IsLine doc => Double -> doc
rational :: Rational -> SDoc
@@ -698,6 +699,8 @@ double n = text $ show n
{-# INLINE CONLIKE rational #-}
rational n = text $ show n
-- See Note [Print Hexadecimal Literals] in GHC.Utils.Ppr
+{-# INLINE CONLIKE word64 #-}
+word64 n = text $ show n
{-# INLINE CONLIKE word #-}
word n = sdocOption sdocHexWordLiterals $ \case
True -> docToSDoc $ Pretty.hex n
@@ -975,8 +978,8 @@ instance (Outputable a, Outputable b) => Outputable (Arg a b) where
instance (Outputable a) => Outputable (Set a) where
ppr s = braces (pprWithCommas ppr (Set.toList s))
-instance Outputable IntSet.IntSet where
- ppr s = braces (pprWithCommas ppr (IntSet.toList s))
+instance Outputable Word64Set.Word64Set where
+ ppr s = braces (pprWithCommas ppr (Word64Set.toList s))
instance (Outputable a, Outputable b) => Outputable (a, b) where
ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
diff --git a/compiler/GHC/Utils/Unique.hs b/compiler/GHC/Utils/Unique.hs
new file mode 100644
index 0000000000000000000000000000000000000000..a89e6bab1d192b3c7885b1ad3611d5e523cea1d1
--- /dev/null
+++ b/compiler/GHC/Utils/Unique.hs
@@ -0,0 +1,35 @@
+{-# LANGUAGE CPP #-}
+
+{- Work around #23537
+
+On 32 bit systems, GHC's codegen around 64 bit numbers is not quite
+complete. This led to panics mentioning missing cases in iselExpr64.
+Now that GHC uses Word64 for its uniques, these panics have started
+popping up whenever a unique is compared to many other uniques in one
+function. As a workaround we use these two functions which are not
+inlined on 32 bit systems, thus preventing the panics.
+-}
+
+module GHC.Utils.Unique (sameUnique, anyOfUnique) where
+
+#include "MachDeps.h"
+
+import GHC.Prelude.Basic (Bool, Eq((==)), Foldable(elem))
+import GHC.Types.Unique (Unique, Uniquable (getUnique))
+
+
+#if WORD_SIZE_IN_BITS == 32
+{-# NOINLINE sameUnique #-}
+#else
+{-# INLINE sameUnique #-}
+#endif
+sameUnique :: Uniquable a => a -> a -> Bool
+sameUnique x y = getUnique x == getUnique y
+
+#if WORD_SIZE_IN_BITS == 32
+{-# NOINLINE anyOfUnique #-}
+#else
+{-# INLINE anyOfUnique #-}
+#endif
+anyOfUnique :: Uniquable a => a -> [Unique] -> Bool
+anyOfUnique tc xs = getUnique tc `elem` xs
\ No newline at end of file
diff --git a/compiler/GHC/Utils/Word64.hs b/compiler/GHC/Utils/Word64.hs
new file mode 100644
index 0000000000000000000000000000000000000000..f8b0ab0c2664248b9f0aa20fe425d2c444a384dc
--- /dev/null
+++ b/compiler/GHC/Utils/Word64.hs
@@ -0,0 +1,20 @@
+module GHC.Utils.Word64 (
+ intToWord64,
+ word64ToInt,
+ truncateWord64ToWord32,
+ ) where
+
+import GHC.Prelude
+import GHC.Utils.Panic.Plain (assert)
+
+import Data.Word
+import GHC.Stack
+
+intToWord64 :: HasCallStack => Int -> Word64
+intToWord64 x = assert (0 <= x) (fromIntegral x)
+
+word64ToInt :: HasCallStack => Word64 -> Int
+word64ToInt x = assert (x <= fromIntegral (maxBound :: Int)) (fromIntegral x)
+
+truncateWord64ToWord32 :: Word64 -> Word32
+truncateWord64ToWord32 = fromIntegral
\ No newline at end of file
diff --git a/compiler/cbits/genSym.c b/compiler/cbits/genSym.c
index 9bdadc5a990dfe9fa04808a1ddc610e50321fdd9..e7ce7321824c24aaeb87f228768333aacbbbdf8a 100644
--- a/compiler/cbits/genSym.c
+++ b/compiler/cbits/genSym.c
@@ -9,16 +9,32 @@
//
// The CPP is thus about the RTS version GHC is linked against, and not the
// version of the GHC being built.
+#if !MIN_VERSION_GLASGOW_HASKELL(9,7,0,0)
+HsWord64 ghc_unique_counter64 = 0;
+#endif
#if !MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)
-HsInt ghc_unique_counter = 0;
HsInt ghc_unique_inc = 1;
#endif
-#define UNIQUE_BITS (sizeof (HsInt) * 8 - UNIQUE_TAG_BITS)
+// This function has been added to the RTS. Here we pessimistically assume
+// that a threaded RTS is used. This function is only used for bootstrapping.
+#if !MIN_VERSION_GLASGOW_HASKELL(9,7,0,0)
+EXTERN_INLINE StgWord64
+atomic_inc64(StgWord64 volatile* p, StgWord64 incr)
+{
+#if defined(HAVE_C11_ATOMICS)
+ return __atomic_add_fetch(p, incr, __ATOMIC_SEQ_CST);
+#else
+ return __sync_add_and_fetch(p, incr);
+#endif
+}
+#endif
+
+#define UNIQUE_BITS (sizeof (HsWord64) * 8 - UNIQUE_TAG_BITS)
#define UNIQUE_MASK ((1ULL << UNIQUE_BITS) - 1)
-HsInt genSym(void) {
- HsInt u = atomic_inc((StgWord *)&ghc_unique_counter, ghc_unique_inc) & UNIQUE_MASK;
+HsWord64 genSym(void) {
+ HsWord64 u = atomic_inc64((StgWord64 *)&ghc_unique_counter64, ghc_unique_inc) & UNIQUE_MASK;
// Uh oh! We will overflow next time a unique is requested.
ASSERT(u != UNIQUE_MASK);
return u;
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 3fe56374d33dc51da58d565e51a79106f9970b0d..0fcdcdada7f80e75e39db137288ce0dee2f3db2e 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -165,7 +165,11 @@ Library
-- as it's magic.
GHC-Options: -this-unit-id ghc
- c-sources:
+ if arch(javascript)
+ js-sources:
+ jsbits/genSym.js
+ else
+ c-sources:
cbits/cutils.c
cbits/genSym.c
cbits/keepCAFsForGHCi.c
@@ -417,6 +421,13 @@ Library
GHC.Data.TrieMap
GHC.Data.Unboxed
GHC.Data.UnionFind
+ GHC.Data.Word64Set
+ GHC.Data.Word64Set.Internal
+ GHC.Data.Word64Map
+ GHC.Data.Word64Map.Internal
+ GHC.Data.Word64Map.Lazy
+ GHC.Data.Word64Map.Strict
+ GHC.Data.Word64Map.Strict.Internal
GHC.Driver.Backend
GHC.Driver.Backend.Internal
GHC.Driver.Backpack
@@ -883,6 +894,8 @@ Library
GHC.Utils.BufHandle
GHC.Utils.CliOption
GHC.Utils.Constants
+ GHC.Utils.Containers.Internal.BitUtil
+ GHC.Utils.Containers.Internal.StrictPair
GHC.Utils.Error
GHC.Utils.Exception
GHC.Utils.Fingerprint
@@ -903,6 +916,8 @@ Library
GHC.Utils.Ppr.Colour
GHC.Utils.TmpFs
GHC.Utils.Trace
+ GHC.Utils.Unique
+ GHC.Utils.Word64
GHC.Wasm.ControlFlow
GHC.Wasm.ControlFlow.FromCmm
GHC.CmmToAsm.Wasm
diff --git a/compiler/jsbits/genSym.js b/compiler/jsbits/genSym.js
new file mode 100644
index 0000000000000000000000000000000000000000..32bd6b9624562d0a9d7a61726f35b60a1c4eacd9
--- /dev/null
+++ b/compiler/jsbits/genSym.js
@@ -0,0 +1,26 @@
+//#OPTIONS: CPP
+#include "Unique.h"
+
+// We assume that the unique tag occupies less than 32 bits (should be safe)
+#define HIGH_UNIQUE_BITS (32 - UNIQUE_TAG_BITS)
+#define HIGH_UNIQUE_MASK ((1 << HIGH_UNIQUE_BITS) - 1)
+
+// The 'ghc_unique_inc' and 'ghc_unique_counter64' are in the native RTS. It allows them to be
+// shared with plugins even if two different instances of the GHC library are
+// loaded at the same time (#19940)
+// However, cross compilers do not support plugins so we have moved these globals back
+// into the compiler.
+var h$ghc_unique_inc = h$newByteArray(4);
+h$ghc_unique_inc.i3[0] = 1;
+var h$ghc_unique_counter64 = h$newByteArray(8);
+h$ghc_unique_counter64.i3[0] = 0;
+h$ghc_unique_counter64.i3[1] = 0;
+
+function h$genSym() {
+ var rl = h$hs_plusWord64(h$ghc_unique_counter64.i3[1] >>> 0, h$ghc_unique_counter64.i3[0] >>> 0, 0, h$ghc_unique_inc.i3[0] >>> 0);
+ h$ret1 = (h$ret1 & HIGH_UNIQUE_MASK) >>> 0;
+ // h$ret1 contains the higher part (rh)
+ h$ghc_unique_counter64.i3[0] = rl | 0;
+ h$ghc_unique_counter64.i3[1] = h$ret1 | 0;
+ return rl; // h$ret1 still contains rh
+}
diff --git a/rts/Globals.c b/rts/Globals.c
index b7ed8147525e3d089e410932a5c0681ad506c862..c6323c45a101e4b953561af83fbdef3d29fc6227 100644
--- a/rts/Globals.c
+++ b/rts/Globals.c
@@ -108,5 +108,5 @@ mkStoreAccessor(LibHSghcGlobalHasPprDebug)
mkStoreAccessor(LibHSghcGlobalHasNoDebugOutput)
mkStoreAccessor(LibHSghcGlobalHasNoStateHack)
-HsInt ghc_unique_counter = 0;
+HsWord64 ghc_unique_counter64 = 0;
HsInt ghc_unique_inc = 1;
diff --git a/rts/RtsSymbols.c b/rts/RtsSymbols.c
index 119431ea18918106393b20cd7e13ac9a270fa260..2a75caa9d93df4250f51a89a02352655e454b094 100644
--- a/rts/RtsSymbols.c
+++ b/rts/RtsSymbols.c
@@ -571,7 +571,7 @@ extern char **environ;
SymI_HasProto(getOrSetLibHSghcGlobalHasPprDebug) \
SymI_HasProto(getOrSetLibHSghcGlobalHasNoDebugOutput) \
SymI_HasProto(getOrSetLibHSghcGlobalHasNoStateHack) \
- SymI_HasProto(ghc_unique_counter) \
+ SymI_HasProto(ghc_unique_counter64) \
SymI_HasProto(ghc_unique_inc) \
SymI_HasProto(genericRaise) \
SymI_HasProto(getProgArgv) \
@@ -922,6 +922,7 @@ extern char **environ;
SymI_HasProto(stopHeapProfTimer) \
SymI_HasProto(requestHeapCensus) \
SymI_HasProto(atomic_inc) \
+ SymI_HasProto(atomic_inc64) \
SymI_HasProto(atomic_dec) \
SymI_HasProto(hs_spt_lookup) \
SymI_HasProto(hs_spt_insert) \
diff --git a/rts/include/rts/Globals.h b/rts/include/rts/Globals.h
index bd3aa637db7298edf146cc33c3bab0fdfa558169..7efe7241c9e139d1f049ebc2b3ca0b2ffbd45c63 100644
--- a/rts/include/rts/Globals.h
+++ b/rts/include/rts/Globals.h
@@ -32,5 +32,5 @@ mkStoreAccessorPrototype(LibHSghcFastStringTable)
mkStoreAccessorPrototype(LibHSghcGlobalHasPprDebug)
mkStoreAccessorPrototype(LibHSghcGlobalHasNoDebugOutput)
mkStoreAccessorPrototype(LibHSghcGlobalHasNoStateHack)
-extern HsInt ghc_unique_counter;
+extern HsWord64 ghc_unique_counter64;
extern HsInt ghc_unique_inc;
diff --git a/rts/include/stg/SMP.h b/rts/include/stg/SMP.h
index 883f7adc80140d0b51f22035a9a6d1e2e1a0ef02..e5ff35dcd20edb7f89fe8313ee64e0c6fa215bc8 100644
--- a/rts/include/stg/SMP.h
+++ b/rts/include/stg/SMP.h
@@ -82,6 +82,15 @@ EXTERN_INLINE StgWord cas_seq_cst_relaxed(StgVolatilePtr p, StgWord o, StgWord n
EXTERN_INLINE StgWord atomic_inc(StgVolatilePtr p, StgWord n);
+/*
+ * Atomic 64-bit addition of by the provided quantity
+ *
+ * atomic_inc64(p, n) {
+ * return ((*p) += n);
+ * }
+ */
+EXTERN_INLINE StgWord64 atomic_inc64(StgWord64 volatile* p, StgWord64 n);
+
/*
* Atomic decrement
*
@@ -407,6 +416,16 @@ atomic_inc(StgVolatilePtr p, StgWord incr)
#endif
}
+EXTERN_INLINE StgWord64
+atomic_inc64(StgWord64 volatile* p, StgWord64 incr)
+{
+#if defined(HAVE_C11_ATOMICS)
+ return __atomic_add_fetch(p, incr, __ATOMIC_SEQ_CST);
+#else
+ return __sync_add_and_fetch(p, incr);
+#endif
+}
+
EXTERN_INLINE StgWord
atomic_dec(StgVolatilePtr p)
{
@@ -544,6 +563,14 @@ atomic_inc(StgVolatilePtr p, StgWord incr)
}
+EXTERN_INLINE StgWord64 atomic_inc64(StgWord64 volatile* p, StgWord64 incr);
+EXTERN_INLINE StgWord64
+atomic_inc64(StgWord64 volatile* p, StgWord64 incr)
+{
+ return ((*p) += incr);
+}
+
+
INLINE_HEADER StgWord
atomic_dec(StgVolatilePtr p)
{
diff --git a/rts/js/globals.js b/rts/js/globals.js
index 4ae7ae8ee9b5985989232a683aa732d04aef347d..d486e9dce690bc52a5fb87d5809fa6d835d96839 100644
--- a/rts/js/globals.js
+++ b/rts/js/globals.js
@@ -16,9 +16,4 @@
GVAR(h$getOrSetLibHSghcGlobalHasPprDebug, has_ppr_debug)
GVAR(h$getOrSetLibHSghcGlobalHasNoDebugOutput, has_no_debug_output)
GVAR(h$getOrSetLibHSghcGlobalHasNoStateHack, has_no_state_hack)
-GVAR(h$getOrSetLibHSghcFastStringTable, faststring_table)
-
-var h$ghc_unique_inc = h$newByteArray(4);
-h$ghc_unique_inc.i3[0] = 1;
-var h$ghc_unique_counter = h$newByteArray(4);
-h$ghc_unique_counter.i3[0] = 0;
+GVAR(h$getOrSetLibHSghcFastStringTable, faststring_table)
\ No newline at end of file
diff --git a/testsuite/tests/count-deps/CountDepsAst.stdout b/testsuite/tests/count-deps/CountDepsAst.stdout
index 1a945015af89b3e7232bdcc3cb5cb8d520311402..8d949c7f22401d87aeb06f4af29bdbb54da57a92 100644
--- a/testsuite/tests/count-deps/CountDepsAst.stdout
+++ b/testsuite/tests/count-deps/CountDepsAst.stdout
@@ -74,6 +74,13 @@ GHC.Data.Pair
GHC.Data.Strict
GHC.Data.StringBuffer
GHC.Data.TrieMap
+GHC.Data.Word64Map
+GHC.Data.Word64Map.Internal
+GHC.Data.Word64Map.Lazy
+GHC.Data.Word64Map.Strict
+GHC.Data.Word64Map.Strict.Internal
+GHC.Data.Word64Set
+GHC.Data.Word64Set.Internal
GHC.Driver.Backend
GHC.Driver.Backend.Internal
GHC.Driver.DynFlags
@@ -192,6 +199,8 @@ GHC.Utils.Binary.Typeable
GHC.Utils.BufHandle
GHC.Utils.CliOption
GHC.Utils.Constants
+GHC.Utils.Containers.Internal.BitUtil
+GHC.Utils.Containers.Internal.StrictPair
GHC.Utils.Error
GHC.Utils.Exception
GHC.Utils.FV
@@ -210,6 +219,7 @@ GHC.Utils.Ppr
GHC.Utils.Ppr.Colour
GHC.Utils.TmpFs
GHC.Utils.Trace
+GHC.Utils.Word64
Language.Haskell.Syntax
Language.Haskell.Syntax.Basic
Language.Haskell.Syntax.Binds
diff --git a/testsuite/tests/count-deps/CountDepsParser.stdout b/testsuite/tests/count-deps/CountDepsParser.stdout
index 9b80e7976eaa9fc6cfe736368aca38a950dad675..5ff9b58b502dd3be33f969f37f7e2fb1f6fd6170 100644
--- a/testsuite/tests/count-deps/CountDepsParser.stdout
+++ b/testsuite/tests/count-deps/CountDepsParser.stdout
@@ -75,6 +75,13 @@ GHC.Data.Pair
GHC.Data.Strict
GHC.Data.StringBuffer
GHC.Data.TrieMap
+GHC.Data.Word64Map
+GHC.Data.Word64Map.Internal
+GHC.Data.Word64Map.Lazy
+GHC.Data.Word64Map.Strict
+GHC.Data.Word64Map.Strict.Internal
+GHC.Data.Word64Set
+GHC.Data.Word64Set.Internal
GHC.Driver.Backend
GHC.Driver.Backend.Internal
GHC.Driver.Backpack.Syntax
@@ -212,6 +219,8 @@ GHC.Utils.Binary.Typeable
GHC.Utils.BufHandle
GHC.Utils.CliOption
GHC.Utils.Constants
+GHC.Utils.Containers.Internal.BitUtil
+GHC.Utils.Containers.Internal.StrictPair
GHC.Utils.Error
GHC.Utils.Exception
GHC.Utils.FV
@@ -230,6 +239,7 @@ GHC.Utils.Ppr
GHC.Utils.Ppr.Colour
GHC.Utils.TmpFs
GHC.Utils.Trace
+GHC.Utils.Word64
Language.Haskell.Syntax
Language.Haskell.Syntax.Basic
Language.Haskell.Syntax.Binds
diff --git a/testsuite/tests/perf/should_run/UniqLoop.hs b/testsuite/tests/perf/should_run/UniqLoop.hs
index bd86ba336045c6e371a6fce5dbed354e3ff389f8..81b1320e5340c4ab552a9aa72a49755fcc476e80 100644
--- a/testsuite/tests/perf/should_run/UniqLoop.hs
+++ b/testsuite/tests/perf/should_run/UniqLoop.hs
@@ -4,13 +4,14 @@ module Main where
import GHC.Types.Unique.Supply
import GHC.Types.Unique
+import Data.Word
-- Generate a lot of uniques
main = do
us <- mkSplitUniqSupply 'v'
seq (churn us 10000000) (return ())
-churn :: UniqSupply -> Int -> Int
+churn :: UniqSupply -> Word64 -> Word64
churn !us 0 = getKey $ uniqFromSupply us
churn us n =
let (!x,!us') = takeUniqFromSupply us