Upgrade UniqSet to a newtype

The fundamental problem with `type UniqSet = UniqFM` is that `UniqSet`
has a key invariant `UniqFM` does not. For example, `fmap` over
`UniqSet` will generally produce nonsense.

* Upgrade `UniqSet` from a type synonym to a newtype.

* Remove unused and shady `extendVarSet_C` and `addOneToUniqSet_C`.

* Use cached unique in `tyConsOfType` by replacing
  `unitNameEnv (tyConName tc) tc` with `unitUniqSet tc`.

Reviewers: austin, hvr, goldfire, simonmar, niteria, bgamari

Reviewed By: niteria

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D3146

8 files changed, 42 insertions, 38 deletions

diff --git a/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs b/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs
index c3df743454..5731f18234 100644
--- a/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs
@@ -89,7 +89,7 @@ worst   :: (RegClass    -> UniqSet Reg)
 worst regsOfClass regAlias neighbors classN classC
  = let  regAliasS regs  = unionManyUniqSets
                         $ map regAlias
-                        $ nonDetEltsUFM regs
+                        $ nonDetEltsUniqSet regs
                         -- This is non-deterministic but we do not
                         -- currently support deterministic code-generation.
                         -- See Note [Unique Determinism and code generation]
@@ -126,7 +126,7 @@ bound regsOfClass regAlias classN classesC
 
         regsC_aliases
                 = unionManyUniqSets
-                $ map (regAliasS . regsOfClass) classesC
+                $ map (regAliasS . getUniqSet . regsOfClass) classesC
 
         overlap = intersectUniqSets (regsOfClass classN) regsC_aliases
 
@@ -155,5 +155,5 @@ powersetL       = map concat . mapM (\x -> [[],[x]])
 
 -- | powersetLS (list of sets)
 powersetLS :: Uniquable a => UniqSet a -> [UniqSet a]
-powersetLS s    = map mkUniqSet $ powersetL $ nonDetEltsUFM s
+powersetLS s    = map mkUniqSet $ powersetL $ nonDetEltsUniqSet s
   -- See Note [Unique Determinism and code generation]
diff --git a/compiler/nativeGen/RegAlloc/Graph/Main.hs b/compiler/nativeGen/RegAlloc/Graph/Main.hs
index e819fe8870..08538453f7 100644
--- a/compiler/nativeGen/RegAlloc/Graph/Main.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/Main.hs
@@ -111,7 +111,7 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code
            (  text "It looks like the register allocator is stuck in an infinite loop."
            $$ text "max cycles  = " <> int maxSpinCount
            $$ text "regsFree    = " <> (hcat $ punctuate space $ map ppr
-                                             $ nonDetEltsUFM $ unionManyUniqSets
+                                             $ nonDetEltsUniqSet $ unionManyUniqSets
                                              $ nonDetEltsUFM regsFree)
               -- This is non-deterministic but we do not
               -- currently support deterministic code-generation.
@@ -316,15 +316,15 @@ graphAddConflictSet
 
 graphAddConflictSet set graph
  = let  virtuals        = mkUniqSet
-                        [ vr | RegVirtual vr <- nonDetEltsUFM set ]
+                        [ vr | RegVirtual vr <- nonDetEltsUniqSet set ]
 
         graph1  = Color.addConflicts virtuals classOfVirtualReg graph
 
         graph2  = foldr (\(r1, r2) -> Color.addExclusion r1 classOfVirtualReg r2)
                         graph1
                         [ (vr, rr)
-                                | RegVirtual vr <- nonDetEltsUFM set
-                                , RegReal    rr <- nonDetEltsUFM set]
+                                | RegVirtual vr <- nonDetEltsUniqSet set
+                                , RegReal    rr <- nonDetEltsUniqSet set]
                           -- See Note [Unique Determinism and code generation]
 
    in   graph2
@@ -419,11 +419,11 @@ seqNode node
         =     seqVirtualReg     (Color.nodeId node)
         `seq` seqRegClass       (Color.nodeClass node)
         `seq` seqMaybeRealReg   (Color.nodeColor node)
