diff options
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 |