diff options
| author | Andreas Klebinger <klebinger.andreas@gmx.at> | 2020-06-23 15:01:25 +0200 |
|---|---|---|
| committer | Andreas Klebinger <klebinger.andreas@gmx.at> | 2020-07-06 02:26:01 +0200 |
| commit | 04c082b0763ba66dd862f9b04833e1d4e4561f25 (patch) | |
| tree | 66200aace00aee9aecc89066b47f7fc9941b419c | |
| parent | 7aa6ef110d8cc6626b1cf18d85a37cbac53e2795 (diff) | |
| download | haskell-wip/andreask/typedUniqFM.tar.gz | |
Give Uniq[D]FM a phantom type for its key.wip/andreask/typedUniqFM
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.
62 files changed, 555 insertions, 352 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 diff --git a/testsuite/tests/plugins/annotation-plugin/SayAnnNames.hs b/testsuite/tests/plugins/annotation-plugin/SayAnnNames.hs index 1db2693c6b..b33039ca7b 100644 --- a/testsuite/tests/plugins/annotation-plugin/SayAnnNames.hs +++ b/testsuite/tests/plugins/annotation-plugin/SayAnnNames.hs @@ -30,4 +30,4 @@ pass g = do annotationsOn :: Data a => ModGuts -> CoreBndr -> CoreM [a] annotationsOn guts bndr = do (_, anns) <- getAnnotations deserializeWithData guts - return $ lookupWithDefaultUFM anns [] (varUnique bndr) + return $ lookupWithDefaultUFM_Directly anns [] (varUnique bndr) diff --git a/testsuite/tests/plugins/simple-plugin/Simple/Plugin.hs b/testsuite/tests/plugins/simple-plugin/Simple/Plugin.hs index 45a0205eb0..49a3a6cffa 100644 --- a/testsuite/tests/plugins/simple-plugin/Simple/Plugin.hs +++ b/testsuite/tests/plugins/simple-plugin/Simple/Plugin.hs @@ -46,14 +46,16 @@ findNameBndr target b mainPass :: ModGuts -> CoreM ModGuts mainPass guts = do putMsgS "Simple Plugin Pass Run" - (_, anns) <- getAnnotations deserializeWithData guts - bindsOnlyPass (mapM (changeBind anns Nothing)) guts + (_, anns) <- getAnnotations deserializeWithData guts :: CoreM (ModuleEnv [ReplaceWith], NameEnv [ReplaceWith]) + -- Var's have the same uniques as their names. Making a cast from NameEnv to VarEnv safe. + let anns' = unsafeCastUFMKey anns :: VarEnv [ReplaceWith] + bindsOnlyPass (mapM (changeBind anns' Nothing)) guts -changeBind :: UniqFM [ReplaceWith] -> Maybe String -> CoreBind -> CoreM CoreBind +changeBind :: VarEnv [ReplaceWith] -> Maybe String -> CoreBind -> CoreM CoreBind changeBind anns mb_replacement (NonRec b e) = changeBindPr anns mb_replacement b e >>= (return . uncurry NonRec) changeBind anns mb_replacement (Rec bes) = liftM Rec $ mapM (uncurry (changeBindPr anns mb_replacement)) bes -changeBindPr :: UniqFM [ReplaceWith] -> Maybe String -> CoreBndr -> CoreExpr -> CoreM (CoreBndr, CoreExpr) +changeBindPr :: VarEnv [ReplaceWith] -> Maybe String -> CoreBndr -> CoreExpr -> CoreM (CoreBndr, CoreExpr) changeBindPr anns mb_replacement b e = do case lookupWithDefaultUFM anns [] b of [] -> do @@ -65,7 +67,7 @@ changeBindPr anns mb_replacement b e = do _ -> do dflags <- getDynFlags error ("Too many change_anns on one binder:" ++ showPpr dflags b) -changeExpr :: UniqFM [ReplaceWith] -> Maybe String -> CoreExpr -> CoreM CoreExpr +changeExpr :: VarEnv [ReplaceWith] -> Maybe String -> CoreExpr -> CoreM CoreExpr changeExpr anns mb_replacement e = let go = changeExpr anns mb_replacement in case e of Lit (LitString _) -> case mb_replacement of Nothing -> return e @@ -80,5 +82,5 @@ changeExpr anns mb_replacement e = let go = changeExpr anns mb_replacement in ca Tick t e -> liftM (Tick t) (go e) _ -> return e -changeAlt :: UniqFM [ReplaceWith] -> Maybe String -> CoreAlt -> CoreM CoreAlt +changeAlt :: VarEnv [ReplaceWith] -> Maybe String -> CoreAlt -> CoreM CoreAlt changeAlt anns mb_replacement (con, bs, e) = liftM (\e' -> (con, bs, e')) (changeExpr anns mb_replacement e) diff --git a/utils/haddock b/utils/haddock -Subproject 9bd65ee47a43529af2ad8e350fdd0c372bc5964 +Subproject 075067254fc30ef56bad67ac65dd3c5f4101f8f |