-        `seq` (seqVirtualRegList (nonDetEltsUFM (Color.nodeConflicts node)))
-        `seq` (seqRealRegList    (nonDetEltsUFM (Color.nodeExclusions node)))
+        `seq` (seqVirtualRegList (nonDetEltsUniqSet (Color.nodeConflicts node)))
+        `seq` (seqRealRegList    (nonDetEltsUniqSet (Color.nodeExclusions node)))
         `seq` (seqRealRegList (Color.nodePreference node))
-        `seq` (seqVirtualRegList (nonDetEltsUFM (Color.nodeCoalesce node)))
-              -- It's OK to use nonDetEltsUFM for seq
+        `seq` (seqVirtualRegList (nonDetEltsUniqSet (Color.nodeCoalesce node)))
+              -- It's OK to use nonDetEltsUniqSet for seq
 
 seqVirtualReg :: VirtualReg -> ()
 seqVirtualReg reg = reg `seq` ()
diff --git a/compiler/nativeGen/RegAlloc/Graph/Spill.hs b/compiler/nativeGen/RegAlloc/Graph/Spill.hs
index 0704e53102..9a3808ad9a 100644
--- a/compiler/nativeGen/RegAlloc/Graph/Spill.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/Spill.hs
@@ -61,9 +61,9 @@ regSpill platform code slotsFree regs
         | otherwise
         = do
                 -- Allocate a slot for each of the spilled regs.
-                let slots       = take (sizeUniqSet regs) $ nonDetEltsUFM slotsFree
+                let slots       = take (sizeUniqSet regs) $ nonDetEltsUniqSet slotsFree
                 let regSlotMap  = listToUFM
-                                $ zip (nonDetEltsUFM regs) slots
+                                $ zip (nonDetEltsUniqSet regs) slots
                     -- This is non-deterministic but we do not
                     -- currently support deterministic code-generation.
                     -- See Note [Unique Determinism and code generation]
@@ -141,7 +141,7 @@ regSpill_top platform regSlotMap cmm
                 moreSlotsLive   = IntSet.fromList
                                 $ catMaybes
                                 $ map (lookupUFM regSlotMap)
-                                $ nonDetEltsUFM regsLive
+                                $ nonDetEltsUniqSet regsLive
                     -- See Note [Unique Determinism and code generation]
 
                 slotMap'
diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
index 03da772819..0811147eda 100644
--- a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
@@ -413,7 +413,7 @@ intersects assocs       = foldl1' intersectAssoc assocs
 findRegOfSlot :: Assoc Store -> Int -> Maybe Reg
 findRegOfSlot assoc slot
         | close                 <- closeAssoc (SSlot slot) assoc
-        , Just (SReg reg)       <- find isStoreReg $ nonDetEltsUFM close
+        , Just (SReg reg)       <- find isStoreReg $ nonDetEltsUniqSet close
            -- See Note [Unique Determinism and code generation]
         = Just reg
 
@@ -549,7 +549,7 @@ delAssoc :: (Uniquable a)
 delAssoc a m
         | Just aSet     <- lookupUFM  m a
         , m1            <- delFromUFM m a
-        = nonDetFoldUFM (\x m -> delAssoc1 x a m) m1 aSet
+        = nonDetFoldUniqSet (\x m -> delAssoc1 x a m) m1 aSet
           -- It's OK to use nonDetFoldUFM here because deletion is commutative
 
         | otherwise     = m
@@ -582,7 +582,7 @@ closeAssoc a assoc
  =      closeAssoc' assoc emptyUniqSet (unitUniqSet a)
  where
         closeAssoc' assoc visited toVisit
-         = case nonDetEltsUFM toVisit of
+         = case nonDetEltsUniqSet toVisit of
              -- See Note [Unique Determinism and code generation]
 
                 -- nothing else to visit, we're done
diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
index efa1cd11e2..0817b3941a 100644
--- a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
@@ -108,7 +108,7 @@ slurpSpillCostInfo platform cmm
         countLIs rsLiveEntry (LiveInstr instr (Just live) : lis)
          = do
                 -- Increment the lifetime counts for regs live on entry to this instr.
