summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
authorAndreas Klebinger <klebinger.andreas@gmx.at>2020-06-23 15:01:25 +0200
committerMarge Bot <ben+marge-bot@smart-cactus.org>2020-07-12 02:53:55 -0400
commitc4de6a7a5c6433ae8c4df8a9fa09fbd9f3bbd0bf (patch)
treea7514919b3df80af5f09cbcdfac3d4fab25a77d2 /compiler
parentde139cc496c0e0110e252a1208ae346f47f8061e (diff)
downloadhaskell-c4de6a7a5c6433ae8c4df8a9fa09fbd9f3bbd0bf.tar.gz
Give Uniq[D]FM a phantom type for its key.
This fixes #17667 and should help to avoid such issues going forward. The changes are mostly mechanical in nature. With two notable exceptions. * The register allocator. The register allocator references registers by distinct uniques. However they come from the types of VirtualReg, Reg or Unique in various places. As a result we sometimes cast the key type of the map and use functions which operate on the now typed map but take a raw Unique as actual key. The logic itself has not changed it just becomes obvious where we do so now. * <Type>Env Modules. As an example a ClassEnv is currently queried using the types `Class`, `Name`, and `TyCon`. This is safe since for a distinct class value all these expressions give the same unique. getUnique cls getUnique (classTyCon cls) getUnique (className cls) getUnique (tcName $ classTyCon cls) This is for the most part contained within the modules defining the interface. However it requires us to play dirty when we are given a `Name` to lookup in a `UniqFM Class a` map. But again the logic did not change and it's for the most part hidden behind the Env Module. Some of these cases could be avoided by refactoring but this is left for future work. We also bump the haddock submodule as it uses UniqFM.
Diffstat (limited to 'compiler')
-rw-r--r--compiler/GHC/Builtin/Utils.hs11
-rw-r--r--compiler/GHC/Cmm/LayoutStack.hs2
-rw-r--r--compiler/GHC/Cmm/Parser.y6
-rw-r--r--compiler/GHC/Cmm/Sink.hs4
-rw-r--r--compiler/GHC/CmmToAsm.hs3
-rw-r--r--compiler/GHC/CmmToAsm/BlockLayout.hs5
-rw-r--r--compiler/GHC/CmmToAsm/Monad.hs2
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Graph.hs4
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Graph/Coalesce.hs4
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs22
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs34
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs6
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs6
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Linear.hs63
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Linear/Base.hs4
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs4
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Linear/StackMap.hs3
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Linear/Stats.hs7
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Liveness.hs31
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Utils.hs59
-rw-r--r--compiler/GHC/CmmToAsm/X86/RegInfo.hs8
-rw-r--r--compiler/GHC/CmmToLlvm/Base.hs12
-rw-r--r--compiler/GHC/Core/FamInstEnv.hs15
-rw-r--r--compiler/GHC/Core/InstEnv.hs18
-rw-r--r--compiler/GHC/Core/Opt/OccurAnal.hs8
-rw-r--r--compiler/GHC/Core/Opt/SpecConstr.hs2
-rw-r--r--compiler/GHC/Core/Tidy.hs3
-rw-r--r--compiler/GHC/Data/FastString/Env.hs4
-rw-r--r--compiler/GHC/Data/Graph/Base.hs4
-rw-r--r--compiler/GHC/Data/Graph/Color.hs25
-rw-r--r--compiler/GHC/Data/Graph/Directed.hs4
-rw-r--r--compiler/GHC/Data/Graph/Ops.hs10
-rw-r--r--compiler/GHC/Data/TrieMap.hs6
-rw-r--r--compiler/GHC/Driver/Types.hs4
-rw-r--r--compiler/GHC/HsToCore/Monad.hs7
-rw-r--r--compiler/GHC/HsToCore/PmCheck/Oracle.hs2
-rw-r--r--compiler/GHC/HsToCore/PmCheck/Ppr.hs2
-rw-r--r--compiler/GHC/HsToCore/PmCheck/Types.hs11
-rw-r--r--compiler/GHC/Iface/Binary.hs14
-rw-r--r--compiler/GHC/Iface/Ext/Binary.hs16
-rw-r--r--compiler/GHC/Parser/Lexer.x4
-rw-r--r--compiler/GHC/Platform/Reg.hs6
-rw-r--r--compiler/GHC/Runtime/Interpreter/Types.hs3
-rw-r--r--compiler/GHC/StgToCmm/ExtCode.hs2
-rw-r--r--compiler/GHC/Tc/Gen/HsType.hs6
-rw-r--r--compiler/GHC/Tc/Solver/Monad.hs16
-rw-r--r--compiler/GHC/Types/Literal.hs9
-rw-r--r--compiler/GHC/Types/Name/Env.hs4
-rw-r--r--compiler/GHC/Types/Name/Occurrence.hs4
-rw-r--r--compiler/GHC/Types/Unique/DFM.hs143
-rw-r--r--compiler/GHC/Types/Unique/DSet.hs8
-rw-r--r--compiler/GHC/Types/Unique/FM.hs180
-rw-r--r--compiler/GHC/Types/Unique/Set.hs16
-rw-r--r--compiler/GHC/Types/Var/Env.hs23
-rw-r--r--compiler/GHC/Types/Var/Set.hs2
-rw-r--r--compiler/GHC/Unit/Module/Env.hs5
-rw-r--r--compiler/GHC/Unit/State.hs2
-rw-r--r--compiler/GHC/Utils/Binary.hs2
-rw-r--r--compiler/ghc.cabal.in1
59 files changed, 546 insertions, 345 deletions
diff --git a/compiler/GHC/Builtin/Utils.hs b/compiler/GHC/Builtin/Utils.hs
index 75515de9f2..9874edc9b7 100644
--- a/compiler/GHC/Builtin/Utils.hs
+++ b/compiler/GHC/Builtin/Utils.hs
@@ -198,15 +198,20 @@ knownKeyNamesOkay all_names
-- known-key thing.
lookupKnownKeyName :: Unique -> Maybe Name
lookupKnownKeyName u =
- knownUniqueName u <|> lookupUFM knownKeysMap u
+ knownUniqueName u <|> lookupUFM_Directly knownKeysMap u
-- | Is a 'Name' known-key?
isKnownKeyName :: Name -> Bool
isKnownKeyName n =
isJust (knownUniqueName $ nameUnique n) || elemUFM n knownKeysMap
-knownKeysMap :: UniqFM Name
-knownKeysMap = listToUFM [ (nameUnique n, n) | n <- knownKeyNames ]
+-- | Maps 'Unique's to known-key names.
+--
+-- The type is @UniqFM Name Name@ to denote that the 'Unique's used
+-- in the domain are 'Unique's associated with 'Name's (as opposed
+-- to some other namespace of 'Unique's).
+knownKeysMap :: UniqFM Name Name
+knownKeysMap = listToIdentityUFM knownKeyNames
-- | Given a 'Unique' lookup any associated arbitrary SDoc's to be displayed by
-- GHCi's ':info' command.
diff --git a/compiler/GHC/Cmm/LayoutStack.hs b/compiler/GHC/Cmm/LayoutStack.hs
index b8cf2c4900..689e5a0e46 100644
--- a/compiler/GHC/Cmm/LayoutStack.hs
+++ b/compiler/GHC/Cmm/LayoutStack.hs
@@ -224,7 +224,7 @@ data StackMap = StackMap
, sm_ret_off :: ByteOff
-- ^ Number of words of stack that we do not describe with an info
-- table, because it contains an update frame.
- , sm_regs :: UniqFM (LocalReg,StackLoc)
+ , sm_regs :: UniqFM LocalReg (LocalReg,StackLoc)
-- ^ regs on the stack
}
diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y
index cadda66b11..eeab41df7b 100644
--- a/compiler/GHC/Cmm/Parser.y
+++ b/compiler/GHC/Cmm/Parser.y
@@ -907,7 +907,7 @@ exprOp name args_code = do
mo <- nameToMachOp name
return $ mkMachOp mo args_code
-exprMacros :: DynFlags -> UniqFM ([CmmExpr] -> CmmExpr)
+exprMacros :: DynFlags -> UniqFM FastString ([CmmExpr] -> CmmExpr)
exprMacros dflags = listToUFM [
( fsLit "ENTRY_CODE", \ [x] -> entryCode platform x ),
( fsLit "INFO_PTR", \ [x] -> closureInfoPtr dflags x ),
@@ -990,7 +990,7 @@ machOps = listToUFM $
( "i2f64", flip MO_SF_Conv W64 )
]
-callishMachOps :: UniqFM ([CmmExpr] -> (CallishMachOp, [CmmExpr]))
+callishMachOps :: UniqFM FastString ([CmmExpr] -> (CallishMachOp, [CmmExpr]))
callishMachOps = listToUFM $
map (\(x, y) -> (mkFastString x, y)) [
( "read_barrier", (MO_ReadBarrier,)),
@@ -1090,7 +1090,7 @@ stmtMacro fun args_code = do
args <- sequence args_code
code (fcode args)
-stmtMacros :: UniqFM ([CmmExpr] -> FCode ())
+stmtMacros :: UniqFM FastString ([CmmExpr] -> FCode ())
stmtMacros = listToUFM [
( fsLit "CCS_ALLOC", \[words,ccs] -> profAlloc words ccs ),
( fsLit "ENTER_CCS_THUNK", \[e] -> enterCostCentreThunk e ),
diff --git a/compiler/GHC/Cmm/Sink.hs b/compiler/GHC/Cmm/Sink.hs
index 8c32ab01aa..bd8c19d2d3 100644
--- a/compiler/GHC/Cmm/Sink.hs
+++ b/compiler/GHC/Cmm/Sink.hs
@@ -420,7 +420,7 @@ tryToInline
tryToInline dflags live node assigs = go usages node emptyLRegSet assigs
where
- usages :: UniqFM Int -- Maps each LocalReg to a count of how often it is used
+ usages :: UniqFM LocalReg Int -- Maps each LocalReg to a count of how often it is used
usages = foldLocalRegsUsed dflags addUsage emptyUFM node
go _usages node _skipped [] = (node, [])
@@ -553,7 +553,7 @@ improveConditional other = other
-- inline y, and we have a dead assignment to x. If we don't notice
-- that x is dead in tryToInline, we end up retaining it.
-addUsage :: UniqFM Int -> LocalReg -> UniqFM Int
+addUsage :: UniqFM LocalReg Int -> LocalReg -> UniqFM LocalReg Int
addUsage m r = addToUFM_C (+) m r 1
regsUsedIn :: LRegSet -> CmmExpr -> Bool
diff --git a/compiler/GHC/CmmToAsm.hs b/compiler/GHC/CmmToAsm.hs
index 9252556b6a..90b0305308 100644
--- a/compiler/GHC/CmmToAsm.hs
+++ b/compiler/GHC/CmmToAsm.hs
@@ -66,6 +66,7 @@ import GHC.Settings.Config
import GHC.CmmToAsm.Instr
import GHC.CmmToAsm.PIC
import GHC.Platform.Reg
+import GHC.Platform.Reg.Class (RegClass)
import GHC.CmmToAsm.Monad
import GHC.CmmToAsm.CFG
import GHC.CmmToAsm.Dwarf
@@ -607,7 +608,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
|| gopt Opt_RegsIterative dflags )
then do
-- the regs usable for allocation
- let (alloc_regs :: UniqFM (UniqSet RealReg))
+ let (alloc_regs :: UniqFM RegClass (UniqSet RealReg))
= foldr (\r -> plusUFM_C unionUniqSets
$ unitUFM (targetClassOfRealReg platform r) (unitUniqSet r))
emptyUFM
diff --git a/compiler/GHC/CmmToAsm/BlockLayout.hs b/compiler/GHC/CmmToAsm/BlockLayout.hs
index 08af8e9f9f..57d265782b 100644
--- a/compiler/GHC/CmmToAsm/BlockLayout.hs
+++ b/compiler/GHC/CmmToAsm/BlockLayout.hs
@@ -29,7 +29,6 @@ import GHC.Platform
import GHC.Driver.Session (gopt, GeneralFlag(..), DynFlags, targetPlatform)
import GHC.Types.Unique.FM
import GHC.Utils.Misc
-import GHC.Types.Unique
import GHC.Data.Graph.Directed
import GHC.Utils.Outputable
@@ -926,8 +925,8 @@ seqBlocks infos blocks = placeNext pullable0 todo0
= pprPanic "seqBlocks" (ppr tooManyNextNodes)
-lookupDeleteUFM :: Uniquable key => UniqFM elt -> key
- -> Maybe (elt, UniqFM elt)
+lookupDeleteUFM :: UniqFM BlockId elt -> BlockId
+ -> Maybe (elt, UniqFM BlockId elt)
lookupDeleteUFM m k = do -- Maybe monad
v <- lookupUFM m k
return (v, delFromUFM m k)
diff --git a/compiler/GHC/CmmToAsm/Monad.hs b/compiler/GHC/CmmToAsm/Monad.hs
index 88d8f4b17c..2827e7026c 100644
--- a/compiler/GHC/CmmToAsm/Monad.hs
+++ b/compiler/GHC/CmmToAsm/Monad.hs
@@ -119,7 +119,7 @@ data NatM_State
-- generated instructions. So instead we update the CFG as we go.
}
-type DwarfFiles = UniqFM (FastString, Int)
+type DwarfFiles = UniqFM FastString (FastString, Int)
newtype NatM result = NatM (NatM_State -> (result, NatM_State))
deriving (Functor)
diff --git a/compiler/GHC/CmmToAsm/Reg/Graph.hs b/compiler/GHC/CmmToAsm/Reg/Graph.hs
index 022c9eed4c..fad2750ef4 100644
--- a/compiler/GHC/CmmToAsm/Reg/Graph.hs
+++ b/compiler/GHC/CmmToAsm/Reg/Graph.hs
@@ -46,7 +46,7 @@ maxSpinCount = 10
regAlloc
:: (Outputable statics, Outputable instr, Instruction instr)
=> NCGConfig
- -> UniqFM (UniqSet RealReg) -- ^ registers we can use for allocation
+ -> UniqFM RegClass (UniqSet RealReg) -- ^ registers we can use for allocation
-> UniqSet Int -- ^ set of available spill slots.
-> Int -- ^ current number of spill slots
-> [LiveCmmDecl statics instr] -- ^ code annotated with liveness information.
@@ -96,7 +96,7 @@ regAlloc_spin
-> Color.Triv VirtualReg RegClass RealReg
-- ^ Function for calculating whether a register is trivially
-- colourable.
- -> UniqFM (UniqSet RealReg) -- ^ Free registers that we can allocate.
+ -> UniqFM RegClass (UniqSet RealReg) -- ^ Free registers that we can allocate.
-> UniqSet Int -- ^ Free stack slots that we can use.
-> Int -- ^ Number of spill slots in use
-> [RegAllocStats statics instr] -- ^ Current regalloc stats to add to.
diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/Coalesce.hs b/compiler/GHC/CmmToAsm/Reg/Graph/Coalesce.hs
index 0bdee541ed..ccf92baaf9 100644
--- a/compiler/GHC/CmmToAsm/Reg/Graph/Coalesce.hs
+++ b/compiler/GHC/CmmToAsm/Reg/Graph/Coalesce.hs
@@ -44,7 +44,7 @@ regCoalesce code
-- | Add a v1 = v2 register renaming to the map.
-- The register with the lowest lexical name is set as the
-- canonical version.
-buildAlloc :: UniqFM Reg -> (Reg, Reg) -> UniqFM Reg
+buildAlloc :: UniqFM Reg Reg -> (Reg, Reg) -> UniqFM Reg Reg
buildAlloc fm (r1, r2)
= let rmin = min r1 r2
rmax = max r1 r2
@@ -53,7 +53,7 @@ buildAlloc fm (r1, r2)
-- | Determine the canonical name for a register by following
-- v1 = v2 renamings in this map.
-sinkReg :: UniqFM Reg -> Reg -> Reg
+sinkReg :: UniqFM Reg Reg -> Reg -> Reg
sinkReg fm r
= case lookupUFM fm r of
Nothing -> r
diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs b/compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs
index 4694ba6b96..6226c1c269 100644
--- a/compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs
+++ b/compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs
@@ -10,6 +10,7 @@ module GHC.CmmToAsm.Reg.Graph.Spill (
import GHC.Prelude
import GHC.CmmToAsm.Reg.Liveness
+import GHC.CmmToAsm.Reg.Utils
import GHC.CmmToAsm.Instr
import GHC.Platform.Reg
import GHC.Cmm hiding (RegSet)
@@ -69,8 +70,11 @@ regSpill platform code slotsFree slotCount regs
= do
-- Allocate a slot for each of the spilled regs.
let slots = take (sizeUniqSet regs) $ nonDetEltsUniqSet slotsFree
- let regSlotMap = listToUFM
- $ zip (nonDetEltsUniqSet regs) slots
+ let
+ regSlotMap = toRegMap -- Cast keys from VirtualReg to Reg
+ -- See Note [UniqFM and the register allocator]
+ $ listToUFM
+ $ zip (nonDetEltsUniqSet regs) slots :: UniqFM Reg Int
-- This is non-deterministic but we do not
-- currently support deterministic code-generation.
-- See Note [Unique Determinism and code generation]
@@ -158,7 +162,7 @@ regSpill_top platform regSlotMap cmm
regSpill_block
:: Instruction instr
=> Platform
- -> UniqFM Int -- ^ map of vregs to slots they're being spilled to.
+ -> UniqFM Reg Int -- ^ map of vregs to slots they're being spilled to.
-> LiveBasicBlock instr
-> SpillM (LiveBasicBlock instr)
@@ -174,7 +178,7 @@ regSpill_block platform regSlotMap (BasicBlock i instrs)
regSpill_instr
:: Instruction instr
=> Platform
- -> UniqFM Int -- ^ map of vregs to slots they're being spilled to.
+ -> UniqFM Reg Int -- ^ map of vregs to slots they're being spilled to.
-> LiveInstr instr
-> SpillM [LiveInstr instr]
@@ -223,7 +227,7 @@ regSpill_instr platform regSlotMap
-- writes to a vreg that is being spilled.
spillRead
:: Instruction instr
- => UniqFM Int
+ => UniqFM Reg Int
-> instr
-> Reg
-> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
@@ -246,7 +250,7 @@ spillRead regSlotMap instr reg
-- writes to a vreg that is being spilled.
spillWrite
:: Instruction instr
- => UniqFM Int
+ => UniqFM Reg Int
-> instr
-> Reg
-> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
@@ -269,7 +273,7 @@ spillWrite regSlotMap instr reg
-- both reads and writes to a vreg that is being spilled.
spillModify
:: Instruction instr
- => UniqFM Int
+ => UniqFM Reg Int
-> instr
-> Reg
-> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
@@ -334,7 +338,7 @@ data SpillS
stateUS :: UniqSupply
-- | Spilled vreg vs the number of times it was loaded, stored.
- , stateSpillSL :: UniqFM (Reg, Int, Int) }
+ , stateSpillSL :: UniqFM Reg (Reg, Int, Int) }
-- | Create a new spiller state.
@@ -366,7 +370,7 @@ accSpillSL (r1, s1, l1) (_, s2, l2)
-- Tells us what registers were spilled.
data SpillStats
= SpillStats
- { spillStoreLoad :: UniqFM (Reg, Int, Int) }
+ { spillStoreLoad :: UniqFM Reg (Reg, Int, Int) }
-- | Extract spiller statistics from the spiller state.
diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs b/compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs
index a5016abc6f..fec35cb6bc 100644
--- a/compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs
+++ b/compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE ScopedTypeVariables #-}
-- | Clean out unneeded spill\/reload instructions.
--
@@ -340,7 +341,7 @@ cleanBackward liveSlotsOnEntry noReloads acc lis
cleanBackward'
:: Instruction instr
=> BlockMap IntSet
- -> UniqFM [BlockId]
+ -> UniqFM Store [BlockId]
-> UniqSet Int
-> [LiveInstr instr]
-> [LiveInstr instr]
@@ -438,17 +439,17 @@ type CleanM
data CleanS
= CleanS
{ -- | Regs which are valid at the start of each block.
- sJumpValid :: UniqFM (Assoc Store)
+ sJumpValid :: UniqFM BlockId (Assoc Store)
-- | Collecting up what regs were valid across each jump.
-- in the next pass we can collate these and write the results
-- to sJumpValid.
- , sJumpValidAcc :: UniqFM [Assoc Store]
+ , sJumpValidAcc :: UniqFM BlockId [Assoc Store]
-- | Map of (slot -> blocks which reload from this slot)
-- used to decide if whether slot spilled to will ever be
-- reloaded from on this path.
- , sReloadedBy :: UniqFM [BlockId]
+ , sReloadedBy :: UniqFM Store [BlockId]
-- | Spills and reloads cleaned each pass (latest at front)
, sCleanedCount :: [(Int, Int)]
@@ -533,7 +534,8 @@ instance Outputable Store where
-- In the spill cleaner, two store locations are associated if they are known
-- to hold the same value.
--
-type Assoc a = UniqFM (UniqSet a)
+-- TODO: Monomorphize: I think we only ever use this with a ~ Store
+type Assoc a = UniqFM a (UniqSet a)
-- | An empty association
emptyAssoc :: Assoc a
@@ -541,8 +543,9 @@ emptyAssoc = emptyUFM
-- | Add an association between these two things.
-addAssoc :: Uniquable a
- => a -> a -> Assoc a -> Assoc a
+-- addAssoc :: Uniquable a
+-- => a -> a -> Assoc a -> Assoc a
+addAssoc :: Store -> Store -> Assoc Store -> Assoc Store
addAssoc a b m
= let m1 = addToUFM_C unionUniqSets m a (unitUniqSet b)
@@ -551,9 +554,7 @@ addAssoc a b m
-- | Delete all associations to a node.
-delAssoc :: (Uniquable a)
- => a -> Assoc a -> Assoc a
-
+delAssoc :: Store -> Assoc Store -> Assoc Store
delAssoc a m
| Just aSet <- lookupUFM m a
, m1 <- delFromUFM m a
@@ -565,9 +566,7 @@ delAssoc a m
-- | Delete a single association edge (a -> b).
-delAssoc1 :: Uniquable a
- => a -> a -> Assoc a -> Assoc a
-
+delAssoc1 :: Store -> Store -> Assoc Store -> Assoc Store
delAssoc1 a b m
| Just aSet <- lookupUFM m a
= addToUFM m a (delOneFromUniqSet aSet b)
@@ -576,17 +575,14 @@ delAssoc1 a b m
-- | Check if these two things are associated.
-elemAssoc :: (Uniquable a)
- => a -> a -> Assoc a -> Bool
+elemAssoc :: Store -> Store -> Assoc Store -> Bool
elemAssoc a b m
= elementOfUniqSet b (closeAssoc a m)
-- | Find the refl. trans. closure of the association from this point.
-closeAssoc :: (Uniquable a)
- => a -> Assoc a -> UniqSet a
-
+closeAssoc :: Store -> Assoc Store -> UniqSet Store
closeAssoc a assoc
= closeAssoc' assoc emptyUniqSet (unitUniqSet a)
where
@@ -615,6 +611,6 @@ closeAssoc a assoc
(unionUniqSets toVisit neighbors)
-- | Intersect two associations.
-intersectAssoc :: Assoc a -> Assoc a -> Assoc a
+intersectAssoc :: Assoc Store -> Assoc Store -> Assoc Store
intersectAssoc a b
= intersectUFM_C (intersectUniqSets) a b
diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs b/compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs
index 995b286839..1ea380fabf 100644
--- a/compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs
+++ b/compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs
@@ -48,9 +48,9 @@ type SpillCostRecord
-- | Map of `SpillCostRecord`
type SpillCostInfo
- = UniqFM SpillCostRecord
+ = UniqFM VirtualReg SpillCostRecord
-type SpillCostState = State (UniqFM SpillCostRecord) ()
+type SpillCostState = State SpillCostInfo ()
-- | An empty map of spill costs.
zeroSpillCostInfo :: SpillCostInfo
@@ -264,7 +264,7 @@ spillCost_length info _ reg
-- | Extract a map of register lifetimes from a `SpillCostInfo`.
-lifeMapFromSpillCostInfo :: SpillCostInfo -> UniqFM (VirtualReg, Int)
+lifeMapFromSpillCostInfo :: SpillCostInfo -> UniqFM VirtualReg (VirtualReg, Int)
lifeMapFromSpillCostInfo info
= listToUFM
$ map (\(r, _, _, life) -> (r, (r, life)))
diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs b/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs
index ddd353c4f2..a0b1519a93 100644
--- a/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs
+++ b/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs
@@ -64,7 +64,7 @@ data RegAllocStats statics instr
, raGraph :: Color.Graph VirtualReg RegClass RealReg
-- | The regs that were coalesced.
- , raCoalesced :: UniqFM VirtualReg
+ , raCoalesced :: UniqFM VirtualReg VirtualReg
-- | Spiller stats.
, raSpillStats :: SpillStats
@@ -88,7 +88,7 @@ data RegAllocStats statics instr
, raGraphColored :: Color.Graph VirtualReg RegClass RealReg
-- | Regs that were coalesced.
- , raCoalesced :: UniqFM VirtualReg
+ , raCoalesced :: UniqFM VirtualReg VirtualReg
-- | Code with coalescings applied.
, raCodeCoalesced :: [LiveCmmDecl statics instr]
@@ -242,7 +242,7 @@ pprStatsLifetimes stats
$$ text "\n")
-binLifetimeCount :: UniqFM (VirtualReg, Int) -> UniqFM (Int, Int)
+binLifetimeCount :: UniqFM VirtualReg (VirtualReg, Int) -> UniqFM Int (Int, Int)
binLifetimeCount fm
= let lifes = map (\l -> (l, (l, 1)))
$ map snd
diff --git a/compiler/GHC/CmmToAsm/Reg/Linear.hs b/compiler/GHC/CmmToAsm/Reg/Linear.hs
index 55cb73af1a..f777a21ca6 100644
--- a/compiler/GHC/CmmToAsm/Reg/Linear.hs
+++ b/compiler/GHC/CmmToAsm/Reg/Linear.hs
@@ -119,6 +119,7 @@ import qualified GHC.CmmToAsm.Reg.Linear.X86 as X86
import qualified GHC.CmmToAsm.Reg.Linear.X86_64 as X86_64
import GHC.CmmToAsm.Reg.Target
import GHC.CmmToAsm.Reg.Liveness
+import GHC.CmmToAsm.Reg.Utils
import GHC.CmmToAsm.Instr
import GHC.CmmToAsm.Config
import GHC.Platform.Reg
@@ -427,7 +428,7 @@ raInsn _ new_instrs _ (LiveInstr ii@(Instr i) Nothing)
raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live))
= do
- assig <- getAssigR
+ assig <- getAssigR :: RegM freeRegs (UniqFM Reg Loc)
-- If we have a reg->reg move between virtual registers, where the
-- src register is not live after this instruction, and the dst
@@ -486,7 +487,8 @@ isInReg src assig | Just (InReg _) <- lookupUFM assig src = True
| otherwise = False
-genRaInsn :: OutputableRegConstraint freeRegs instr
+genRaInsn :: forall freeRegs instr.
+ OutputableRegConstraint freeRegs instr
=> BlockMap RegSet
-> [instr]
-> BlockId
@@ -500,13 +502,13 @@ genRaInsn block_live new_instrs block_id instr r_dying w_dying = do
platform <- getPlatform
case regUsageOfInstr platform instr of { RU read written ->
do
- let real_written = [ rr | (RegReal rr) <- written ]
+ let real_written = [ rr | (RegReal rr) <- written ] :: [RealReg]
let virt_written = [ vr | (RegVirtual vr) <- written ]
-- we don't need to do anything with real registers that are
-- only read by this instr. (the list is typically ~2 elements,
-- so using nub isn't a problem).
- let virt_read = nub [ vr | (RegVirtual vr) <- read ]
+ let virt_read = nub [ vr | (RegVirtual vr) <- read ] :: [VirtualReg]
-- debugging
{- freeregs <- getFreeRegsR
@@ -560,15 +562,20 @@ genRaInsn block_live new_instrs block_id instr r_dying w_dying = do
let
-- (i) Patch the instruction
+ patch_map :: UniqFM Reg Reg
patch_map
- = listToUFM
+ = toRegMap $ -- Cast key from VirtualReg to Reg
+ -- See Note [UniqFM and the register allocator]
+ listToUFM
[ (t, RegReal r)
| (t, r) <- zip virt_read r_allocd
++ zip virt_written w_allocd ]
+ patched_instr :: instr
patched_instr
= patchRegsOfInstr adjusted_instr patchLookup
+ patchLookup :: Reg -> Reg
patchLookup x
= case lookupUFM patch_map x of
Nothing -> x
@@ -631,7 +638,8 @@ releaseRegs regs = do
--
saveClobberedTemps
- :: (Instruction instr, FR freeRegs)
+ :: forall instr freeRegs.
+ (Instruction instr, FR freeRegs)
=> [RealReg] -- real registers clobbered by this instruction
-> [Reg] -- registers which are no longer live after this insn
-> RegM freeRegs [instr] -- return: instructions to spill any temps that will
@@ -642,8 +650,10 @@ saveClobberedTemps [] _
saveClobberedTemps clobbered dying
= do
- assig <- getAssigR
- let to_spill
+ assig <- getAssigR :: RegM freeRegs (UniqFM Reg Loc)
+ -- Unique represents the VirtualReg
+ let to_spill :: [(Unique, RealReg)]
+ to_spill
= [ (temp,reg)
| (temp, InReg reg) <- nonDetUFMToList assig
-- This is non-deterministic but we do not
@@ -657,6 +667,8 @@ saveClobberedTemps clobbered dying
return instrs
where
+ -- See Note [UniqFM and the register allocator]
+ clobber :: RegMap Loc -> [instr] -> [(Unique,RealReg)] -> RegM freeRegs ([instr], RegMap Loc)
clobber assig instrs []
= return (instrs, assig)
@@ -675,7 +687,7 @@ saveClobberedTemps clobbered dying
(my_reg : _) -> do
setFreeRegsR (frAllocateReg platform my_reg freeRegs)
- let new_assign = addToUFM assig temp (InReg my_reg)
+ let new_assign = addToUFM_Directly assig temp (InReg my_reg)
let instr = mkRegRegMoveInstr platform
(RegReal reg) (RegReal my_reg)
@@ -688,7 +700,7 @@ saveClobberedTemps clobbered dying
-- record why this reg was spilled for profiling
recordSpill (SpillClobber temp)
- let new_assign = addToUFM assig temp (InBoth reg slot)
+ let new_assign = addToUFM_Directly assig temp (InBoth reg slot)
clobber new_assign (spill : instrs) rest
@@ -719,12 +731,13 @@ clobberRegs clobbered
-- also catches temps which were loaded up during allocation
-- of read registers, not just those saved in saveClobberedTemps.
+ clobber :: RegMap Loc -> [(Unique,Loc)] -> RegMap Loc
clobber assig []
= assig
clobber assig ((temp, InBoth reg slot) : rest)
| any (realRegsAlias reg) clobbered
- = clobber (addToUFM assig temp (InMem slot)) rest
+ = clobber (addToUFM_Directly assig temp (InMem slot)) rest
clobber assig (_:rest)
= clobber assig rest
@@ -762,8 +775,9 @@ allocateRegsAndSpill _ _ spills alloc []
= return (spills, reverse alloc)
allocateRegsAndSpill reading keep spills alloc (r:rs)
- = do assig <- getAssigR :: RegM freeRegs (RegMap Loc)
+ = do assig <- toVRegMap <$> getAssigR
-- pprTraceM "allocateRegsAndSpill:assig" (ppr (r:rs) $$ ppr assig)
+ -- See Note [UniqFM and the register allocator]
let doSpill = allocRegsAndSpill_spill reading keep spills alloc r rs assig
case lookupUFM assig r of
-- case (1a): already in a register
@@ -776,7 +790,7 @@ allocateRegsAndSpill reading keep spills alloc (r:rs)
-- NB2. This is why we must process written registers here, even if they
-- are also read by the same instruction.
Just (InBoth my_reg _)
- -> do when (not reading) (setAssigR (addToUFM assig r (InReg my_reg)))
+ -> do when (not reading) (setAssigR $ toRegMap (addToUFM assig r (InReg my_reg)))
allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
-- Not already in a register, so we need to find a free one...
@@ -801,15 +815,14 @@ allocateRegsAndSpill reading keep spills alloc (r:rs)
-- Note: I tried returning a list of past assignments, but that
-- turned out to barely matter but added a few tenths of
-- a percent to compile time.
-findPrefRealReg :: forall freeRegs u. Uniquable u
- => u -> RegM freeRegs (Maybe RealReg)
+findPrefRealReg :: VirtualReg -> RegM freeRegs (Maybe RealReg)
findPrefRealReg vreg = do
bassig <- getBlockAssigR :: RegM freeRegs (BlockMap (freeRegs,RegMap Loc))
return $ foldr (findVirtRegAssig) Nothing bassig
where
findVirtRegAssig :: (freeRegs,RegMap Loc) -> Maybe RealReg -> Maybe RealReg
findVirtRegAssig assig z =
- z <|> case lookupUFM (snd assig) vreg of
+ z <|> case lookupUFM (toVRegMap $ snd assig) vreg of
Just (InReg real_reg) -> Just real_reg
Just (InBoth real_reg _) -> Just real_reg
_ -> z
@@ -823,7 +836,7 @@ allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, Outputable instr)
-> [RealReg]
-> VirtualReg
-> [VirtualReg]
- -> UniqFM Loc
+ -> UniqFM VirtualReg Loc
-> SpillLoc
-> RegM freeRegs ([instr], [RealReg])
allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc
@@ -845,7 +858,8 @@ allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc
= first_free
spills' <- loadTemp r spill_loc final_reg spills
- setAssigR (addToUFM assig r $! newLocation spill_loc final_reg)
+ setAssigR $ toRegMap
+ $ (addToUFM assig r $! newLocation spill_loc final_reg)
setFreeRegsR $ frAllocateReg platform final_reg freeRegs
allocateRegsAndSpill reading keep spills' (final_reg : alloc) rs
@@ -856,7 +870,7 @@ allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc
do let inRegOrBoth (InReg _) = True
inRegOrBoth (InBoth _ _) = True
inRegOrBoth _ = False
- let candidates' :: UniqFM Loc
+ let candidates' :: UniqFM VirtualReg Loc
candidates' =
flip delListFromUFM keep $
filterUFM inRegOrBoth $
@@ -867,7 +881,8 @@ allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc
let candidates = nonDetUFMToList candidates'
-- the vregs we could kick out that are already in a slot
- let candidates_inBoth
+ let candidates_inBoth :: [(Unique, RealReg, StackSlot)]
+ candidates_inBoth
= [ (temp, reg, mem)
| (temp, InBoth reg mem) <- candidates
, targetClassOfRealReg platform reg == classOfVirtualReg r ]
@@ -885,10 +900,10 @@ allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc
-- just free up its register for use.
| (temp, my_reg, slot) : _ <- candidates_inBoth
= do spills' <- loadTemp r spill_loc my_reg spills
- let assig1 = addToUFM assig temp (InMem slot)
+ let assig1 = addToUFM_Directly assig temp (InMem slot)
let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg
- setAssigR assig2
+ setAssigR $ toRegMap assig2
allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs
-- otherwise, we need to spill a temporary that currently
@@ -905,9 +920,9 @@ allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc
recordSpill (SpillAlloc temp_to_push_out)
-- update the register assignment
- let assig1 = addToUFM assig temp_to_push_out (InMem slot)
+ let assig1 = addToUFM_Directly assig temp_to_push_out (InMem slot)
let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg
- setAssigR assig2
+ setAssigR $ toRegMap assig2
-- if need be, load up a spilled temp into the reg we've just freed up.
spills' <- loadTemp r spill_loc my_reg spills
diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/Base.hs b/compiler/GHC/CmmToAsm/Reg/Linear/Base.hs
index 6a110f0a48..33a15fd7b8 100644
--- a/compiler/GHC/CmmToAsm/Reg/Linear/Base.hs
+++ b/compiler/GHC/CmmToAsm/Reg/Linear/Base.hs
@@ -100,7 +100,9 @@ data SpillReason
-- | Used to carry interesting stats out of the register allocator.
data RegAllocStats
= RegAllocStats
- { ra_spillInstrs :: UniqFM [Int]
+ { ra_spillInstrs :: UniqFM Unique [Int] -- Keys are the uniques of regs
+ -- and taken from SpillReason
+ -- See Note [UniqFM and the register allocator]
, ra_fixupList :: [(BlockId,BlockId,BlockId)]
-- ^ (from,fixup,to) : We inserted fixup code between from and to
}
diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs b/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs
index 4ceaf4573b..8d3a46f490 100644
--- a/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs
+++ b/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs
@@ -146,8 +146,8 @@ joinToTargets_again :: (Instruction instr, FR freeRegs, Outputable instr)
-> instr
-> BlockId
-> [BlockId]
- -> UniqFM Loc
- -> UniqFM Loc
+ -> UniqFM Reg Loc
+ -> UniqFM Reg Loc
-> RegM freeRegs ([NatBasicBlock instr], instr)
joinToTargets_again
block_live new_blocks block_id instr dest dests
diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/StackMap.hs b/compiler/GHC/CmmToAsm/Reg/Linear/StackMap.hs
index 29864f9752..97e04936b0 100644
--- a/compiler/GHC/CmmToAsm/Reg/Linear/StackMap.hs
+++ b/compiler/GHC/CmmToAsm/Reg/Linear/StackMap.hs
@@ -34,8 +34,9 @@ data StackMap
{ -- | The slots that are still available to be allocated.
stackMapNextFreeSlot :: !Int
+ -- See Note [UniqFM and the register allocator]
-- | Assignment of vregs to stack slots.
- , stackMapAssignment :: UniqFM StackSlot }
+ , stackMapAssignment :: UniqFM Unique StackSlot }
-- | An empty stack map, with all slots available.
diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/Stats.hs b/compiler/GHC/CmmToAsm/Reg/Linear/Stats.hs
index 414128b32c..6411e5285d 100644
--- a/compiler/GHC/CmmToAsm/Reg/Linear/Stats.hs
+++ b/compiler/GHC/CmmToAsm/Reg/Linear/Stats.hs
@@ -11,6 +11,7 @@ import GHC.Prelude
import GHC.CmmToAsm.Reg.Linear.Base
import GHC.CmmToAsm.Reg.Liveness
import GHC.CmmToAsm.Instr
+import GHC.Types.Unique (Unique)
import GHC.Types.Unique.FM
import GHC.Utils.Outputable
@@ -19,8 +20,8 @@ import GHC.Utils.Monad.State
-- | Build a map of how many times each reg was alloced, clobbered, loaded etc.
binSpillReasons
- :: [SpillReason] -> UniqFM [Int]
-
+ :: [SpillReason] -> UniqFM Unique [Int]
+ -- See Note [UniqFM and the register allocator]
binSpillReasons reasons
= addListToUFM_C
(zipWith (+))
@@ -61,6 +62,8 @@ pprStats
pprStats code statss
= let -- sum up all the instrs inserted by the spiller
+ -- See Note [UniqFM and the register allocator]
+ spills :: UniqFM Unique [Int]
spills = foldl' (plusUFM_C (zipWith (+)))
emptyUFM
$ map ra_spillInstrs statss
diff --git a/compiler/GHC/CmmToAsm/Reg/Liveness.hs b/compiler/GHC/CmmToAsm/Reg/Liveness.hs
index f650ad6186..13dbcc5f70 100644
--- a/compiler/GHC/CmmToAsm/Reg/Liveness.hs
+++ b/compiler/GHC/CmmToAsm/Reg/Liveness.hs
@@ -66,9 +66,14 @@ import Data.IntSet (IntSet)
-----------------------------------------------------------------------------
type RegSet = UniqSet Reg
-type RegMap a = UniqFM a
+-- | Map from some kind of register to a.
+--
+-- While we give the type for keys as Reg which is the common case
+-- sometimes we end up using VirtualReq or naked Uniques.
+-- See Note [UniqFM and the register allocator]
+type RegMap a = UniqFM Reg a
-emptyRegMap :: UniqFM a
+emptyRegMap :: RegMap a
emptyRegMap = emptyUFM
emptyRegSet :: RegSet
@@ -76,6 +81,9 @@ emptyRegSet = emptyUniqSet
type BlockMap a = LabelMap a
+type SlotMap a = UniqFM Slot a
+
+type Slot = Int
-- | A top level thing which carries liveness information.
type LiveCmmDecl statics instr
@@ -400,7 +408,7 @@ slurpReloadCoalesce live
in unionManyBags (cs : moveBags)
slurpCompM :: [LiveBasicBlock instr]
- -> State (UniqFM [UniqFM Reg]) [Bag (Reg, Reg)]
+ -> State (UniqFM BlockId [UniqFM Slot Reg]) [Bag (Reg, Reg)]
slurpCompM blocks
= do -- run the analysis once to record the mapping across jumps.
mapM_ (slurpBlock False) blocks
@@ -412,7 +420,7 @@ slurpReloadCoalesce live
mapM (slurpBlock True) blocks
slurpBlock :: Bool -> LiveBasicBlock instr
- -> State (UniqFM [UniqFM Reg]) (Bag (Reg, Reg))
+ -> State (UniqFM BlockId [UniqFM Slot Reg]) (Bag (Reg, Reg))
slurpBlock propagate (BasicBlock blockId instrs)
= do -- grab the slot map for entry to this block
slotMap <- if propagate
@@ -422,12 +430,12 @@ slurpReloadCoalesce live
(_, mMoves) <- mapAccumLM slurpLI slotMap instrs
return $ listToBag $ catMaybes mMoves
- slurpLI :: UniqFM Reg -- current slotMap
+ slurpLI :: SlotMap Reg -- current slotMap
-> LiveInstr instr
- -> State (UniqFM [UniqFM Reg]) -- blockId -> [slot -> reg]
+ -> State (UniqFM BlockId [SlotMap Reg]) -- blockId -> [slot -> reg]
-- for tracking slotMaps across jumps
- ( UniqFM Reg -- new slotMap
+ ( SlotMap Reg -- new slotMap
, Maybe (Reg, Reg)) -- maybe a new coalesce edge
slurpLI slotMap li
@@ -467,15 +475,18 @@ slurpReloadCoalesce live
let slotMaps = fromMaybe [] (lookupUFM map blockId)
return $ foldr mergeSlotMaps emptyUFM slotMaps
- mergeSlotMaps :: UniqFM Reg -> UniqFM Reg -> UniqFM Reg
+ mergeSlotMaps :: SlotMap Reg -> SlotMap Reg -> SlotMap Reg
mergeSlotMaps map1 map2
- = listToUFM
+ -- toList sadly means we have to use the _Directly style
+ -- functions.
+ -- TODO: We shouldn't need to go through a list here.
+ = listToUFM_Directly
$ [ (k, r1)
| (k, r1) <- nonDetUFMToList map1
-- This is non-deterministic but we do not
-- currently support deterministic code-generation.
-- See Note [Unique Determinism and code generation]
- , case lookupUFM map2 k of
+ , case lookupUFM_Directly map2 k of
Nothing -> False
Just r2 -> r1 == r2 ]
diff --git a/compiler/GHC/CmmToAsm/Reg/Utils.hs b/compiler/GHC/CmmToAsm/Reg/Utils.hs
new file mode 100644
index 0000000000..3a832963fe
--- /dev/null
+++ b/compiler/GHC/CmmToAsm/Reg/Utils.hs
@@ -0,0 +1,59 @@
+module GHC.CmmToAsm.Reg.Utils
+ ( toRegMap, toVRegMap )
+where
+
+{- Note [UniqFM and the register allocator]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ Before UniqFM had a key type the register allocator
+ wasn't picky about key types, using VirtualReg, Reg
+ and Unique at various use sites for the same map.
+
+ This is safe.
+ * The Unique values come from registers at various
+ points where we lose a reference to the original
+ register value, but the unique is still valid.
+
+ * VirtualReg is a subset of the registers in Reg's type.
+ Making a value of VirtualReg into a Reg in fact doesn't
+ change its unique. This is because Reg consists of virtual
+ regs and real regs, whose unique values do not overlap.
+
+ * Since the code was written in the assumption that keys are
+ not typed it's hard to reverse this assumption now. So we get
+ some gnarly but correct code where we often pass around Uniques
+ and switch between using Uniques, VirtualReg and RealReg as keys
+ of the same map. These issues were always there. But with the
+ now-typed keys they become visible. It's a classic case of not all
+ correct programs type checking.
+
+ We reduce some of the burden by providing a way to cast
+
+ UniqFM VirtualReg a
+
+ to
+
+ UniqFM Reg a
+
+ in this module. This is safe as Reg is the sum of VirtualReg and
+ RealReg. With each kind of register keeping the same unique when
+ treated as Reg.
+
+ TODO: If you take offense to this I encourage you to refactor this
+ code. I'm sure we can do with less casting of keys and direct use
+ of uniques. It might also be reasonable to just use a IntMap directly
+ instead of dealing with UniqFM at all.
+
+
+-}
+import GHC.Types.Unique.FM
+import GHC.Platform.Reg
+
+-- These should hopefully be zero cost.
+
+toRegMap :: UniqFM VirtualReg elt -> UniqFM Reg elt
+toRegMap = unsafeCastUFMKey
+
+toVRegMap :: UniqFM Reg elt -> UniqFM VirtualReg elt
+toVRegMap = unsafeCastUFMKey
+
diff --git a/compiler/GHC/CmmToAsm/X86/RegInfo.hs b/compiler/GHC/CmmToAsm/X86/RegInfo.hs
index de11279d54..3f7d50d319 100644
--- a/compiler/GHC/CmmToAsm/X86/RegInfo.hs
+++ b/compiler/GHC/CmmToAsm/X86/RegInfo.hs
@@ -38,13 +38,13 @@ regDotColor platform reg
Just str -> text str
_ -> panic "Register not assigned a color"
-regColors :: Platform -> UniqFM [Char]
+regColors :: Platform -> UniqFM RealReg [Char]
regColors platform = listToUFM (normalRegColors platform)
-normalRegColors :: Platform -> [(Reg,String)]
+normalRegColors :: Platform -> [(RealReg,String)]
normalRegColors platform =
- zip (map regSingle [0..lastint platform]) colors
- ++ zip (map regSingle [firstxmm..lastxmm platform]) greys
+ zip (map realRegSingle [0..lastint platform]) colors
+ ++ zip (map realRegSingle [firstxmm..lastxmm platform]) greys
where
-- 16 colors - enough for amd64 gp regs
colors = ["#800000","#ff0000","#808000","#ffff00","#008000"
diff --git a/compiler/GHC/CmmToLlvm/Base.hs b/compiler/GHC/CmmToLlvm/Base.hs
index 7f60d660cb..ead3572a79 100644
--- a/compiler/GHC/CmmToLlvm/Base.hs
+++ b/compiler/GHC/CmmToLlvm/Base.hs
@@ -305,7 +305,7 @@ data LlvmEnv = LlvmEnv
, envOutput :: BufHandle -- ^ Output buffer
, envMask :: !Char -- ^ Mask for creating unique values
, envFreshMeta :: MetaId -- ^ Supply of fresh metadata IDs
- , envUniqMeta :: UniqFM MetaId -- ^ Global metadata nodes
+ , envUniqMeta :: UniqFM Unique MetaId -- ^ Global metadata nodes
, envFunMap :: LlvmEnvMap -- ^ Global functions so far, with type
, envAliases :: UniqSet LMString -- ^ Globals that we had to alias, see [Llvm Forward References]
, envUsedVars :: [LlvmVar] -- ^ Pointers to be added to llvm.used (see @cmmUsedLlvmGens@)
@@ -315,7 +315,7 @@ data LlvmEnv = LlvmEnv
, envStackRegs :: [GlobalReg] -- ^ Non-constant registers (alloca'd in the function prelude)
}
-type LlvmEnvMap = UniqFM LlvmType
+type LlvmEnvMap = UniqFM Unique LlvmType
-- | The Llvm monad. Wraps @LlvmEnv@ state as well as the @IO@ monad
newtype LlvmM a = LlvmM { runLlvmM :: LlvmEnv -> IO (a, LlvmEnv) }
@@ -397,13 +397,13 @@ withClearVars m = LlvmM $ \env -> do
-- | Insert variables or functions into the environment.
varInsert, funInsert :: Uniquable key => key -> LlvmType -> LlvmM ()
-varInsert s t = modifyEnv $ \env -> env { envVarMap = addToUFM (envVarMap env) s t }
-funInsert s t = modifyEnv $ \env -> env { envFunMap = addToUFM (envFunMap env) s t }
+varInsert s t = modifyEnv $ \env -> env { envVarMap = addToUFM (envVarMap env) (getUnique s) t }
+funInsert s t = modifyEnv $ \env -> env { envFunMap = addToUFM (envFunMap env) (getUnique s) t }
-- | Lookup variables or functions in the environment.
varLookup, funLookup :: Uniquable key => key -> LlvmM (Maybe LlvmType)
-varLookup s = getEnv (flip lookupUFM s . envVarMap)
-funLookup s = getEnv (flip lookupUFM s . envFunMap)
+varLookup s = getEnv (flip lookupUFM (getUnique s) . envVarMap)
+funLookup s = getEnv (flip lookupUFM (getUnique s) . envFunMap)
-- | Set a register as allocated on the stack
markStackReg :: GlobalReg -> LlvmM ()
diff --git a/compiler/GHC/Core/FamInstEnv.hs b/compiler/GHC/Core/FamInstEnv.hs
index 4a685ba096..a693927db4 100644
--- a/compiler/GHC/Core/FamInstEnv.hs
+++ b/compiler/GHC/Core/FamInstEnv.hs
@@ -352,7 +352,10 @@ UniqFM and UniqDFM.
See Note [Deterministic UniqFM].
-}
-type FamInstEnv = UniqDFM FamilyInstEnv -- Maps a family to its instances
+-- Internally we sometimes index by Name instead of TyCon despite
+-- of what the type says. This is safe since
+-- getUnique (tyCon) == getUniqe (tcName tyCon)
+type FamInstEnv = UniqDFM TyCon FamilyInstEnv -- Maps a family to its instances
-- See Note [FamInstEnv]
-- See Note [FamInstEnv determinism]
@@ -365,6 +368,14 @@ newtype FamilyInstEnv
instance Outputable FamilyInstEnv where
ppr (FamIE fs) = text "FamIE" <+> vcat (map ppr fs)
+-- | Index a FamInstEnv by the tyCons name.
+toNameInstEnv :: FamInstEnv -> UniqDFM Name FamilyInstEnv
+toNameInstEnv = unsafeCastUDFMKey
+
+-- | Create a FamInstEnv from Name indices.
+fromNameInstEnv :: UniqDFM Name FamilyInstEnv -> FamInstEnv
+fromNameInstEnv = unsafeCastUDFMKey
+
-- INVARIANTS:
-- * The fs_tvs are distinct in each FamInst
-- of a range value of the map (so we can safely unify them)
@@ -398,7 +409,7 @@ extendFamInstEnvList inst_env fis = foldl' extendFamInstEnv inst_env fis
extendFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv
extendFamInstEnv inst_env
ins_item@(FamInst {fi_fam = cls_nm})
- = addToUDFM_C add inst_env cls_nm (FamIE [ins_item])
+ = fromNameInstEnv $ addToUDFM_C add (toNameInstEnv inst_env) cls_nm (FamIE [ins_item])
where
add (FamIE items) _ = FamIE (ins_item:items)
diff --git a/compiler/GHC/Core/InstEnv.hs b/compiler/GHC/Core/InstEnv.hs
index 61d3ac0f55..74295a738f 100644
--- a/compiler/GHC/Core/InstEnv.hs
+++ b/compiler/GHC/Core/InstEnv.hs
@@ -42,6 +42,7 @@ import GHC.Types.Var
import GHC.Types.Var.Set
import GHC.Types.Name
import GHC.Types.Name.Set
+import GHC.Types.Unique (getUnique)
import GHC.Core.Unify
import GHC.Utils.Outputable
import GHC.Utils.Error
@@ -385,7 +386,16 @@ Testing with nofib and validate detected no difference between UniqFM and
UniqDFM. See also Note [Deterministic UniqFM]
-}
-type InstEnv = UniqDFM ClsInstEnv -- Maps Class to instances for that class
+-- Internally it's safe to indexable this map by
+-- by @Class@, the classes @Name@, the classes @TyCon@
+-- or it's @Unique@.
+-- This is since:
+-- getUnique cls == getUnique (className cls) == getUnique (classTyCon cls)
+--
+-- We still use Class as key type as it's both the common case
+-- and conveys the meaning better. But the implementation of
+--InstEnv is a bit more lax internally.
+type InstEnv = UniqDFM Class ClsInstEnv -- Maps Class to instances for that class
-- See Note [InstEnv determinism]
-- | 'InstEnvs' represents the combination of the global type class instance
@@ -457,7 +467,7 @@ classInstances (InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible =
memberInstEnv :: InstEnv -> ClsInst -> Bool
memberInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm } ) =
maybe False (\(ClsIE items) -> any (identicalDFunType ins_item) items)
- (lookupUDFM inst_env cls_nm)
+ (lookupUDFM_Directly inst_env (getUnique cls_nm))
where
identicalDFunType cls1 cls2 =
eqType (varType (is_dfun cls1)) (varType (is_dfun cls2))
@@ -467,13 +477,13 @@ extendInstEnvList inst_env ispecs = foldl' extendInstEnv inst_env ispecs
extendInstEnv :: InstEnv -> ClsInst -> InstEnv
extendInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm })
- = addToUDFM_C add inst_env cls_nm (ClsIE [ins_item])
+ = addToUDFM_C_Directly add inst_env (getUnique cls_nm) (ClsIE [ins_item])
where
add (ClsIE cur_insts) _ = ClsIE (ins_item : cur_insts)
deleteFromInstEnv :: InstEnv -> ClsInst -> InstEnv
deleteFromInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm })
- = adjustUDFM adjust inst_env cls_nm
+ = adjustUDFM_Directly adjust inst_env (getUnique cls_nm)
where
adjust (ClsIE items) = ClsIE (filterOut (identicalClsInstHead ins_item) items)
diff --git a/compiler/GHC/Core/Opt/OccurAnal.hs b/compiler/GHC/Core/Opt/OccurAnal.hs
index 9cc0953efd..500c2bdab6 100644
--- a/compiler/GHC/Core/Opt/OccurAnal.hs
+++ b/compiler/GHC/Core/Opt/OccurAnal.hs
@@ -2230,12 +2230,12 @@ addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv
addAppCtxt env@(OccEnv { occ_one_shots = ctxt }) args
= env { occ_one_shots = replicate (valArgCount args) OneShotLam ++ ctxt }
-transClosureFV :: UniqFM VarSet -> UniqFM VarSet
+transClosureFV :: VarEnv VarSet -> VarEnv VarSet
-- If (f,g), (g,h) are in the input, then (f,h) is in the output
-- as well as (f,g), (g,h)
transClosureFV env
| no_change = env
- | otherwise = transClosureFV (listToUFM new_fv_list)
+ | otherwise = transClosureFV (listToUFM_Directly new_fv_list)
where
(no_change, new_fv_list) = mapAccumL bump True (nonDetUFMToList env)
-- It's OK to use nonDetUFMToList here because we'll forget the
@@ -2247,10 +2247,10 @@ transClosureFV env
(new_fvs, no_change_here) = extendFvs env fvs
-------------
-extendFvs_ :: UniqFM VarSet -> VarSet -> VarSet
+extendFvs_ :: VarEnv VarSet -> VarSet -> VarSet
extendFvs_ env s = fst (extendFvs env s) -- Discard the Bool flag
-extendFvs :: UniqFM VarSet -> VarSet -> (VarSet, Bool)
+extendFvs :: VarEnv VarSet -> VarSet -> (VarSet, Bool)
-- (extendFVs env s) returns
-- (s `union` env(s), env(s) `subset` s)
extendFvs env s
diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs
index ee0590061c..37f85c3822 100644
--- a/compiler/GHC/Core/Opt/SpecConstr.hs
+++ b/compiler/GHC/Core/Opt/SpecConstr.hs
@@ -1090,7 +1090,7 @@ data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument
| ScrutOcc -- See Note [ScrutOcc]
(DataConEnv [ArgOcc]) -- How the sub-components are used
-type DataConEnv a = UniqFM a -- Keyed by DataCon
+type DataConEnv a = UniqFM DataCon a -- Keyed by DataCon
{- Note [ScrutOcc]
~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/Core/Tidy.hs b/compiler/GHC/Core/Tidy.hs
index 246da2be54..948b1e3673 100644
--- a/compiler/GHC/Core/Tidy.hs
+++ b/compiler/GHC/Core/Tidy.hs
@@ -26,6 +26,7 @@ import GHC.Core.Type ( tidyType, tidyVarBndr )
import GHC.Core.Coercion ( tidyCo )
import GHC.Types.Var
import GHC.Types.Var.Env
+import GHC.Types.Unique (getUnique)
import GHC.Types.Unique.FM
import GHC.Types.Name hiding (tidyNameOcc)
import GHC.Types.SrcLoc
@@ -121,7 +122,7 @@ tidyRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs,
tidyNameOcc :: TidyEnv -> Name -> Name
-- In rules and instances, we have Names, and we must tidy them too
-- Fortunately, we can lookup in the VarEnv with a name
-tidyNameOcc (_, var_env) n = case lookupUFM var_env n of
+tidyNameOcc (_, var_env) n = case lookupUFM_Directly var_env (getUnique n) of
Nothing -> n
Just v -> idName v
diff --git a/compiler/GHC/Data/FastString/Env.hs b/compiler/GHC/Data/FastString/Env.hs
index 3bc4ba6bec..05db9ace2a 100644
--- a/compiler/GHC/Data/FastString/Env.hs
+++ b/compiler/GHC/Data/FastString/Env.hs
@@ -40,7 +40,7 @@ import GHC.Data.FastString
-- deterministic and why it matters. Use DFastStringEnv if the set eventually
-- gets converted into a list or folded over in a way where the order
-- changes the generated code.
-type FastStringEnv a = UniqFM a -- Domain is FastString
+type FastStringEnv a = UniqFM FastString a -- Domain is FastString
emptyFsEnv :: FastStringEnv a
mkFsEnv :: [(FastString,a)] -> FastStringEnv a
@@ -85,7 +85,7 @@ lookupFsEnv_NF env n = expectJust "lookupFsEnv_NF" (lookupFsEnv env n)
-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why we need
-- DFastStringEnv.
-type DFastStringEnv a = UniqDFM a -- Domain is FastString
+type DFastStringEnv a = UniqDFM FastString a -- Domain is FastString
emptyDFsEnv :: DFastStringEnv a
emptyDFsEnv = emptyUDFM
diff --git a/compiler/GHC/Data/Graph/Base.hs b/compiler/GHC/Data/Graph/Base.hs
index 3c40645660..9e8cc383a4 100644
--- a/compiler/GHC/Data/Graph/Base.hs
+++ b/compiler/GHC/Data/Graph/Base.hs
@@ -45,7 +45,7 @@ type Triv k cls color
data Graph k cls color
= Graph {
-- | All active nodes in the graph.
- graphMap :: UniqFM (Node k cls color) }
+ graphMap :: UniqFM k (Node k cls color) }
-- | An empty graph.
@@ -57,7 +57,7 @@ initGraph
-- | Modify the finite map holding the nodes in the graph.
graphMapModify
- :: (UniqFM (Node k cls color) -> UniqFM (Node k cls color))
+ :: (UniqFM k (Node k cls color) -> UniqFM k (Node k cls color))
-> Graph k cls color -> Graph k cls color
graphMapModify f graph
diff --git a/compiler/GHC/Data/Graph/Color.hs b/compiler/GHC/Data/Graph/Color.hs
index 948447da58..e4189acb61 100644
--- a/compiler/GHC/Data/Graph/Color.hs
+++ b/compiler/GHC/Data/Graph/Color.hs
@@ -4,6 +4,7 @@
--
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module GHC.Data.Graph.Color (
module GHC.Data.Graph.Base,
@@ -37,19 +38,20 @@ import Data.List
-- the stack (ie in reverse order) and assigning them colors different to their neighbors.
--
colorGraph
- :: ( Uniquable k, Uniquable cls, Uniquable color
+ :: forall k cls color.
+ ( Uniquable k, Uniquable cls, Uniquable color
, Eq cls, Ord k
, Outputable k, Outputable cls, Outputable color)
=> Bool -- ^ whether to do iterative coalescing
-> Int -- ^ how many times we've tried to color this graph so far.
- -> UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class).
+ -> UniqFM cls (UniqSet color) -- ^ map of (node class -> set of colors available for this class).
-> Triv k cls color -- ^ fn to decide whether a node is trivially colorable.
-> (Graph k cls color -> k) -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable.
-> Graph k cls color -- ^ the graph to color.
-> ( Graph k cls color -- the colored graph.
, UniqSet k -- the set of nodes that we couldn't find a color for.
- , UniqFM k ) -- map of regs (r1 -> r2) that were coalesced
+ , UniqFM k k ) -- map of regs (r1 -> r2) that were coalesced
-- r1 should be replaced by r2 in the source
colorGraph iterative spinCount colors triv spill graph0
@@ -71,7 +73,7 @@ colorGraph iterative spinCount colors triv spill graph0
-- run the scanner to slurp out all the trivially colorable nodes
-- (and do coalescing if iterative coalescing is enabled)
- (ksTriv, ksProblems, kksCoalesce2)
+ (ksTriv, ksProblems, kksCoalesce2 :: [(k,k)])
= colorScan iterative triv spill graph_coalesced
-- If iterative coalescing is enabled, the scanner will coalesce the graph as does its business.
@@ -253,9 +255,10 @@ colorScan_spill iterative triv spill graph
-- | Try to assign a color to all these nodes.
assignColors
- :: ( Uniquable k, Uniquable cls, Uniquable color
+ :: forall k cls color.
+ ( Uniquable k, Uniquable cls, Uniquable color
, Outputable cls)
- => UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class).
+ => UniqFM cls (UniqSet color) -- ^ map of (node class -> set of colors available for this class).
-> Graph k cls color -- ^ the graph
-> [k] -- ^ nodes to assign a color to.
-> ( Graph k cls color -- the colored graph
@@ -264,7 +267,13 @@ assignColors
assignColors colors graph ks
= assignColors' colors graph [] ks
- where assignColors' _ graph prob []
+ where assignColors' :: UniqFM cls (UniqSet color) -- ^ map of (node class -> set of colors available for this class).
+ -> Graph k cls color -- ^ the graph
+ -> [k] -- ^ nodes to assign a color to.
+ -> [k]
+ -> ( Graph k cls color -- the colored graph
+ , [k])
+ assignColors' _ graph prob []
= (graph, prob)
assignColors' colors graph prob (k:ks)
@@ -293,7 +302,7 @@ assignColors colors graph ks
selectColor
:: ( Uniquable k, Uniquable cls, Uniquable color
, Outputable cls)
- => UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class).
+ => UniqFM cls (UniqSet color) -- ^ map of (node class -> set of colors available for this class).
-> Graph k cls color -- ^ the graph
-> k -- ^ key of the node to select a color for.
-> Maybe color
diff --git a/compiler/GHC/Data/Graph/Directed.hs b/compiler/GHC/Data/Graph/Directed.hs
index c3f397051a..5bd08b9641 100644
--- a/compiler/GHC/Data/Graph/Directed.hs
+++ b/compiler/GHC/Data/Graph/Directed.hs
@@ -507,8 +507,8 @@ classifyEdges root getSucc edges =
endFrom = getTime ends from
endTo = getTime ends to
- addTimes :: (Time, UniqFM Time, UniqFM Time) -> key
- -> (Time, UniqFM Time, UniqFM Time)
+ addTimes :: (Time, UniqFM key Time, UniqFM key Time) -> key
+ -> (Time, UniqFM key Time, UniqFM key Time)
addTimes (time,starts,ends) n
--Dont reenter nodes
| elemUFM n starts
diff --git a/compiler/GHC/Data/Graph/Ops.hs b/compiler/GHC/Data/Graph/Ops.hs
index 61f8bfe431..99e4a7eea0 100644
--- a/compiler/GHC/Data/Graph/Ops.hs
+++ b/compiler/GHC/Data/Graph/Ops.hs
@@ -218,8 +218,8 @@ addConflicts conflicts getClass
addConflictSet1 :: Uniquable k
=> k -> (k -> cls) -> UniqSet k
- -> UniqFM (Node k cls color)
- -> UniqFM (Node k cls color)
+ -> UniqFM k (Node k cls color)
+ -> UniqFM k (Node k cls color)
addConflictSet1 u getClass set
= case delOneFromUniqSet set u of
set' -> adjustWithDefaultUFM
@@ -645,7 +645,7 @@ checkNode graph node
slurpNodeConflictCount
:: Graph k cls color
- -> UniqFM (Int, Int) -- ^ (conflict neighbours, num nodes with that many conflicts)
+ -> UniqFM Int (Int, Int) -- ^ (conflict neighbours, num nodes with that many conflicts)
slurpNodeConflictCount graph
= addListToUFM_C
@@ -676,7 +676,7 @@ setColor u color
adjustWithDefaultUFM
:: Uniquable k
=> (a -> a) -> a -> k
- -> UniqFM a -> UniqFM a
+ -> UniqFM k a -> UniqFM k a
adjustWithDefaultUFM f def k map
= addToUFM_C
@@ -689,7 +689,7 @@ adjustWithDefaultUFM f def k map
adjustUFM_C
:: Uniquable k
=> (a -> a)
- -> k -> UniqFM a -> UniqFM a
+ -> k -> UniqFM k a -> UniqFM k a
adjustUFM_C f k map
= case lookupUFM map k of
diff --git a/compiler/GHC/Data/TrieMap.hs b/compiler/GHC/Data/TrieMap.hs
index e2506e3d4c..b3c7c5277f 100644
--- a/compiler/GHC/Data/TrieMap.hs
+++ b/compiler/GHC/Data/TrieMap.hs
@@ -33,7 +33,7 @@ import GHC.Prelude
import GHC.Types.Literal
import GHC.Types.Unique.DFM
-import GHC.Types.Unique( Unique )
+import GHC.Types.Unique( Uniquable )
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
@@ -202,8 +202,8 @@ See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for more details on how
deterministic.
-}
-instance TrieMap UniqDFM where
- type Key UniqDFM = Unique
+instance forall key. Uniquable key => TrieMap (UniqDFM key) where
+ type Key (UniqDFM key) = key
emptyTM = emptyUDFM
lookupTM k m = lookupUDFM m k
alterTM k f m = alterUDFM f m k
diff --git a/compiler/GHC/Driver/Types.hs b/compiler/GHC/Driver/Types.hs
index 748658c473..5671079723 100644
--- a/compiler/GHC/Driver/Types.hs
+++ b/compiler/GHC/Driver/Types.hs
@@ -3221,10 +3221,10 @@ instance Outputable CompleteMatch where
ppr (CompleteMatch cl ty) = text "CompleteMatch:" <+> ppr cl
<+> dcolon <+> ppr ty
--- | A map keyed by the 'completeMatchTyCon'.
+-- | A map keyed by the 'completeMatchTyCon' which has type Name.
-- See Note [Implementation of COMPLETE signatures]
-type CompleteMatchMap = UniqFM [CompleteMatch]
+type CompleteMatchMap = UniqFM Name [CompleteMatch]
mkCompleteMatchMap :: [CompleteMatch] -> CompleteMatchMap
mkCompleteMatchMap = extendCompleteMatchMap emptyUFM
diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs
index 0cd715634a..f803939da6 100644
--- a/compiler/GHC/HsToCore/Monad.hs
+++ b/compiler/GHC/HsToCore/Monad.hs
@@ -86,7 +86,7 @@ import GHC.Types.Name.Env
import GHC.Driver.Session
import GHC.Utils.Error
import GHC.Data.FastString
-import GHC.Types.Unique.FM ( lookupWithDefaultUFM )
+import GHC.Types.Unique.FM ( lookupWithDefaultUFM_Directly )
import GHC.Types.Literal ( mkLitString )
import GHC.Types.CostCentre.State
@@ -533,7 +533,10 @@ dsGetCompleteMatches :: TyCon -> DsM [CompleteMatch]
dsGetCompleteMatches tc = do
eps <- getEps
env <- getGblEnv
- let lookup_completes ufm = lookupWithDefaultUFM ufm [] tc
+ -- We index into a UniqFM from Name -> elt, for tyCon it holds that
+ -- getUnique (tyConName tc) == getUnique tc. So we lookup using the
+ -- unique directly instead.
+ let lookup_completes ufm = lookupWithDefaultUFM_Directly ufm [] (getUnique tc)
eps_matches_list = lookup_completes $ eps_complete_matches eps
env_matches_list = lookup_completes $ ds_complete_matches env
return $ eps_matches_list ++ env_matches_list
diff --git a/compiler/GHC/HsToCore/PmCheck/Oracle.hs b/compiler/GHC/HsToCore/PmCheck/Oracle.hs
index 7a213ce7ef..361ea04971 100644
--- a/compiler/GHC/HsToCore/PmCheck/Oracle.hs
+++ b/compiler/GHC/HsToCore/PmCheck/Oracle.hs
@@ -781,7 +781,7 @@ lookupRefuts :: Uniquable k => Delta -> k -> [PmAltCon]
-- Unfortunately we need the extra bit of polymorphism and the unfortunate
-- duplication of lookupVarInfo here.
lookupRefuts MkDelta{ delta_tm_st = ts@(TmSt (SDIE env) _) } k =
- case lookupUDFM env k of
+ case lookupUDFM_Directly env (getUnique k) of
Nothing -> []
Just (Indirect y) -> pmAltConSetElems (vi_neg (lookupVarInfo ts y))
Just (Entry vi) -> pmAltConSetElems (vi_neg vi)
diff --git a/compiler/GHC/HsToCore/PmCheck/Ppr.hs b/compiler/GHC/HsToCore/PmCheck/Ppr.hs
index 5b1fe16ba1..e4358e78b6 100644
--- a/compiler/GHC/HsToCore/PmCheck/Ppr.hs
+++ b/compiler/GHC/HsToCore/PmCheck/Ppr.hs
@@ -98,7 +98,7 @@ substitution to the vectors before printing them out (see function `pprOne' in
-- | Extract and assigns pretty names to constraint variables with refutable
-- shapes.
prettifyRefuts :: Delta -> DIdEnv SDoc -> DIdEnv (SDoc, [PmAltCon])
-prettifyRefuts delta = listToUDFM . map attach_refuts . udfmToList
+prettifyRefuts delta = listToUDFM_Directly . map attach_refuts . udfmToList
where
attach_refuts (u, sdoc) = (u, (sdoc, lookupRefuts delta u))
diff --git a/compiler/GHC/HsToCore/PmCheck/Types.hs b/compiler/GHC/HsToCore/PmCheck/Types.hs
index 9267555380..2d551fc1aa 100644
--- a/compiler/GHC/HsToCore/PmCheck/Types.hs
+++ b/compiler/GHC/HsToCore/PmCheck/Types.hs
@@ -6,6 +6,8 @@ Author: George Karachalias <george.karachalias@cs.kuleuven.be>
{-# LANGUAGE CPP #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ApplicativeDo #-}
-- | Types used through-out pattern match checking. This module is mostly there
-- to be imported from "GHC.Tc.Types". The exposed API is that of
@@ -458,11 +460,14 @@ setEntrySDIE :: SharedDIdEnv a -> Id -> a -> SharedDIdEnv a
setEntrySDIE sdie@(SDIE env) x a =
SDIE $ extendDVarEnv env (fst (lookupReprAndEntrySDIE sdie x)) (Entry a)
-traverseSDIE :: Applicative f => (a -> f b) -> SharedDIdEnv a -> f (SharedDIdEnv b)
-traverseSDIE f = fmap (SDIE . listToUDFM) . traverse g . udfmToList . unSDIE
+traverseSDIE :: forall a b f. Applicative f => (a -> f b) -> SharedDIdEnv a -> f (SharedDIdEnv b)
+traverseSDIE f = fmap (SDIE . listToUDFM_Directly) . traverse g . udfmToList . unSDIE
where
+ g :: (Unique, Shared a) -> f (Unique, Shared b)
g (u, Indirect y) = pure (u,Indirect y)
- g (u, Entry a) = (u,) . Entry <$> f a
+ g (u, Entry a) = do
+ a' <- f a
+ pure (u,Entry a')
instance Outputable a => Outputable (Shared a) where
ppr (Indirect x) = ppr x
diff --git a/compiler/GHC/Iface/Binary.hs b/compiler/GHC/Iface/Binary.hs
index d92aa742af..1e2f7060f1 100644
--- a/compiler/GHC/Iface/Binary.hs
+++ b/compiler/GHC/Iface/Binary.hs
@@ -286,7 +286,7 @@ binaryInterfaceMagic platform
-- The symbol table
--
-putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO ()
+putSymbolTable :: BinHandle -> Int -> UniqFM Name (Int,Name) -> IO ()
putSymbolTable bh next_off symtab = do
put_ bh next_off
let names = elems (array (0,next_off-1) (nonDetEltsUFM symtab))
@@ -327,7 +327,7 @@ fromOnDiskName nc (pid, mod_name, occ) =
new_cache = extendNameCache cache mod occ name
in ( nc{ nsUniqs = us, nsNames = new_cache }, name )
-serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()
+serialiseName :: BinHandle -> Name -> UniqFM key (Int,Name) -> IO ()
serialiseName bh name _ = do
let mod = ASSERT2( isExternalName name, ppr name ) nameModule name
put_ bh (moduleUnit mod, moduleName mod, nameOccName name)
@@ -399,7 +399,7 @@ getSymtabName _ncu _dict symtab bh = do
data BinSymbolTable = BinSymbolTable {
bin_symtab_next :: !FastMutInt, -- The next index to use
- bin_symtab_map :: !(IORef (UniqFM (Int,Name)))
+ bin_symtab_map :: !(IORef (UniqFM Name (Int,Name)))
-- indexed by Name
}
@@ -410,13 +410,13 @@ allocateFastString :: BinDictionary -> FastString -> IO Word32
allocateFastString BinDictionary { bin_dict_next = j_r,
bin_dict_map = out_r} f = do
out <- readIORef out_r
- let uniq = getUnique f
- case lookupUFM out uniq of
+ let !uniq = getUnique f
+ case lookupUFM_Directly out uniq of
Just (j, _) -> return (fromIntegral j :: Word32)
Nothing -> do
j <- readFastMutInt j_r
writeFastMutInt j_r (j + 1)
- writeIORef out_r $! addToUFM out uniq (j, f)
+ writeIORef out_r $! addToUFM_Directly out uniq (j, f)
return (fromIntegral j :: Word32)
getDictFastString :: Dictionary -> BinHandle -> IO FastString
@@ -426,7 +426,7 @@ getDictFastString dict bh = do
data BinDictionary = BinDictionary {
bin_dict_next :: !FastMutInt, -- The next index to use
- bin_dict_map :: !(IORef (UniqFM (Int,FastString)))
+ bin_dict_map :: !(IORef (UniqFM FastString (Int,FastString)))
-- indexed by FastString
}
diff --git a/compiler/GHC/Iface/Ext/Binary.hs b/compiler/GHC/Iface/Ext/Binary.hs
index 2fce4cd2ee..4fc3b9a331 100644
--- a/compiler/GHC/Iface/Ext/Binary.hs
+++ b/compiler/GHC/Iface/Ext/Binary.hs
@@ -2,6 +2,8 @@
Binary serialization for .hie files.
-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE BangPatterns #-}
+
module GHC.Iface.Ext.Binary
( readHieFile
, readHieFileWithVersion
@@ -48,12 +50,12 @@ import GHC.Iface.Ext.Types
data HieSymbolTable = HieSymbolTable
{ hie_symtab_next :: !FastMutInt
- , hie_symtab_map :: !(IORef (UniqFM (Int, HieName)))
+ , hie_symtab_map :: !(IORef (UniqFM Name (Int, HieName)))
}
data HieDictionary = HieDictionary
{ hie_dict_next :: !FastMutInt -- The next index to use
- , hie_dict_map :: !(IORef (UniqFM (Int,FastString))) -- indexed by FastString
+ , hie_dict_map :: !(IORef (UniqFM FastString (Int,FastString))) -- indexed by FastString
}
initBinMemSize :: Int
@@ -97,7 +99,7 @@ writeHieFile hie_file_path hiefile = do
-- Make some initial state
symtab_next <- newFastMutInt
writeFastMutInt symtab_next 0
- symtab_map <- newIORef emptyUFM
+ symtab_map <- newIORef emptyUFM :: IO (IORef (UniqFM Name (Int, HieName)))
let hie_symtab = HieSymbolTable {
hie_symtab_next = symtab_next,
hie_symtab_map = symtab_map }
@@ -257,16 +259,16 @@ putFastString HieDictionary { hie_dict_next = j_r,
hie_dict_map = out_r} bh f
= do
out <- readIORef out_r
- let unique = getUnique f
- case lookupUFM out unique of
+ let !unique = getUnique f
+ case lookupUFM_Directly out unique of
Just (j, _) -> put_ bh (fromIntegral j :: Word32)
Nothing -> do
j <- readFastMutInt j_r
put_ bh (fromIntegral j :: Word32)
writeFastMutInt j_r (j + 1)
- writeIORef out_r $! addToUFM out unique (j, f)
+ writeIORef out_r $! addToUFM_Directly out unique (j, f)
-putSymbolTable :: BinHandle -> Int -> UniqFM (Int,HieName) -> IO ()
+putSymbolTable :: BinHandle -> Int -> UniqFM Name (Int,HieName) -> IO ()
putSymbolTable bh next_off symtab = do
put_ bh next_off
let names = A.elems (A.array (0,next_off-1) (nonDetEltsUFM symtab))
diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x
index 7fd5a218d0..a2ca634c53 100644
--- a/compiler/GHC/Parser/Lexer.x
+++ b/compiler/GHC/Parser/Lexer.x
@@ -911,7 +911,7 @@ This did not work, so I opted for NoLexicalNegationBit instead.
-- facilitates using a keyword in two different extensions that can be
-- activated independently)
--
-reservedWordsFM :: UniqFM (Token, ExtsBitmap)
+reservedWordsFM :: UniqFM FastString (Token, ExtsBitmap)
reservedWordsFM = listToUFM $
map (\(x, y, z) -> (mkFastString x, (y, z)))
[( "_", ITunderscore, 0 ),
@@ -994,7 +994,7 @@ Also, note that these are included in the `varid` production in the parser --
a key detail to make all this work.
-------------------------------------}
-reservedSymsFM :: UniqFM (Token, IsUnicodeSyntax, ExtsBitmap)
+reservedSymsFM :: UniqFM FastString (Token, IsUnicodeSyntax, ExtsBitmap)
reservedSymsFM = listToUFM $
map (\ (x,w,y,z) -> (mkFastString x,(w,y,z)))
[ ("..", ITdotdot, NormalSyntax, 0 )
diff --git a/compiler/GHC/Platform/Reg.hs b/compiler/GHC/Platform/Reg.hs
index 37fd039ef7..c6679c8a70 100644
--- a/compiler/GHC/Platform/Reg.hs
+++ b/compiler/GHC/Platform/Reg.hs
@@ -8,6 +8,7 @@ module GHC.Platform.Reg (
Reg(..),
regPair,
regSingle,
+ realRegSingle,
isRealReg, takeRealReg,
isVirtualReg, takeVirtualReg,
@@ -181,7 +182,10 @@ data Reg
deriving (Eq, Ord)
regSingle :: RegNo -> Reg
-regSingle regNo = RegReal $ RealRegSingle regNo
+regSingle regNo = RegReal (realRegSingle regNo)
+
+realRegSingle :: RegNo -> RealReg
+realRegSingle regNo = RealRegSingle regNo
regPair :: RegNo -> RegNo -> Reg
regPair regNo1 regNo2 = RegReal $ RealRegPair regNo1 regNo2
diff --git a/compiler/GHC/Runtime/Interpreter/Types.hs b/compiler/GHC/Runtime/Interpreter/Types.hs
index 11f405815c..5c267f5ec1 100644
--- a/compiler/GHC/Runtime/Interpreter/Types.hs
+++ b/compiler/GHC/Runtime/Interpreter/Types.hs
@@ -15,6 +15,7 @@ import GHC.Prelude
import GHCi.RemoteTypes
import GHCi.Message ( Pipe )
import GHC.Types.Unique.FM
+import GHC.Data.FastString ( FastString )
import Foreign
import Control.Concurrent
@@ -53,7 +54,7 @@ data IServConfig = IServConfig
data IServInstance = IServInstance
{ iservPipe :: !Pipe
, iservProcess :: !ProcessHandle
- , iservLookupSymbolCache :: !(UniqFM (Ptr ()))
+ , iservLookupSymbolCache :: !(UniqFM FastString (Ptr ()))
, iservPendingFrees :: ![HValueRef]
-- ^ Values that need to be freed before the next command is sent.
-- Threads can append values to this list asynchronously (by modifying the
diff --git a/compiler/GHC/StgToCmm/ExtCode.hs b/compiler/GHC/StgToCmm/ExtCode.hs
index 987df399af..05909d4bb5 100644
--- a/compiler/GHC/StgToCmm/ExtCode.hs
+++ b/compiler/GHC/StgToCmm/ExtCode.hs
@@ -65,7 +65,7 @@ data Named
| LabelN BlockId -- ^ A blockid of some code or data.
-- | An environment of named things.
-type Env = UniqFM Named
+type Env = UniqFM FastString Named
-- | Local declarations that are in scope during code generation.
type Decls = [(FastString,Named)]
diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs
index 9ee420d4ca..de8a85b37a 100644
--- a/compiler/GHC/Tc/Gen/HsType.hs
+++ b/compiler/GHC/Tc/Gen/HsType.hs
@@ -862,11 +862,13 @@ tc_infer_hs_type mode (HsDocTy _ ty _) = tc_infer_lhs_type mode ty
-- See Note [Typechecking NHsCoreTys]
tc_infer_hs_type _ (XHsType (NHsCoreTy ty))
= do env <- getLclEnv
- let subst_prs = [ (nm, tv)
+ -- Raw uniques since we go from NameEnv to TvSubstEnv.
+ let subst_prs :: [(Unique, TcTyVar)]
+ subst_prs = [ (getUnique nm, tv)
| ATyVar nm tv <- nameEnvElts (tcl_env env) ]
subst = mkTvSubst
(mkInScopeSet $ mkVarSet $ map snd subst_prs)
- (listToUFM $ map (liftSnd mkTyVarTy) subst_prs)
+ (listToUFM_Directly $ map (liftSnd mkTyVarTy) subst_prs)
ty' = substTy subst ty
return (ty', tcTypeKind ty')
diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs
index 3c783b0137..14695fdd5a 100644
--- a/compiler/GHC/Tc/Solver/Monad.hs
+++ b/compiler/GHC/Tc/Solver/Monad.hs
@@ -2420,7 +2420,7 @@ not match the requested info exactly!
-}
-type TcAppMap a = UniqDFM (ListMap LooseTypeMap a)
+type TcAppMap a = UniqDFM Unique (ListMap LooseTypeMap a)
-- Indexed by tycon then the arg types, using "loose" matching, where
-- we don't require kind equality. This allows, for example, (a |> co)
-- to match (a).
@@ -2539,7 +2539,7 @@ findDict m loc cls tys
findDictsByClass :: DictMap a -> Class -> Bag a
findDictsByClass m cls
- | Just tm <- lookupUDFM m cls = foldTM consBag tm emptyBag
+ | Just tm <- lookupUDFM_Directly m (getUnique cls) = foldTM consBag tm emptyBag
| otherwise = emptyBag
delDict :: DictMap a -> Class -> [Type] -> DictMap a
@@ -2550,7 +2550,7 @@ addDict m cls tys item = insertTcApp m (getUnique cls) tys item
addDictsByClass :: DictMap Ct -> Class -> Bag Ct -> DictMap Ct
addDictsByClass m cls items
- = addToUDFM m cls (foldr add emptyTM items)
+ = addToUDFM_Directly m (getUnique cls) (foldr add emptyTM items)
where
add ct@(CDictCan { cc_tyargs = tys }) tm = insertTM tys ct tm
add ct _ = pprPanic "addDictsByClass" (ppr ct)
@@ -2600,8 +2600,8 @@ findFunEqsByTyCon :: FunEqMap a -> TyCon -> [a]
-- We use this to check for derived interactions with built-in type-function
-- constructors.
findFunEqsByTyCon m tc
- | Just tm <- lookupUDFM m tc = foldTM (:) tm []
- | otherwise = []
+ | Just tm <- lookupUDFM m (getUnique tc) = foldTM (:) tm []
+ | otherwise = []
foldFunEqs :: (a -> b -> b) -> FunEqMap a -> b -> b
foldFunEqs = foldTcAppMap
@@ -2632,17 +2632,17 @@ delFunEq :: FunEqMap a -> TyCon -> [Type] -> FunEqMap a
delFunEq m tc tys = delTcApp m (getUnique tc) tys
------------------------------
-type ExactFunEqMap a = UniqFM (ListMap TypeMap a)
+type ExactFunEqMap a = UniqFM TyCon (ListMap TypeMap a)
emptyExactFunEqs :: ExactFunEqMap a
emptyExactFunEqs = emptyUFM
findExactFunEq :: ExactFunEqMap a -> TyCon -> [Type] -> Maybe a
-findExactFunEq m tc tys = do { tys_map <- lookupUFM m (getUnique tc)
+findExactFunEq m tc tys = do { tys_map <- lookupUFM m tc
; lookupTM tys tys_map }
insertExactFunEq :: ExactFunEqMap a -> TyCon -> [Type] -> a -> ExactFunEqMap a
-insertExactFunEq m tc tys val = alterUFM alter_tm m (getUnique tc)
+insertExactFunEq m tc tys val = alterUFM alter_tm m tc
where alter_tm mb_tm = Just (insertTM tys val (mb_tm `orElse` emptyTM))
{-
diff --git a/compiler/GHC/Types/Literal.hs b/compiler/GHC/Types/Literal.hs
index 55f2ffaca6..93b8bd9b9d 100644
--- a/compiler/GHC/Types/Literal.hs
+++ b/compiler/GHC/Types/Literal.hs
@@ -643,10 +643,13 @@ absentLiteralOf :: TyCon -> Maybe Literal
-- Rubbish literals are handled in GHC.Core.Opt.WorkWrap.Utils, because
-- 1. Looking at the TyCon is not enough, we need the actual type
-- 2. This would need to return a type application to a literal
-absentLiteralOf tc = lookupUFM absent_lits (tyConName tc)
+absentLiteralOf tc = lookupUFM absent_lits tc
-absent_lits :: UniqFM Literal
-absent_lits = listToUFM [ (addrPrimTyConKey, LitNullAddr)
+absent_lits :: UniqFM TyCon Literal
+absent_lits = listToUFM_Directly
+ -- Explicitly construct the mape from the known
+ -- keys of these tyCons.
+ [ (addrPrimTyConKey, LitNullAddr)
, (charPrimTyConKey, LitChar 'x')
, (intPrimTyConKey, mkLitIntUnchecked 0)
, (int64PrimTyConKey, mkLitInt64Unchecked 0)
diff --git a/compiler/GHC/Types/Name/Env.hs b/compiler/GHC/Types/Name/Env.hs
index cf6d853003..1a94dc4fa0 100644
--- a/compiler/GHC/Types/Name/Env.hs
+++ b/compiler/GHC/Types/Name/Env.hs
@@ -93,7 +93,7 @@ depAnal get_defs get_uses nodes
-}
-- | Name Environment
-type NameEnv a = UniqFM a -- Domain is Name
+type NameEnv a = UniqFM Name a -- Domain is Name
emptyNameEnv :: NameEnv a
isEmptyNameEnv :: NameEnv a -> Bool
@@ -152,7 +152,7 @@ lookupNameEnv_NF env n = expectJust "lookupNameEnv_NF" (lookupNameEnv env n)
--
-- See Note [Deterministic UniqFM] in "GHC.Types.Unique.DFM" for explanation why
-- we need DNameEnv.
-type DNameEnv a = UniqDFM a
+type DNameEnv a = UniqDFM Name a
emptyDNameEnv :: DNameEnv a
emptyDNameEnv = emptyUDFM
diff --git a/compiler/GHC/Types/Name/Occurrence.hs b/compiler/GHC/Types/Name/Occurrence.hs
index 2ee0621b8b..ad6042a8f0 100644
--- a/compiler/GHC/Types/Name/Occurrence.hs
+++ b/compiler/GHC/Types/Name/Occurrence.hs
@@ -387,7 +387,7 @@ instance Uniquable OccName where
getUnique (OccName TvName fs) = mkTvOccUnique fs
getUnique (OccName TcClsName fs) = mkTcOccUnique fs
-newtype OccEnv a = A (UniqFM a)
+newtype OccEnv a = A (UniqFM OccName a)
deriving Data
emptyOccEnv :: OccEnv a
@@ -822,7 +822,7 @@ This is #12382.
-}
-type TidyOccEnv = UniqFM Int -- The in-scope OccNames
+type TidyOccEnv = UniqFM FastString Int -- The in-scope OccNames
-- See Note [TidyOccEnv]
emptyTidyOccEnv :: TidyOccEnv
diff --git a/compiler/GHC/Types/Unique/DFM.hs b/compiler/GHC/Types/Unique/DFM.hs
index 72f10d8082..56107a6087 100644
--- a/compiler/GHC/Types/Unique/DFM.hs
+++ b/compiler/GHC/Types/Unique/DFM.hs
@@ -29,10 +29,13 @@ module GHC.Types.Unique.DFM (
unitUDFM,
addToUDFM,
addToUDFM_C,
+ addToUDFM_C_Directly,
+ addToUDFM_Directly,
addListToUDFM,
delFromUDFM,
delListFromUDFM,
adjustUDFM,
+ adjustUDFM_Directly,
alterUDFM,
mapUDFM,
plusUDFM,
@@ -48,7 +51,7 @@ module GHC.Types.Unique.DFM (
disjointUDFM, disjointUdfmUfm,
equalKeysUDFM,
minusUDFM,
- listToUDFM,
+ listToUDFM, listToUDFM_Directly,
udfmMinusUFM, ufmMinusUDFM,
partitionUDFM,
anyUDFM, allUDFM,
@@ -57,6 +60,7 @@ module GHC.Types.Unique.DFM (
udfmToList,
udfmToUfm,
nonDetStrictFoldUDFM,
+ unsafeCastUDFMKey,
alwaysUnsafeUfmToUdfm,
) where
@@ -72,6 +76,7 @@ import Data.List (sortBy)
import Data.Function (on)
import qualified Data.Semigroup as Semi
import GHC.Types.Unique.FM (UniqFM, nonDetUFMToList, ufmToIntMap, unsafeIntMapToUFM)
+import Unsafe.Coerce
-- Note [Deterministic UniqFM]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -128,7 +133,13 @@ instance Eq val => Eq (TaggedVal val) where
(TaggedVal v1 _) == (TaggedVal v2 _) = v1 == v2
-- | Type of unique deterministic finite maps
-data UniqDFM ele =
+--
+-- The key is just here to keep us honest. It's always safe
+-- to use a single type as key.
+-- 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.
+data UniqDFM key ele =
UDFM
!(M.IntMap (TaggedVal ele)) -- A map where keys are Unique's values and
-- values are tagged with insertion time.
@@ -139,27 +150,27 @@ data UniqDFM ele =
deriving (Data, Functor)
-- | Deterministic, in O(n log n).
-instance Foldable UniqDFM where
+instance Foldable (UniqDFM key) where
foldr = foldUDFM
-- | Deterministic, in O(n log n).
-instance Traversable UniqDFM where
+instance Traversable (UniqDFM key) where
traverse f = fmap listToUDFM_Directly
. traverse (\(u,a) -> (u,) <$> f a)
. udfmToList
-emptyUDFM :: UniqDFM elt
+emptyUDFM :: UniqDFM key elt
emptyUDFM = UDFM M.empty 0
-unitUDFM :: Uniquable key => key -> elt -> UniqDFM elt
+unitUDFM :: Uniquable key => key -> elt -> UniqDFM key elt
unitUDFM k v = UDFM (M.singleton (getKey $ getUnique k) (TaggedVal v 0)) 1
-- The new binding always goes to the right of existing ones
-addToUDFM :: Uniquable key => UniqDFM elt -> key -> elt -> UniqDFM elt
+addToUDFM :: Uniquable key => UniqDFM key elt -> key -> elt -> UniqDFM key elt
addToUDFM m k v = addToUDFM_Directly m (getUnique k) v
-- The new binding always goes to the right of existing ones
-addToUDFM_Directly :: UniqDFM elt -> Unique -> elt -> UniqDFM elt
+addToUDFM_Directly :: UniqDFM key elt -> Unique -> elt -> UniqDFM key elt
addToUDFM_Directly (UDFM m i) u v
= UDFM (M.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1)
where
@@ -168,12 +179,12 @@ addToUDFM_Directly (UDFM m i) u v
-- This means that udfmToList typically returns elements
-- in the order of insertion, rather than the reverse
-addToUDFM_Directly_C
+addToUDFM_C_Directly
:: (elt -> elt -> elt) -- old -> new -> result
- -> UniqDFM elt
+ -> UniqDFM key elt
-> Unique -> elt
- -> UniqDFM elt
-addToUDFM_Directly_C f (UDFM m i) u v
+ -> UniqDFM key elt
+addToUDFM_C_Directly f (UDFM m i) u v
= UDFM (M.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1)
where
tf (TaggedVal new_v _) (TaggedVal old_v old_i)
@@ -184,25 +195,25 @@ addToUDFM_Directly_C f (UDFM m i) u v
addToUDFM_C
:: Uniquable key => (elt -> elt -> elt) -- old -> new -> result
- -> UniqDFM elt -- old
+ -> UniqDFM key elt -- old
-> key -> elt -- new
- -> UniqDFM elt -- result
-addToUDFM_C f m k v = addToUDFM_Directly_C f m (getUnique k) v
+ -> UniqDFM key elt -- result
+addToUDFM_C f m k v = addToUDFM_C_Directly f m (getUnique k) v
-addListToUDFM :: Uniquable key => UniqDFM elt -> [(key,elt)] -> UniqDFM elt
+addListToUDFM :: Uniquable key => UniqDFM key elt -> [(key,elt)] -> UniqDFM key elt
addListToUDFM = foldl' (\m (k, v) -> addToUDFM m k v)
-addListToUDFM_Directly :: UniqDFM elt -> [(Unique,elt)] -> UniqDFM elt
+addListToUDFM_Directly :: UniqDFM key elt -> [(Unique,elt)] -> UniqDFM key elt
addListToUDFM_Directly = foldl' (\m (k, v) -> addToUDFM_Directly m k v)
addListToUDFM_Directly_C
- :: (elt -> elt -> elt) -> UniqDFM elt -> [(Unique,elt)] -> UniqDFM elt
-addListToUDFM_Directly_C f = foldl' (\m (k, v) -> addToUDFM_Directly_C f m k v)
+ :: (elt -> elt -> elt) -> UniqDFM key elt -> [(Unique,elt)] -> UniqDFM key elt
+addListToUDFM_Directly_C f = foldl' (\m (k, v) -> addToUDFM_C_Directly f m k v)
-delFromUDFM :: Uniquable key => UniqDFM elt -> key -> UniqDFM elt
+delFromUDFM :: Uniquable key => UniqDFM key elt -> key -> UniqDFM key elt
delFromUDFM (UDFM m i) k = UDFM (M.delete (getKey $ getUnique k) m) i
-plusUDFM_C :: (elt -> elt -> elt) -> UniqDFM elt -> UniqDFM elt -> UniqDFM elt
+plusUDFM_C :: (elt -> elt -> elt) -> UniqDFM key elt -> UniqDFM key elt -> UniqDFM key elt
plusUDFM_C f udfml@(UDFM _ i) udfmr@(UDFM _ j)
-- we will use the upper bound on the tag as a proxy for the set size,
-- to insert the smaller one into the bigger one
@@ -242,126 +253,130 @@ plusUDFM_C f udfml@(UDFM _ i) udfmr@(UDFM _ j)
-- insertion order and O(m * min(n+m, W)) to insert them into the bigger
-- set.
-plusUDFM :: UniqDFM elt -> UniqDFM elt -> UniqDFM elt
+plusUDFM :: UniqDFM key elt -> UniqDFM key elt -> UniqDFM key elt
plusUDFM udfml@(UDFM _ i) udfmr@(UDFM _ j)
-- we will use the upper bound on the tag as a proxy for the set size,
-- to insert the smaller one into the bigger one
| i > j = insertUDFMIntoLeft udfml udfmr
| otherwise = insertUDFMIntoLeft udfmr udfml
-insertUDFMIntoLeft :: UniqDFM elt -> UniqDFM elt -> UniqDFM elt
+insertUDFMIntoLeft :: UniqDFM key elt -> UniqDFM key elt -> UniqDFM key elt
insertUDFMIntoLeft udfml udfmr = addListToUDFM_Directly udfml $ udfmToList udfmr
insertUDFMIntoLeft_C
- :: (elt -> elt -> elt) -> UniqDFM elt -> UniqDFM elt -> UniqDFM elt
+ :: (elt -> elt -> elt) -> UniqDFM key elt -> UniqDFM key elt -> UniqDFM key elt
insertUDFMIntoLeft_C f udfml udfmr =
addListToUDFM_Directly_C f udfml $ udfmToList udfmr
-lookupUDFM :: Uniquable key => UniqDFM elt -> key -> Maybe elt
+lookupUDFM :: Uniquable key => UniqDFM key elt -> key -> Maybe elt
lookupUDFM (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey $ getUnique k) m
-lookupUDFM_Directly :: UniqDFM elt -> Unique -> Maybe elt
+lookupUDFM_Directly :: UniqDFM key elt -> Unique -> Maybe elt
lookupUDFM_Directly (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey k) m
-elemUDFM :: Uniquable key => key -> UniqDFM elt -> Bool
+elemUDFM :: Uniquable key => key -> UniqDFM key elt -> Bool
elemUDFM k (UDFM m _i) = M.member (getKey $ getUnique k) m
-- | Performs a deterministic fold over the UniqDFM.
-- It's O(n log n) while the corresponding function on `UniqFM` is O(n).
-foldUDFM :: (elt -> a -> a) -> a -> UniqDFM elt -> a
+foldUDFM :: (elt -> a -> a) -> a -> UniqDFM key elt -> a
foldUDFM k z m = foldr k z (eltsUDFM m)
-- | Performs a nondeterministic strict fold over the UniqDFM.
-- It's O(n), same as the corresponding function on `UniqFM`.
-- If you use this please provide a justification why it doesn't introduce
-- nondeterminism.
-nonDetStrictFoldUDFM :: (elt -> a -> a) -> a -> UniqDFM elt -> a
+nonDetStrictFoldUDFM :: (elt -> a -> a) -> a -> UniqDFM key elt -> a
nonDetStrictFoldUDFM k z (UDFM m _i) = foldl' k' z m
where
k' acc (TaggedVal v _) = k v acc
-eltsUDFM :: UniqDFM elt -> [elt]
+eltsUDFM :: UniqDFM key elt -> [elt]
eltsUDFM (UDFM m _i) =
map taggedFst $ sortBy (compare `on` taggedSnd) $ M.elems m
-filterUDFM :: (elt -> Bool) -> UniqDFM elt -> UniqDFM elt
+filterUDFM :: (elt -> Bool) -> UniqDFM key elt -> UniqDFM key elt
filterUDFM p (UDFM m i) = UDFM (M.filter (\(TaggedVal v _) -> p v) m) i
-filterUDFM_Directly :: (Unique -> elt -> Bool) -> UniqDFM elt -> UniqDFM elt
+filterUDFM_Directly :: (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
-- | Converts `UniqDFM` to a list, with elements in deterministic order.
-- It's O(n log n) while the corresponding function on `UniqFM` is O(n).
-udfmToList :: UniqDFM elt -> [(Unique, elt)]
+udfmToList :: UniqDFM key elt -> [(Unique, elt)]
udfmToList (UDFM m _i) =
[ (getUnique k, taggedFst v)
| (k, v) <- sortBy (compare `on` (taggedSnd . snd)) $ M.toList m ]
-- Determines whether two 'UniqDFM's contain the same keys.
-equalKeysUDFM :: UniqDFM a -> UniqDFM b -> Bool
+equalKeysUDFM :: UniqDFM key a -> UniqDFM key b -> Bool
equalKeysUDFM (UDFM m1 _) (UDFM m2 _) = liftEq (\_ _ -> True) m1 m2
-isNullUDFM :: UniqDFM elt -> Bool
+isNullUDFM :: UniqDFM key elt -> Bool
isNullUDFM (UDFM m _) = M.null m
-sizeUDFM :: UniqDFM elt -> Int
+sizeUDFM :: UniqDFM key elt -> Int
sizeUDFM (UDFM m _i) = M.size m
-intersectUDFM :: UniqDFM elt -> UniqDFM elt -> UniqDFM elt
+intersectUDFM :: UniqDFM key elt -> UniqDFM key elt -> UniqDFM key elt
intersectUDFM (UDFM x i) (UDFM y _j) = UDFM (M.intersection x y) i
-- M.intersection is left biased, that means the result will only have
-- a subset of elements from the left set, so `i` is a good upper bound.
-udfmIntersectUFM :: UniqDFM elt1 -> UniqFM elt2 -> UniqDFM elt1
+udfmIntersectUFM :: UniqDFM key elt1 -> UniqFM key elt2 -> UniqDFM key elt1
udfmIntersectUFM (UDFM x i) y = UDFM (M.intersection x (ufmToIntMap y)) i
-- M.intersection is left biased, that means the result will only have
-- a subset of elements from the left set, so `i` is a good upper bound.
-disjointUDFM :: UniqDFM elt -> UniqDFM elt -> Bool
+disjointUDFM :: UniqDFM key elt -> UniqDFM key elt -> Bool
disjointUDFM (UDFM x _i) (UDFM y _j) = M.disjoint x y
-disjointUdfmUfm :: UniqDFM elt -> UniqFM elt2 -> Bool
+disjointUdfmUfm :: UniqDFM key elt -> UniqFM key elt2 -> Bool
disjointUdfmUfm (UDFM x _i) y = M.disjoint x (ufmToIntMap y)
-minusUDFM :: UniqDFM elt1 -> UniqDFM elt2 -> UniqDFM elt1
+minusUDFM :: UniqDFM key elt1 -> UniqDFM key elt2 -> UniqDFM key elt1
minusUDFM (UDFM x i) (UDFM y _j) = UDFM (M.difference x y) i
-- M.difference returns a subset of a left set, so `i` is a good upper
-- bound.
-udfmMinusUFM :: UniqDFM elt1 -> UniqFM elt2 -> UniqDFM elt1
+udfmMinusUFM :: UniqDFM key elt1 -> UniqFM key elt2 -> UniqDFM key elt1
udfmMinusUFM (UDFM x i) y = UDFM (M.difference x (ufmToIntMap y)) i
-- M.difference returns a subset of a left set, so `i` is a good upper
-- bound.
-ufmMinusUDFM :: UniqFM elt1 -> UniqDFM elt2 -> UniqFM elt1
+ufmMinusUDFM :: UniqFM key elt1 -> UniqDFM key elt2 -> UniqFM key elt1
ufmMinusUDFM x (UDFM y _i) = unsafeIntMapToUFM (M.difference (ufmToIntMap x) y)
-- | Partition UniqDFM into two UniqDFMs according to the predicate
-partitionUDFM :: (elt -> Bool) -> UniqDFM elt -> (UniqDFM elt, UniqDFM elt)
+partitionUDFM :: (elt -> Bool) -> UniqDFM key elt -> (UniqDFM key elt, UniqDFM key elt)
partitionUDFM p (UDFM m i) =
case M.partition (p . taggedFst) m of
(left, right) -> (UDFM left i, UDFM right i)
-- | Delete a list of elements from a UniqDFM
-delListFromUDFM :: Uniquable key => UniqDFM elt -> [key] -> UniqDFM elt
+delListFromUDFM :: Uniquable key => UniqDFM key elt -> [key] -> UniqDFM key elt
delListFromUDFM = foldl' delFromUDFM
-- | This allows for lossy conversion from UniqDFM to UniqFM
-udfmToUfm :: UniqDFM elt -> UniqFM elt
+udfmToUfm :: UniqDFM key elt -> UniqFM key elt
udfmToUfm (UDFM m _i) = unsafeIntMapToUFM (M.map taggedFst m)
-listToUDFM :: Uniquable key => [(key,elt)] -> UniqDFM elt
+listToUDFM :: Uniquable key => [(key,elt)] -> UniqDFM key elt
listToUDFM = foldl' (\m (k, v) -> addToUDFM m k v) emptyUDFM
-listToUDFM_Directly :: [(Unique, elt)] -> UniqDFM elt
+listToUDFM_Directly :: [(Unique, elt)] -> UniqDFM key elt
listToUDFM_Directly = foldl' (\m (u, v) -> addToUDFM_Directly m u v) emptyUDFM
-- | Apply a function to a particular element
-adjustUDFM :: Uniquable key => (elt -> elt) -> UniqDFM elt -> key -> UniqDFM elt
+adjustUDFM :: Uniquable key => (elt -> elt) -> UniqDFM key elt -> key -> UniqDFM key elt
adjustUDFM f (UDFM m i) k = UDFM (M.adjust (fmap f) (getKey $ getUnique k) m) i
+-- | Apply a function to a particular element
+adjustUDFM_Directly :: (elt -> elt) -> UniqDFM key elt -> Unique -> UniqDFM key elt
+adjustUDFM_Directly f (UDFM m i) k = UDFM (M.adjust (fmap f) (getKey k) m) i
+
-- | The expression (alterUDFM f k map) alters value x at k, or absence
-- thereof. alterUDFM can be used to insert, delete, or update a value in
-- UniqDFM. Use addToUDFM, delFromUDFM or adjustUDFM when possible, they are
@@ -369,9 +384,9 @@ adjustUDFM f (UDFM m i) k = UDFM (M.adjust (fmap f) (getKey $ getUnique k) m) i
alterUDFM
:: Uniquable key
=> (Maybe elt -> Maybe elt) -- How to adjust
- -> UniqDFM elt -- old
+ -> UniqDFM key elt -- old
-> key -- new
- -> UniqDFM elt -- result
+ -> UniqDFM key elt -- result
alterUDFM f (UDFM m i) k =
UDFM (M.alter alterf (getKey $ getUnique k) m) (i + 1)
where
@@ -381,39 +396,47 @@ alterUDFM f (UDFM m i) k =
inject (Just v) = Just $ TaggedVal v i
-- | Map a function over every value in a UniqDFM
-mapUDFM :: (elt1 -> elt2) -> UniqDFM elt1 -> UniqDFM elt2
+mapUDFM :: (elt1 -> elt2) -> UniqDFM key elt1 -> UniqDFM key elt2
mapUDFM f (UDFM m i) = UDFM (M.map (fmap f) m) i
-anyUDFM :: (elt -> Bool) -> UniqDFM elt -> Bool
+anyUDFM :: (elt -> Bool) -> UniqDFM key elt -> Bool
anyUDFM p (UDFM m _i) = M.foldr ((||) . p . taggedFst) False m
-allUDFM :: (elt -> Bool) -> UniqDFM elt -> Bool
+allUDFM :: (elt -> Bool) -> UniqDFM key elt -> Bool
allUDFM p (UDFM m _i) = M.foldr ((&&) . p . taggedFst) True m
-instance Semi.Semigroup (UniqDFM a) where
+instance Semi.Semigroup (UniqDFM key a) where
(<>) = plusUDFM
-instance Monoid (UniqDFM a) where
+instance Monoid (UniqDFM key a) where
mempty = emptyUDFM
mappend = (Semi.<>)
-- This should not be used in committed code, provided for convenience to
-- make ad-hoc conversions when developing
-alwaysUnsafeUfmToUdfm :: UniqFM elt -> UniqDFM elt
+alwaysUnsafeUfmToUdfm :: UniqFM key elt -> UniqDFM key elt
alwaysUnsafeUfmToUdfm = listToUDFM_Directly . nonDetUFMToList
+-- | Cast the key domain of a UniqFM.
+--
+-- As long as the domains don't overlap in their uniques
+-- this is safe.
+unsafeCastUDFMKey :: UniqDFM key1 elt -> UniqDFM key2 elt
+unsafeCastUDFMKey = unsafeCoerce -- Only phantom parameter changes so
+ -- this is safe and avoids reallocation.
+
-- Output-ery
-instance Outputable a => Outputable (UniqDFM a) where
+instance Outputable a => Outputable (UniqDFM key a) where
ppr ufm = pprUniqDFM ppr ufm
-pprUniqDFM :: (a -> SDoc) -> UniqDFM a -> SDoc
+pprUniqDFM :: (a -> SDoc) -> UniqDFM key a -> SDoc
pprUniqDFM ppr_elt ufm
= brackets $ fsep $ punctuate comma $
[ ppr uq <+> text ":->" <+> ppr_elt elt
| (uq, elt) <- udfmToList ufm ]
-pprUDFM :: UniqDFM a -- ^ The things to be pretty printed
+pprUDFM :: UniqDFM key a -- ^ The things to be pretty printed
-> ([a] -> SDoc) -- ^ The pretty printing function to use on the elements
-> SDoc -- ^ 'SDoc' where the things have been pretty
-- printed
diff --git a/compiler/GHC/Types/Unique/DSet.hs b/compiler/GHC/Types/Unique/DSet.hs
index 479b69ba0a..0ce46ab083 100644
--- a/compiler/GHC/Types/Unique/DSet.hs
+++ b/compiler/GHC/Types/Unique/DSet.hs
@@ -52,7 +52,7 @@ import qualified Data.Semigroup as Semi
-- Beyond preserving invariants, we may also want to 'override' typeclass
-- instances.
-newtype UniqDSet a = UniqDSet {getUniqDSet' :: UniqDFM a}
+newtype UniqDSet a = UniqDSet {getUniqDSet' :: UniqDFM a a}
deriving (Data, Semi.Semigroup, Monoid)
emptyUniqDSet :: UniqDSet a
@@ -87,14 +87,14 @@ unionManyUniqDSets (x:xs) = foldl' unionUniqDSets x xs
minusUniqDSet :: UniqDSet a -> UniqDSet a -> UniqDSet a
minusUniqDSet (UniqDSet s) (UniqDSet t) = UniqDSet (minusUDFM s t)
-uniqDSetMinusUniqSet :: UniqDSet a -> UniqSet b -> UniqDSet a
+uniqDSetMinusUniqSet :: UniqDSet a -> UniqSet a -> UniqDSet a
uniqDSetMinusUniqSet xs ys
= UniqDSet (udfmMinusUFM (getUniqDSet xs) (getUniqSet ys))
intersectUniqDSets :: UniqDSet a -> UniqDSet a -> UniqDSet a
intersectUniqDSets (UniqDSet s) (UniqDSet t) = UniqDSet (intersectUDFM s t)
-uniqDSetIntersectUniqSet :: UniqDSet a -> UniqSet b -> UniqDSet a
+uniqDSetIntersectUniqSet :: UniqDSet a -> UniqSet a -> UniqDSet a
uniqDSetIntersectUniqSet xs ys
= UniqDSet (udfmIntersectUFM (getUniqDSet xs) (getUniqSet ys))
@@ -134,7 +134,7 @@ mapUniqDSet f = mkUniqDSet . map f . uniqDSetToList
instance Eq (UniqDSet a) where
UniqDSet a == UniqDSet b = equalKeysUDFM a b
-getUniqDSet :: UniqDSet a -> UniqDFM a
+getUniqDSet :: UniqDSet a -> UniqDFM a a
getUniqDSet = getUniqDSet'
instance Outputable a => Outputable (UniqDSet a) where
diff --git a/compiler/GHC/Types/Unique/FM.hs b/compiler/GHC/Types/Unique/FM.hs
index fc33e9693f..41f3018a05 100644
--- a/compiler/GHC/Types/Unique/FM.hs
+++ b/compiler/GHC/Types/Unique/FM.hs
@@ -22,6 +22,7 @@ of arguments of combining function.
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wall #-}
module GHC.Types.Unique.FM (
@@ -36,6 +37,7 @@ module GHC.Types.Unique.FM (
listToUFM,
listToUFM_Directly,
listToUFM_C,
+ listToIdentityUFM,
addToUFM,addToUFM_C,addToUFM_Acc,
addListToUFM,addListToUFM_C,
addToUFM_Directly,
@@ -69,6 +71,7 @@ module GHC.Types.Unique.FM (
nonDetEltsUFM, eltsUFM, nonDetKeysUFM,
ufmToSet_Directly,
nonDetUFMToList, ufmToIntMap, unsafeIntMapToUFM,
+ unsafeCastUFMKey,
pprUniqFM, pprUFM, pprUFMWithKeys, pluralUFM
) where
@@ -83,57 +86,67 @@ import Data.Data
import qualified Data.Semigroup as Semi
import Data.Functor.Classes (Eq1 (..))
-
-newtype UniqFM ele = UFM (M.IntMap ele)
+-- | A finite map from @uniques@ of one type to
+-- elements in another type.
+--
+-- The key is just here to keep us honest. It's always safe
+-- to use a single type as key.
+-- 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)
deriving (Data, Eq, Functor)
-- Nondeterministic Foldable and Traversable instances are accessible through
-- use of the 'NonDetUniqFM' wrapper.
-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM to learn about determinism.
-emptyUFM :: UniqFM elt
+emptyUFM :: UniqFM key elt
emptyUFM = UFM M.empty
-isNullUFM :: UniqFM elt -> Bool
+isNullUFM :: UniqFM key elt -> Bool
isNullUFM (UFM m) = M.null m
-unitUFM :: Uniquable key => key -> elt -> UniqFM elt
+unitUFM :: Uniquable key => key -> elt -> UniqFM key elt
unitUFM k v = UFM (M.singleton (getKey $ getUnique k) v)
-- when you've got the Unique already
-unitDirectlyUFM :: Unique -> elt -> UniqFM elt
+unitDirectlyUFM :: Unique -> elt -> UniqFM key elt
unitDirectlyUFM u v = UFM (M.singleton (getKey u) v)
-listToUFM :: Uniquable key => [(key,elt)] -> UniqFM elt
+listToUFM :: Uniquable key => [(key,elt)] -> UniqFM key elt
listToUFM = foldl' (\m (k, v) -> addToUFM m k v) emptyUFM
-listToUFM_Directly :: [(Unique, elt)] -> UniqFM elt
+listToUFM_Directly :: [(Unique, elt)] -> UniqFM key elt
listToUFM_Directly = foldl' (\m (u, v) -> addToUFM_Directly m u v) emptyUFM
+listToIdentityUFM :: Uniquable key => [key] -> UniqFM key key
+listToIdentityUFM = foldl' (\m x -> addToUFM m x x) emptyUFM
+
listToUFM_C
:: Uniquable key
=> (elt -> elt -> elt)
-> [(key, elt)]
- -> UniqFM elt
+ -> UniqFM key elt
listToUFM_C f = foldl' (\m (k, v) -> addToUFM_C f m k v) emptyUFM
-addToUFM :: Uniquable key => UniqFM elt -> key -> elt -> UniqFM elt
+addToUFM :: Uniquable key => UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM (UFM m) k v = UFM (M.insert (getKey $ getUnique k) v m)
-addListToUFM :: Uniquable key => UniqFM elt -> [(key,elt)] -> UniqFM elt
+addListToUFM :: Uniquable key => UniqFM key elt -> [(key,elt)] -> UniqFM key elt
addListToUFM = foldl' (\m (k, v) -> addToUFM m k v)
-addListToUFM_Directly :: UniqFM elt -> [(Unique,elt)] -> UniqFM elt
+addListToUFM_Directly :: UniqFM key elt -> [(Unique,elt)] -> UniqFM key elt
addListToUFM_Directly = foldl' (\m (k, v) -> addToUFM_Directly m k v)
-addToUFM_Directly :: UniqFM elt -> Unique -> elt -> UniqFM elt
+addToUFM_Directly :: UniqFM key elt -> Unique -> elt -> UniqFM key elt
addToUFM_Directly (UFM m) u v = UFM (M.insert (getKey u) v m)
addToUFM_C
:: Uniquable key
=> (elt -> elt -> elt) -- old -> new -> result
- -> UniqFM elt -- old
+ -> UniqFM key elt -- old
-> key -> elt -- new
- -> UniqFM elt -- result
+ -> UniqFM key elt -- result
-- Arguments of combining function of M.insertWith and addToUFM_C are flipped.
addToUFM_C f (UFM m) k v =
UFM (M.insertWith (flip f) (getKey $ getUnique k) v m)
@@ -142,53 +155,55 @@ addToUFM_Acc
:: Uniquable key
=> (elt -> elts -> elts) -- Add to existing
-> (elt -> elts) -- New element
- -> UniqFM elts -- old
+ -> UniqFM key elts -- old
-> key -> elt -- new
- -> UniqFM elts -- result
+ -> UniqFM key elts -- result
addToUFM_Acc exi new (UFM m) k v =
UFM (M.insertWith (\_new old -> exi v old) (getKey $ getUnique k) (new v) m)
alterUFM
:: Uniquable key
=> (Maybe elt -> Maybe elt) -- How to adjust
- -> UniqFM elt -- old
+ -> UniqFM key elt -- old
-> key -- new
- -> UniqFM elt -- result
+ -> UniqFM key elt -- result
alterUFM f (UFM m) k = UFM (M.alter f (getKey $ getUnique k) m)
+-- | Add elements to the map, combining existing values with inserted ones using
+-- the given function.
addListToUFM_C
:: Uniquable key
=> (elt -> elt -> elt)
- -> UniqFM elt -> [(key,elt)]
- -> UniqFM elt
+ -> UniqFM key elt -> [(key,elt)]
+ -> UniqFM key elt
addListToUFM_C f = foldl' (\m (k, v) -> addToUFM_C f m k v)
-adjustUFM :: Uniquable key => (elt -> elt) -> UniqFM elt -> key -> UniqFM elt
+adjustUFM :: Uniquable key => (elt -> elt) -> UniqFM key elt -> key -> UniqFM key elt
adjustUFM f (UFM m) k = UFM (M.adjust f (getKey $ getUnique k) m)
-adjustUFM_Directly :: (elt -> elt) -> UniqFM elt -> Unique -> UniqFM elt
+adjustUFM_Directly :: (elt -> elt) -> UniqFM key elt -> Unique -> UniqFM key elt
adjustUFM_Directly f (UFM m) u = UFM (M.adjust f (getKey u) m)
-delFromUFM :: Uniquable key => UniqFM elt -> key -> UniqFM elt
+delFromUFM :: Uniquable key => UniqFM key elt -> key -> UniqFM key elt
delFromUFM (UFM m) k = UFM (M.delete (getKey $ getUnique k) m)
-delListFromUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt
+delListFromUFM :: Uniquable key => UniqFM key elt -> [key] -> UniqFM key elt
delListFromUFM = foldl' delFromUFM
-delListFromUFM_Directly :: UniqFM elt -> [Unique] -> UniqFM elt
+delListFromUFM_Directly :: UniqFM key elt -> [Unique] -> UniqFM key elt
delListFromUFM_Directly = foldl' delFromUFM_Directly
-delFromUFM_Directly :: UniqFM elt -> Unique -> UniqFM elt
+delFromUFM_Directly :: UniqFM key elt -> Unique -> UniqFM key elt
delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m)
-- Bindings in right argument shadow those in the left
-plusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
+plusUFM :: UniqFM key elt -> UniqFM key elt -> UniqFM key elt
-- M.union is left-biased, plusUFM should be right-biased.
plusUFM (UFM x) (UFM y) = UFM (M.union y x)
-- Note (M.union y x), with arguments flipped
-- M.union is left-biased, plusUFM should be right-biased.
-plusUFM_C :: (elt -> elt -> elt) -> UniqFM elt -> UniqFM elt -> UniqFM elt
+plusUFM_C :: (elt -> elt -> elt) -> UniqFM key elt -> UniqFM key elt -> UniqFM key elt
plusUFM_C f (UFM x) (UFM y) = UFM (M.unionWith f x y)
-- | `plusUFM_CD f m1 d1 m2 d2` merges the maps using `f` as the
@@ -204,11 +219,11 @@ plusUFM_C f (UFM x) (UFM y) = UFM (M.unionWith f x y)
-- @
plusUFM_CD
:: (elta -> eltb -> eltc)
- -> UniqFM elta -- map X
+ -> UniqFM key elta -- map X
-> elta -- default for X
- -> UniqFM eltb -- map Y
+ -> UniqFM key eltb -- map Y
-> eltb -- default for Y
- -> UniqFM eltc
+ -> UniqFM key eltc
plusUFM_CD f (UFM xm) dx (UFM ym) dy
= UFM $ M.mergeWithKey
(\_ x y -> Just (x `f` y))
@@ -225,9 +240,9 @@ plusUFM_CD f (UFM xm) dx (UFM ym) dy
-- (mapUFM Just m2) Nothing`.
plusUFM_CD2
:: (Maybe elta -> Maybe eltb -> eltc)
- -> UniqFM elta -- map X
- -> UniqFM eltb -- map Y
- -> UniqFM eltc
+ -> UniqFM key elta -- map X
+ -> UniqFM key eltb -- map Y
+ -> UniqFM key eltc
plusUFM_CD2 f (UFM xm) (UFM ym)
= UFM $ M.mergeWithKey
(\_ x y -> Just (Just x `f` Just y))
@@ -236,7 +251,7 @@ plusUFM_CD2 f (UFM xm) (UFM ym)
xm ym
plusMaybeUFM_C :: (elt -> elt -> Maybe elt)
- -> UniqFM elt -> UniqFM elt -> UniqFM elt
+ -> UniqFM key elt -> UniqFM key elt -> UniqFM key elt
plusMaybeUFM_C f (UFM xm) (UFM ym)
= UFM $ M.mergeWithKey
(\_ x y -> x `f` y)
@@ -244,80 +259,80 @@ plusMaybeUFM_C f (UFM xm) (UFM ym)
id
xm ym
-plusUFMList :: [UniqFM elt] -> UniqFM elt
+plusUFMList :: [UniqFM key elt] -> UniqFM key elt
plusUFMList = foldl' plusUFM emptyUFM
-minusUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1
+minusUFM :: UniqFM key elt1 -> UniqFM key elt2 -> UniqFM key elt1
minusUFM (UFM x) (UFM y) = UFM (M.difference x y)
-intersectUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1
+intersectUFM :: UniqFM key elt1 -> UniqFM key elt2 -> UniqFM key elt1
intersectUFM (UFM x) (UFM y) = UFM (M.intersection x y)
intersectUFM_C
:: (elt1 -> elt2 -> elt3)
- -> UniqFM elt1
- -> UniqFM elt2
- -> UniqFM elt3
+ -> UniqFM key elt1
+ -> UniqFM key elt2
+ -> UniqFM key elt3
intersectUFM_C f (UFM x) (UFM y) = UFM (M.intersectionWith f x y)
-disjointUFM :: UniqFM elt1 -> UniqFM elt2 -> Bool
+disjointUFM :: UniqFM key elt1 -> UniqFM key elt2 -> Bool
disjointUFM (UFM x) (UFM y) = M.disjoint x y
-foldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a
+foldUFM :: (elt -> a -> a) -> a -> UniqFM key elt -> a
foldUFM k z (UFM m) = M.foldr k z m
-mapUFM :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2
+mapUFM :: (elt1 -> elt2) -> UniqFM key elt1 -> UniqFM key elt2
mapUFM f (UFM m) = UFM (M.map f m)
-mapUFM_Directly :: (Unique -> elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2
+mapUFM_Directly :: (Unique -> elt1 -> elt2) -> UniqFM key elt1 -> UniqFM key elt2
mapUFM_Directly f (UFM m) = UFM (M.mapWithKey (f . getUnique) m)
-filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt
+filterUFM :: (elt -> Bool) -> UniqFM key elt -> UniqFM key elt
filterUFM p (UFM m) = UFM (M.filter p m)
-filterUFM_Directly :: (Unique -> elt -> Bool) -> UniqFM elt -> UniqFM elt
+filterUFM_Directly :: (Unique -> elt -> Bool) -> UniqFM key elt -> UniqFM key elt
filterUFM_Directly p (UFM m) = UFM (M.filterWithKey (p . getUnique) m)
-partitionUFM :: (elt -> Bool) -> UniqFM elt -> (UniqFM elt, UniqFM elt)
+partitionUFM :: (elt -> Bool) -> UniqFM key elt -> (UniqFM key elt, UniqFM key elt)
partitionUFM p (UFM m) =
case M.partition p m of
(left, right) -> (UFM left, UFM right)
-sizeUFM :: UniqFM elt -> Int
+sizeUFM :: UniqFM key elt -> Int
sizeUFM (UFM m) = M.size m
-elemUFM :: Uniquable key => key -> UniqFM elt -> Bool
+elemUFM :: Uniquable key => key -> UniqFM key elt -> Bool
elemUFM k (UFM m) = M.member (getKey $ getUnique k) m
-elemUFM_Directly :: Unique -> UniqFM elt -> Bool
+elemUFM_Directly :: Unique -> UniqFM key elt -> Bool
elemUFM_Directly u (UFM m) = M.member (getKey u) m
-lookupUFM :: Uniquable key => UniqFM elt -> key -> Maybe elt
+lookupUFM :: Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM (UFM m) k = M.lookup (getKey $ getUnique k) m
-- when you've got the Unique already
-lookupUFM_Directly :: UniqFM elt -> Unique -> Maybe elt
+lookupUFM_Directly :: UniqFM key elt -> Unique -> Maybe elt
lookupUFM_Directly (UFM m) u = M.lookup (getKey u) m
-lookupWithDefaultUFM :: Uniquable key => UniqFM elt -> elt -> key -> elt
+lookupWithDefaultUFM :: Uniquable key => UniqFM key elt -> elt -> key -> elt
lookupWithDefaultUFM (UFM m) v k = M.findWithDefault v (getKey $ getUnique k) m
-lookupWithDefaultUFM_Directly :: UniqFM elt -> elt -> Unique -> elt
+lookupWithDefaultUFM_Directly :: UniqFM key elt -> elt -> Unique -> elt
lookupWithDefaultUFM_Directly (UFM m) v u = M.findWithDefault v (getKey u) m
-eltsUFM :: UniqFM elt -> [elt]
+eltsUFM :: UniqFM key elt -> [elt]
eltsUFM (UFM m) = M.elems m
-ufmToSet_Directly :: UniqFM elt -> S.IntSet
+ufmToSet_Directly :: UniqFM key elt -> S.IntSet
ufmToSet_Directly (UFM m) = M.keysSet m
-anyUFM :: (elt -> Bool) -> UniqFM elt -> Bool
+anyUFM :: (elt -> Bool) -> UniqFM key elt -> Bool
anyUFM p (UFM m) = M.foldr ((||) . p) False m
-allUFM :: (elt -> Bool) -> UniqFM elt -> Bool
+allUFM :: (elt -> Bool) -> UniqFM key elt -> Bool
allUFM p (UFM m) = M.foldr ((&&) . p) True m
-seqEltsUFM :: ([elt] -> ()) -> UniqFM elt -> ()
+seqEltsUFM :: ([elt] -> ()) -> UniqFM key elt -> ()
seqEltsUFM seqList = seqList . nonDetEltsUFM
-- It's OK to use nonDetEltsUFM here because the type guarantees that
-- the only interesting thing this function can do is to force the
@@ -326,31 +341,31 @@ seqEltsUFM seqList = seqList . nonDetEltsUFM
-- See Note [Deterministic UniqFM] to learn about nondeterminism.
-- If you use this please provide a justification why it doesn't introduce
-- nondeterminism.
-nonDetEltsUFM :: UniqFM elt -> [elt]
+nonDetEltsUFM :: UniqFM key elt -> [elt]
nonDetEltsUFM (UFM m) = M.elems m
-- See Note [Deterministic UniqFM] to learn about nondeterminism.
-- If you use this please provide a justification why it doesn't introduce
-- nondeterminism.
-nonDetKeysUFM :: UniqFM elt -> [Unique]
+nonDetKeysUFM :: UniqFM key elt -> [Unique]
nonDetKeysUFM (UFM m) = map getUnique $ M.keys m
-- See Note [Deterministic UniqFM] to learn about nondeterminism.
-- If you use this please provide a justification why it doesn't introduce
-- nondeterminism.
-nonDetStrictFoldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a
+nonDetStrictFoldUFM :: (elt -> a -> a) -> a -> UniqFM key elt -> a
nonDetStrictFoldUFM k z (UFM m) = M.foldl' (flip k) z m
-- See Note [Deterministic UniqFM] to learn about nondeterminism.
-- If you use this please provide a justification why it doesn't introduce
-- nondeterminism.
-nonDetStrictFoldUFM_Directly:: (Unique -> elt -> a -> a) -> a -> UniqFM elt -> a
+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
-- See Note [Deterministic UniqFM] to learn about nondeterminism.
-- If you use this please provide a justification why it doesn't introduce
-- nondeterminism.
-nonDetUFMToList :: UniqFM elt -> [(Unique, elt)]
+nonDetUFMToList :: UniqFM key elt -> [(Unique, elt)]
nonDetUFMToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m
-- | A wrapper around 'UniqFM' with the sole purpose of informing call sites
@@ -359,48 +374,55 @@ nonDetUFMToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m
-- If you use this please provide a justification why it doesn't introduce
-- nondeterminism.
-- See Note [Deterministic UniqFM] in "GHC.Types.Unique.DFM" to learn about determinism.
-newtype NonDetUniqFM ele = NonDetUniqFM { getNonDet :: UniqFM ele }
+newtype NonDetUniqFM key ele = NonDetUniqFM { getNonDet :: UniqFM key ele }
deriving (Functor)
-- | Inherently nondeterministic.
-- If you use this please provide a justification why it doesn't introduce
-- nondeterminism.
-- See Note [Deterministic UniqFM] in "GHC.Types.Unique.DFM" to learn about determinism.
-instance Foldable NonDetUniqFM where
+instance forall key. Foldable (NonDetUniqFM key) where
foldr f z (NonDetUniqFM (UFM m)) = foldr f z m
-- | Inherently nondeterministic.
-- If you use this please provide a justification why it doesn't introduce
-- nondeterminism.
-- See Note [Deterministic UniqFM] in "GHC.Types.Unique.DFM" to learn about determinism.
-instance Traversable NonDetUniqFM where
+instance forall key. Traversable (NonDetUniqFM key) where
traverse f (NonDetUniqFM (UFM m)) = NonDetUniqFM . UFM <$> traverse f m
-ufmToIntMap :: UniqFM elt -> M.IntMap elt
+ufmToIntMap :: UniqFM key elt -> M.IntMap elt
ufmToIntMap (UFM m) = m
-unsafeIntMapToUFM :: M.IntMap elt -> UniqFM elt
+unsafeIntMapToUFM :: M.IntMap elt -> UniqFM key elt
unsafeIntMapToUFM = UFM
+-- | Cast the key domain of a UniqFM.
+--
+-- As long as the domains don't overlap in their uniques
+-- this is safe.
+unsafeCastUFMKey :: UniqFM key1 elt -> UniqFM key2 elt
+unsafeCastUFMKey (UFM m) = UFM m
+
-- Determines whether two 'UniqFM's contain the same keys.
-equalKeysUFM :: UniqFM a -> UniqFM b -> Bool
+equalKeysUFM :: UniqFM key a -> UniqFM key b -> Bool
equalKeysUFM (UFM m1) (UFM m2) = liftEq (\_ _ -> True) m1 m2
-- Instances
-instance Semi.Semigroup (UniqFM a) where
+instance Semi.Semigroup (UniqFM key a) where
(<>) = plusUFM
-instance Monoid (UniqFM a) where
+instance Monoid (UniqFM key a) where
mempty = emptyUFM
mappend = (Semi.<>)
-- Output-ery
-instance Outputable a => Outputable (UniqFM a) where
+instance Outputable a => Outputable (UniqFM key a) where
ppr ufm = pprUniqFM ppr ufm
-pprUniqFM :: (a -> SDoc) -> UniqFM a -> SDoc
+pprUniqFM :: (a -> SDoc) -> UniqFM key a -> SDoc
pprUniqFM ppr_elt ufm
= brackets $ fsep $ punctuate comma $
[ ppr uq <+> text ":->" <+> ppr_elt elt
@@ -413,7 +435,7 @@ pprUniqFM ppr_elt ufm
-- shouldn't be a problem.
-- Having this function helps contain the non-determinism created with
-- nonDetEltsUFM.
-pprUFM :: UniqFM a -- ^ The things to be pretty printed
+pprUFM :: UniqFM key a -- ^ The things to be pretty printed
-> ([a] -> SDoc) -- ^ The pretty printing function to use on the elements
-> SDoc -- ^ 'SDoc' where the things have been pretty
-- printed
@@ -425,7 +447,7 @@ pprUFM ufm pp = pp (nonDetEltsUFM ufm)
-- Having this function helps contain the non-determinism created with
-- nonDetUFMToList.
pprUFMWithKeys
- :: UniqFM a -- ^ The things to be pretty printed
+ :: UniqFM key a -- ^ The things to be pretty printed
-> ([(Unique, a)] -> SDoc) -- ^ The pretty printing function to use on the elements
-> SDoc -- ^ 'SDoc' where the things have been pretty
-- printed
@@ -433,7 +455,7 @@ pprUFMWithKeys ufm pp = pp (nonDetUFMToList ufm)
-- | Determines the pluralisation suffix appropriate for the length of a set
-- in the same way that plural from Outputable does for lists.
-pluralUFM :: UniqFM a -> SDoc
+pluralUFM :: UniqFM key a -> SDoc
pluralUFM ufm
| sizeUFM ufm == 1 = empty
| otherwise = char 's'
diff --git a/compiler/GHC/Types/Unique/Set.hs b/compiler/GHC/Types/Unique/Set.hs
index aaf9531d8f..88e56f9e44 100644
--- a/compiler/GHC/Types/Unique/Set.hs
+++ b/compiler/GHC/Types/Unique/Set.hs
@@ -63,7 +63,7 @@ import qualified Data.Semigroup as Semi
-- It means that to implement mapUniqSet you have to update
-- both the keys and the values.
-newtype UniqSet a = UniqSet {getUniqSet' :: UniqFM a}
+newtype UniqSet a = UniqSet {getUniqSet' :: UniqFM a a}
deriving (Data, Semi.Semigroup, Monoid)
emptyUniqSet :: UniqSet a
@@ -109,13 +109,13 @@ intersectUniqSets (UniqSet s) (UniqSet t) = UniqSet (intersectUFM s t)
disjointUniqSets :: UniqSet a -> UniqSet a -> Bool
disjointUniqSets (UniqSet s) (UniqSet t) = disjointUFM s t
-restrictUniqSetToUFM :: UniqSet a -> UniqFM b -> UniqSet a
+restrictUniqSetToUFM :: UniqSet key -> UniqFM key b -> UniqSet key
restrictUniqSetToUFM (UniqSet s) m = UniqSet (intersectUFM s m)
-uniqSetMinusUFM :: UniqSet a -> UniqFM b -> UniqSet a
+uniqSetMinusUFM :: UniqSet key -> UniqFM key b -> UniqSet key
uniqSetMinusUFM (UniqSet s) t = UniqSet (minusUFM s t)
-uniqSetMinusUDFM :: UniqSet a -> UniqDFM b -> UniqSet a
+uniqSetMinusUDFM :: UniqSet key -> UniqDFM key b -> UniqSet key
uniqSetMinusUDFM (UniqSet s) t = UniqSet (ufmMinusUDFM s t)
elementOfUniqSet :: Uniquable a => a -> UniqSet a -> Bool
@@ -145,7 +145,9 @@ sizeUniqSet (UniqSet s) = sizeUFM s
isEmptyUniqSet :: UniqSet a -> Bool
isEmptyUniqSet (UniqSet s) = isNullUFM s
-lookupUniqSet :: Uniquable a => UniqSet b -> a -> Maybe b
+-- | What's the point you might ask? We might have changed an object
+-- without it's key changing. In which case this lookup makes sense.
+lookupUniqSet :: Uniquable key => UniqSet key -> key -> Maybe key
lookupUniqSet (UniqSet s) k = lookupUFM s k
lookupUniqSet_Directly :: UniqSet a -> Unique -> Maybe a
@@ -178,13 +180,13 @@ mapUniqSet f = mkUniqSet . map f . nonDetEltsUniqSet
instance Eq (UniqSet a) where
UniqSet a == UniqSet b = equalKeysUFM a b
-getUniqSet :: UniqSet a -> UniqFM a
+getUniqSet :: UniqSet a -> UniqFM a a
getUniqSet = getUniqSet'
-- | 'unsafeUFMToUniqSet' converts a @'UniqFM' a@ into a @'UniqSet' a@
-- assuming, without checking, that it maps each 'Unique' to a value
-- that has that 'Unique'. See Note [UniqSet invariant].
-unsafeUFMToUniqSet :: UniqFM a -> UniqSet a
+unsafeUFMToUniqSet :: UniqFM a a -> UniqSet a
unsafeUFMToUniqSet = UniqSet
instance Outputable a => Outputable (UniqSet a) where
diff --git a/compiler/GHC/Types/Var/Env.hs b/compiler/GHC/Types/Var/Env.hs
index a39770cfe3..47cdc8734b 100644
--- a/compiler/GHC/Types/Var/Env.hs
+++ b/compiler/GHC/Types/Var/Env.hs
@@ -439,20 +439,24 @@ delTidyEnvList (occ_env, var_env) vs = (occ_env', var_env')
************************************************************************
-}
+-- We would like this to be `UniqFM Var elt`
+-- but the code uses various key types.
+-- So for now make it explicitly untyped
+
-- | Variable Environment
-type VarEnv elt = UniqFM elt
+type VarEnv elt = UniqFM Var elt
-- | Identifier Environment
-type IdEnv elt = VarEnv elt
+type IdEnv elt = UniqFM Id elt
-- | Type Variable Environment
-type TyVarEnv elt = VarEnv elt
+type TyVarEnv elt = UniqFM Var elt
-- | Type or Coercion Variable Environment
-type TyCoVarEnv elt = VarEnv elt
+type TyCoVarEnv elt = UniqFM TyCoVar elt
-- | Coercion Variable Environment
-type CoVarEnv elt = VarEnv elt
+type CoVarEnv elt = UniqFM CoVar elt
emptyVarEnv :: VarEnv a
mkVarEnv :: [(Var, a)] -> VarEnv a
@@ -533,7 +537,7 @@ modifyVarEnv mangle_fn env key
Nothing -> env
Just xx -> extendVarEnv env key (mangle_fn xx)
-modifyVarEnv_Directly :: (a -> a) -> UniqFM a -> Unique -> UniqFM a
+modifyVarEnv_Directly :: (a -> a) -> UniqFM key a -> Unique -> UniqFM key a
modifyVarEnv_Directly mangle_fn env key
= case (lookupUFM_Directly env key) of
Nothing -> env
@@ -544,13 +548,14 @@ modifyVarEnv_Directly mangle_fn env key
-- DVarEnv.
-- | Deterministic Variable Environment
-type DVarEnv elt = UniqDFM elt
+type DVarEnv elt = UniqDFM Var elt
-- | Deterministic Identifier Environment
-type DIdEnv elt = DVarEnv elt
+-- Sadly not always indexed by Id, but it is in the common case.
+type DIdEnv elt = UniqDFM Var elt
-- | Deterministic Type Variable Environment
-type DTyVarEnv elt = DVarEnv elt
+type DTyVarEnv elt = UniqDFM TyVar elt
emptyDVarEnv :: DVarEnv a
emptyDVarEnv = emptyUDFM
diff --git a/compiler/GHC/Types/Var/Set.hs b/compiler/GHC/Types/Var/Set.hs
index c935a336a9..b6f4663974 100644
--- a/compiler/GHC/Types/Var/Set.hs
+++ b/compiler/GHC/Types/Var/Set.hs
@@ -131,7 +131,7 @@ isEmptyVarSet = isEmptyUniqSet
mkVarSet = mkUniqSet
lookupVarSet_Directly = lookupUniqSet_Directly
lookupVarSet = lookupUniqSet
-lookupVarSetByName = lookupUniqSet
+lookupVarSetByName set name = lookupUniqSet_Directly set (getUnique name)
sizeVarSet = sizeUniqSet
filterVarSet = filterUniqSet
delVarSetByKey = delOneFromUniqSet_Directly
diff --git a/compiler/GHC/Unit/Module/Env.hs b/compiler/GHC/Unit/Module/Env.hs
index 3d01b21c08..cf056e2bdf 100644
--- a/compiler/GHC/Unit/Module/Env.hs
+++ b/compiler/GHC/Unit/Module/Env.hs
@@ -32,6 +32,7 @@ where
import GHC.Prelude
+import GHC.Unit.Module.Name (ModuleName)
import GHC.Types.Unique
import GHC.Types.Unique.FM
import GHC.Types.Unique.DFM
@@ -191,12 +192,12 @@ UniqFM.
-}
-- | A map keyed off of 'ModuleName's (actually, their 'Unique's)
-type ModuleNameEnv elt = UniqFM elt
+type ModuleNameEnv elt = UniqFM ModuleName elt
-- | A map keyed off of 'ModuleName's (actually, their 'Unique's)
-- Has deterministic folds and can be deterministically converted to a list
-type DModuleNameEnv elt = UniqDFM elt
+type DModuleNameEnv elt = UniqDFM ModuleName elt
--------------------------------------------------------------------
diff --git a/compiler/GHC/Unit/State.hs b/compiler/GHC/Unit/State.hs
index 6bc073fc27..2efd9626e6 100644
--- a/compiler/GHC/Unit/State.hs
+++ b/compiler/GHC/Unit/State.hs
@@ -1730,7 +1730,7 @@ mkModuleNameProvidersMap ctx cfg pkg_map closure vis_map =
in (pk', m', fromReexportedModules e pkg')
return (m, mkModMap pk' m' origin')
- esmap :: UniqFM (Map Module ModuleOrigin)
+ esmap :: UniqFM ModuleName (Map Module ModuleOrigin)
esmap = listToUFM (es False) -- parameter here doesn't matter, orig will
-- be overwritten
diff --git a/compiler/GHC/Utils/Binary.hs b/compiler/GHC/Utils/Binary.hs
index d95041665a..5bcc98cff4 100644
--- a/compiler/GHC/Utils/Binary.hs
+++ b/compiler/GHC/Utils/Binary.hs
@@ -1148,7 +1148,7 @@ undef s = panic ("Binary.UserData: no " ++ s)
type Dictionary = Array Int FastString -- The dictionary
-- Should be 0-indexed
-putDictionary :: BinHandle -> Int -> UniqFM (Int,FastString) -> IO ()
+putDictionary :: BinHandle -> Int -> UniqFM FastString (Int,FastString) -> IO ()
putDictionary bh sz dict = do
put_ bh sz
mapM_ (putFS bh) (elems (array (0,sz-1) (nonDetEltsUFM dict)))
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 494725a0b6..ce887f6a85 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -626,6 +626,7 @@ Library
GHC.CmmToAsm.Reg.Linear.X86_64
GHC.CmmToAsm.Reg.Linear.PPC
GHC.CmmToAsm.Reg.Linear.SPARC
+ GHC.CmmToAsm.Reg.Utils
GHC.CmmToAsm.Dwarf
GHC.CmmToAsm.Dwarf.Types
GHC.CmmToAsm.Dwarf.Constants