-                mapM_ incLifetime $ nonDetEltsUFM rsLiveEntry
+                mapM_ incLifetime $ nonDetEltsUniqSet rsLiveEntry
                     -- This is non-deterministic but we do not
                     -- currently support deterministic code-generation.
                     -- See Note [Unique Determinism and code generation]
@@ -140,7 +140,7 @@ slurpSpillCostInfo platform cmm
 -- | Take all the virtual registers from this set.
 takeVirtuals :: UniqSet Reg -> UniqSet VirtualReg
 takeVirtuals set = mkUniqSet
-  [ vr | RegVirtual vr <- nonDetEltsUFM set ]
+  [ vr | RegVirtual vr <- nonDetEltsUniqSet set ]
   -- See Note [Unique Determinism and code generation]
 
 
@@ -260,7 +260,7 @@ nodeDegree classOfVirtualReg graph reg
         , virtConflicts
            <- length
            $ filter (\r -> classOfVirtualReg r == classOfVirtualReg reg)
-           $ nonDetEltsUFM
+           $ nonDetEltsUniqSet
            -- See Note [Unique Determinism and code generation]
            $ nodeConflicts node
 
diff --git a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs
index 81e0c5e091..204de846ae 100644
--- a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs
@@ -13,7 +13,7 @@ import Reg
 
 import GraphBase
 
-import UniqFM
+import UniqSet
 import Platform
 import Panic
 
@@ -56,10 +56,10 @@ accSqueeze
         :: Int
         -> Int
         -> (reg -> Int)
-        -> UniqFM reg
+        -> UniqSet reg
         -> Int
 
-accSqueeze count maxCount squeeze ufm = acc count (nonDetEltsUFM ufm)
+accSqueeze count maxCount squeeze us = acc count (nonDetEltsUniqSet us)
   -- See Note [Unique Determinism and code generation]
   where acc count [] = count
         acc count _ | count >= maxCount = count
diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs
index 055129703b..b7721880c3 100644
--- a/compiler/nativeGen/RegAlloc/Linear/Main.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs
@@ -352,7 +352,7 @@ initBlock id block_live
                             setFreeRegsR    (frInitFreeRegs platform)
                           Just live ->
                             setFreeRegsR $ foldl' (flip $ frAllocateReg platform) (frInitFreeRegs platform)
-                                                  [ r | RegReal r <- nonDetEltsUFM live ]
+                                                  [ r | RegReal r <- nonDetEltsUniqSet live ]
                             -- See Note [Unique Determinism and code generation]
                         setAssigR       emptyRegMap
 
@@ -446,8 +446,8 @@ raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live))
            return (new_instrs, [])
 
         _ -> genRaInsn block_live new_instrs id instr
-                        (nonDetEltsUFM $ liveDieRead live)
-                        (nonDetEltsUFM $ liveDieWrite live)
+                        (nonDetEltsUniqSet $ liveDieRead live)
+                        (nonDetEltsUniqSet $ liveDieWrite live)
                         -- See Note [Unique Determinism and code generation]
 
 raInsn _ _ _ instr
diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs
index 4b00ed6cd6..e387f82420 100644
--- a/compiler/nativeGen/RegAlloc/Liveness.hs
+++ b/compiler/nativeGen/RegAlloc/Liveness.hs
@@ -40,7 +40,7 @@ import Instruction
 
 import BlockId
 import Hoopl
-import Cmm hiding (RegSet)
+import Cmm hiding (RegSet, emptyRegSet)
 import PprCmm()
 
 import Digraph
@@ -66,6 +66,9 @@ type RegMap a = UniqFM a
 emptyRegMap :: UniqFM a
 emptyRegMap = emptyUFM
 
+emptyRegSet :: RegSet
+emptyRegSet = emptyUniqSet
+
 type BlockMap a = LabelMap a
 
 
@@ -220,7 +223,8 @@ instance Outputable instr
          where  pprRegs :: SDoc -> RegSet -> SDoc
                 pprRegs name regs
                  | isEmptyUniqSet regs  = empty
-                 | otherwise            = name <> (pprUFM regs (hcat . punctuate space . map ppr))
+                 | otherwise            = name <>
+                     (pprUFM (getUniqSet regs) (hcat . punctuate space . map ppr))
 
 instance Outputable LiveInfo where
     ppr (LiveInfo mb_static entryIds liveVRegsOnEntry liveSlotsOnEntry)
@@ -573,7 +577,7 @@ patchEraseLive patchF cmm
          = let
                 patchRegSet set = mkUniqSet $ map patchF $ nonDetEltsUFM set
                   -- See Note [Unique Determinism and code generation]
-                blockMap'       = mapMap patchRegSet blockMap
+                blockMap'       = mapMap (patchRegSet . getUniqSet) blockMap
 
                 info'           = LiveInfo static id (Just blockMap') mLiveSlots
            in   CmmProc info' label live $ map patchSCC sccs
@@ -629,9 +633,9 @@ patchRegsLiveInstr patchF li
                 (patchRegsOfInstr instr patchF)
                 (Just live
                         { -- WARNING: have to go via lists here because patchF changes the uniq in the Reg
-                          liveBorn      = mkUniqSet $ map patchF $ nonDetEltsUFM $ liveBorn live
-                        , liveDieRead   = mkUniqSet $ map patchF $ nonDetEltsUFM $ liveDieRead live
-                        , liveDieWrite  = mkUniqSet $ map patchF $ nonDetEltsUFM $ liveDieWrite live })
+                          liveBorn      = mapUniqSet patchF $ liveBorn live
+                        , liveDieRead   = mapUniqSet patchF $ liveDieRead live
+                        , liveDieWrite  = mapUniqSet patchF $ liveDieWrite live })
                           -- See Note [Unique Determinism and code generation]
 
 
@@ -758,7 +762,7 @@ checkIsReverseDependent sccs'
          = let  dests           = slurpJumpDestsOfBlock block
                 blocksSeen'     = unionUniqSets blocksSeen $ mkUniqSet [blockId block]
                 badDests        = dests `minusUniqSet` blocksSeen'
-           in   case nonDetEltsUFM badDests of
+           in   case nonDetEltsUniqSet badDests of
                  -- See Note [Unique Determinism and code generation]
                  []             -> go blocksSeen' sccs
                  bad : _        -> Just bad
@@ -767,7 +771,7 @@ checkIsReverseDependent sccs'
          = let  dests           = unionManyUniqSets $ map slurpJumpDestsOfBlock blocks
                 blocksSeen'     = unionUniqSets blocksSeen $ mkUniqSet $ map blockId blocks
                 badDests        = dests `minusUniqSet` blocksSeen'
-           in   case nonDetEltsUFM badDests of
+           in   case nonDetEltsUniqSet badDests of
                  -- See Note [Unique Determinism and code generation]
                  []             -> go blocksSeen' sccs
                  bad : _        -> Just bad
@@ -861,7 +865,7 @@ livenessSCCs platform blockmap done
                 = a' == b'
               where a' = map f $ mapToList a
                     b' = map f $ mapToList b
-                    f (key,elt) = (key, nonDetEltsUFM elt)
+                    f (key,elt) = (key, nonDetEltsUniqSet elt)
                     -- See Note [Unique Determinism and code generation]
 
 
@@ -989,7 +993,7 @@ liveness1 platform liveregs blockmap (LiveInstr instr _)
             targetLiveRegs target
                   = case mapLookup target blockmap of
                                 Just ra -> ra
-                                Nothing -> emptyRegMap
+                                Nothing -> emptyRegSet
 
             live_from_branch = unionManyUniqSets (map targetLiveRegs targets)
 
@@ -998,8 +1002,8 @@ liveness1 platform liveregs blockmap (LiveInstr instr _)
             -- registers that are live only in the branch targets should
             -- be listed as dying here.
             live_branch_only = live_from_branch `minusUniqSet` liveregs
-            r_dying_br  = nonDetEltsUFM (mkUniqSet r_dying `unionUniqSets`
-                                        live_branch_only)
+            r_dying_br  = nonDetEltsUniqSet (mkUniqSet r_dying `unionUniqSets`
+                                             live_branch_only)
                           -- See Note [Unique Determinism and code generation]