Commit c4de6a7a authored by Andreas Klebinger's avatar Andreas Klebinger Committed by Marge Bot
Browse files

Give Uniq[D]FM a phantom type for its key.

This fixes #17667 and should help to avoid such issues going forward.

The changes are mostly mechanical in nature. With two notable
exceptions.

* The register allocator.

  The register allocator references registers by distinct uniques.
  However they come from the types of VirtualReg, Reg or Unique in
  various places. As a result we sometimes cast the key type of the
  map and use functions which operate on the now typed map but take
  a raw Unique as actual key. The logic itself has not changed it
  just becomes obvious where we do so now.

* <Type>Env Modules.

As an example a ClassEnv is currently queried using the types `Class`,
`Name`, and `TyCon`. This is safe since for a distinct class value all
these expressions give the same unique.

    getUnique cls
    getUnique (classTyCon cls)
    getUnique (className cls)
    getUnique (tcName $ classTyCon cls)

This is for the most part contained within the modules defining the
interface. However it requires us to play dirty when we are given a
`Name` to lookup in a `UniqFM Class a` map. But again the logic did
not change and it's for the most part hidden behind the Env Module.

Some of these cases could be avoided by refactoring but this is left
for future work.

We also bump the haddock submodule as it uses UniqFM.
parent de139cc4
Pipeline #22162 failed with stages
in 792 minutes and 28 seconds
...@@ -198,15 +198,20 @@ knownKeyNamesOkay all_names ...@@ -198,15 +198,20 @@ knownKeyNamesOkay all_names
-- known-key thing. -- known-key thing.
lookupKnownKeyName :: Unique -> Maybe Name lookupKnownKeyName :: Unique -> Maybe Name
lookupKnownKeyName u = lookupKnownKeyName u =
knownUniqueName u <|> lookupUFM knownKeysMap u knownUniqueName u <|> lookupUFM_Directly knownKeysMap u
-- | Is a 'Name' known-key? -- | Is a 'Name' known-key?
isKnownKeyName :: Name -> Bool isKnownKeyName :: Name -> Bool
isKnownKeyName n = isKnownKeyName n =
isJust (knownUniqueName $ nameUnique n) || elemUFM n knownKeysMap isJust (knownUniqueName $ nameUnique n) || elemUFM n knownKeysMap
knownKeysMap :: UniqFM Name -- | Maps 'Unique's to known-key names.
knownKeysMap = listToUFM [ (nameUnique n, n) | n <- knownKeyNames ] --
-- 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 -- | Given a 'Unique' lookup any associated arbitrary SDoc's to be displayed by
-- GHCi's ':info' command. -- GHCi's ':info' command.
......
...@@ -224,7 +224,7 @@ data StackMap = StackMap ...@@ -224,7 +224,7 @@ data StackMap = StackMap
, sm_ret_off :: ByteOff , sm_ret_off :: ByteOff
-- ^ Number of words of stack that we do not describe with an info -- ^ Number of words of stack that we do not describe with an info
-- table, because it contains an update frame. -- table, because it contains an update frame.
, sm_regs :: UniqFM (LocalReg,StackLoc) , sm_regs :: UniqFM LocalReg (LocalReg,StackLoc)
-- ^ regs on the stack -- ^ regs on the stack
} }
......
...@@ -907,7 +907,7 @@ exprOp name args_code = do ...@@ -907,7 +907,7 @@ exprOp name args_code = do
mo <- nameToMachOp name mo <- nameToMachOp name
return $ mkMachOp mo args_code return $ mkMachOp mo args_code
exprMacros :: DynFlags -> UniqFM ([CmmExpr] -> CmmExpr) exprMacros :: DynFlags -> UniqFM FastString ([CmmExpr] -> CmmExpr)
exprMacros dflags = listToUFM [ exprMacros dflags = listToUFM [
( fsLit "ENTRY_CODE", \ [x] -> entryCode platform x ), ( fsLit "ENTRY_CODE", \ [x] -> entryCode platform x ),
( fsLit "INFO_PTR", \ [x] -> closureInfoPtr dflags x ), ( fsLit "INFO_PTR", \ [x] -> closureInfoPtr dflags x ),
...@@ -990,7 +990,7 @@ machOps = listToUFM $ ...@@ -990,7 +990,7 @@ machOps = listToUFM $
( "i2f64", flip MO_SF_Conv W64 ) ( "i2f64", flip MO_SF_Conv W64 )
] ]
callishMachOps :: UniqFM ([CmmExpr] -> (CallishMachOp, [CmmExpr])) callishMachOps :: UniqFM FastString ([CmmExpr] -> (CallishMachOp, [CmmExpr]))
callishMachOps = listToUFM $ callishMachOps = listToUFM $
map (\(x, y) -> (mkFastString x, y)) [ map (\(x, y) -> (mkFastString x, y)) [
( "read_barrier", (MO_ReadBarrier,)), ( "read_barrier", (MO_ReadBarrier,)),
...@@ -1090,7 +1090,7 @@ stmtMacro fun args_code = do ...@@ -1090,7 +1090,7 @@ stmtMacro fun args_code = do
args <- sequence args_code args <- sequence args_code
code (fcode args) code (fcode args)
stmtMacros :: UniqFM ([CmmExpr] -> FCode ()) stmtMacros :: UniqFM FastString ([CmmExpr] -> FCode ())
stmtMacros = listToUFM [ stmtMacros = listToUFM [
( fsLit "CCS_ALLOC", \[words,ccs] -> profAlloc words ccs ), ( fsLit "CCS_ALLOC", \[words,ccs] -> profAlloc words ccs ),
( fsLit "ENTER_CCS_THUNK", \[e] -> enterCostCentreThunk e ), ( fsLit "ENTER_CCS_THUNK", \[e] -> enterCostCentreThunk e ),
......
...@@ -420,7 +420,7 @@ tryToInline ...@@ -420,7 +420,7 @@ tryToInline
tryToInline dflags live node assigs = go usages node emptyLRegSet assigs tryToInline dflags live node assigs = go usages node emptyLRegSet assigs
where 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 usages = foldLocalRegsUsed dflags addUsage emptyUFM node
go _usages node _skipped [] = (node, []) go _usages node _skipped [] = (node, [])
...@@ -553,7 +553,7 @@ improveConditional other = other ...@@ -553,7 +553,7 @@ improveConditional other = other
-- inline y, and we have a dead assignment to x. If we don't notice -- 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. -- 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 addUsage m r = addToUFM_C (+) m r 1
regsUsedIn :: LRegSet -> CmmExpr -> Bool regsUsedIn :: LRegSet -> CmmExpr -> Bool
......
...@@ -66,6 +66,7 @@ import GHC.Settings.Config ...@@ -66,6 +66,7 @@ import GHC.Settings.Config
import GHC.CmmToAsm.Instr import GHC.CmmToAsm.Instr
import GHC.CmmToAsm.PIC import GHC.CmmToAsm.PIC
import GHC.Platform.Reg import GHC.Platform.Reg
import GHC.Platform.Reg.Class (RegClass)
import GHC.CmmToAsm.Monad import GHC.CmmToAsm.Monad
import GHC.CmmToAsm.CFG import GHC.CmmToAsm.CFG
import GHC.CmmToAsm.Dwarf import GHC.CmmToAsm.Dwarf
...@@ -607,7 +608,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count ...@@ -607,7 +608,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
|| gopt Opt_RegsIterative dflags ) || gopt Opt_RegsIterative dflags )
then do then do
-- the regs usable for allocation -- the regs usable for allocation
let (alloc_regs :: UniqFM (UniqSet RealReg)) let (alloc_regs :: UniqFM RegClass (UniqSet RealReg))
= foldr (\r -> plusUFM_C unionUniqSets = foldr (\r -> plusUFM_C unionUniqSets
$ unitUFM (targetClassOfRealReg platform r) (unitUniqSet r)) $ unitUFM (targetClassOfRealReg platform r) (unitUniqSet r))
emptyUFM emptyUFM
......
...@@ -29,7 +29,6 @@ import GHC.Platform ...@@ -29,7 +29,6 @@ import GHC.Platform
import GHC.Driver.Session (gopt, GeneralFlag(..), DynFlags, targetPlatform) import GHC.Driver.Session (gopt, GeneralFlag(..), DynFlags, targetPlatform)
import GHC.Types.Unique.FM import GHC.Types.Unique.FM
import GHC.Utils.Misc import GHC.Utils.Misc
import GHC.Types.Unique
import GHC.Data.Graph.Directed import GHC.Data.Graph.Directed
import GHC.Utils.Outputable import GHC.Utils.Outputable
...@@ -926,8 +925,8 @@ seqBlocks infos blocks = placeNext pullable0 todo0 ...@@ -926,8 +925,8 @@ seqBlocks infos blocks = placeNext pullable0 todo0
= pprPanic "seqBlocks" (ppr tooManyNextNodes) = pprPanic "seqBlocks" (ppr tooManyNextNodes)
lookupDeleteUFM :: Uniquable key => UniqFM elt -> key lookupDeleteUFM :: UniqFM BlockId elt -> BlockId
-> Maybe (elt, UniqFM elt) -> Maybe (elt, UniqFM BlockId elt)
lookupDeleteUFM m k = do -- Maybe monad lookupDeleteUFM m k = do -- Maybe monad
v <- lookupUFM m k v <- lookupUFM m k
return (v, delFromUFM m k) return (v, delFromUFM m k)
......
...@@ -119,7 +119,7 @@ data NatM_State ...@@ -119,7 +119,7 @@ data NatM_State
-- generated instructions. So instead we update the CFG as we go. -- 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)) newtype NatM result = NatM (NatM_State -> (result, NatM_State))
deriving (Functor) deriving (Functor)
......
...@@ -46,7 +46,7 @@ maxSpinCount = 10 ...@@ -46,7 +46,7 @@ maxSpinCount = 10
regAlloc regAlloc
:: (Outputable statics, Outputable instr, Instruction instr) :: (Outputable statics, Outputable instr, Instruction instr)
=> NCGConfig => 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. -> UniqSet Int -- ^ set of available spill slots.
-> Int -- ^ current number of spill slots -> Int -- ^ current number of spill slots
-> [LiveCmmDecl statics instr] -- ^ code annotated with liveness information. -> [LiveCmmDecl statics instr] -- ^ code annotated with liveness information.
...@@ -96,7 +96,7 @@ regAlloc_spin ...@@ -96,7 +96,7 @@ regAlloc_spin
-> Color.Triv VirtualReg RegClass RealReg -> Color.Triv VirtualReg RegClass RealReg
-- ^ Function for calculating whether a register is trivially -- ^ Function for calculating whether a register is trivially
-- colourable. -- 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. -> UniqSet Int -- ^ Free stack slots that we can use.
-> Int -- ^ Number of spill slots in use -> Int -- ^ Number of spill slots in use
-> [RegAllocStats statics instr] -- ^ Current regalloc stats to add to. -> [RegAllocStats statics instr] -- ^ Current regalloc stats to add to.
......
...@@ -44,7 +44,7 @@ regCoalesce code ...@@ -44,7 +44,7 @@ regCoalesce code
-- | Add a v1 = v2 register renaming to the map. -- | Add a v1 = v2 register renaming to the map.
-- The register with the lowest lexical name is set as the -- The register with the lowest lexical name is set as the
-- canonical version. -- canonical version.
buildAlloc :: UniqFM Reg -> (Reg, Reg) -> UniqFM Reg buildAlloc :: UniqFM Reg Reg -> (Reg, Reg) -> UniqFM Reg Reg
buildAlloc fm (r1, r2) buildAlloc fm (r1, r2)
= let rmin = min r1 r2 = let rmin = min r1 r2
rmax = max r1 r2 rmax = max r1 r2
...@@ -53,7 +53,7 @@ buildAlloc fm (r1, r2) ...@@ -53,7 +53,7 @@ buildAlloc fm (r1, r2)
-- | Determine the canonical name for a register by following -- | Determine the canonical name for a register by following
-- v1 = v2 renamings in this map. -- v1 = v2 renamings in this map.
sinkReg :: UniqFM Reg -> Reg -> Reg sinkReg :: UniqFM Reg Reg -> Reg -> Reg
sinkReg fm r sinkReg fm r
= case lookupUFM fm r of = case lookupUFM fm r of
Nothing -> r Nothing -> r
......
...@@ -10,6 +10,7 @@ module GHC.CmmToAsm.Reg.Graph.Spill ( ...@@ -10,6 +10,7 @@ module GHC.CmmToAsm.Reg.Graph.Spill (
import GHC.Prelude import GHC.Prelude
import GHC.CmmToAsm.Reg.Liveness import GHC.CmmToAsm.Reg.Liveness
import GHC.CmmToAsm.Reg.Utils
import GHC.CmmToAsm.Instr import GHC.CmmToAsm.Instr
import GHC.Platform.Reg import GHC.Platform.Reg
import GHC.Cmm hiding (RegSet) import GHC.Cmm hiding (RegSet)
...@@ -69,8 +70,11 @@ regSpill platform code slotsFree slotCount regs ...@@ -69,8 +70,11 @@ regSpill platform code slotsFree slotCount regs
= do = do
-- Allocate a slot for each of the spilled regs. -- Allocate a slot for each of the spilled regs.
let slots = take (sizeUniqSet regs) $ nonDetEltsUniqSet slotsFree let slots = take (sizeUniqSet regs) $ nonDetEltsUniqSet slotsFree
let regSlotMap = listToUFM let
$ zip (nonDetEltsUniqSet regs) slots 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 -- This is non-deterministic but we do not
-- currently support deterministic code-generation. -- currently support deterministic code-generation.
-- See Note [Unique Determinism and code generation] -- See Note [Unique Determinism and code generation]
...@@ -158,7 +162,7 @@ regSpill_top platform regSlotMap cmm ...@@ -158,7 +162,7 @@ regSpill_top platform regSlotMap cmm
regSpill_block regSpill_block
:: Instruction instr :: Instruction instr
=> Platform => 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 -> LiveBasicBlock instr
-> SpillM (LiveBasicBlock instr) -> SpillM (LiveBasicBlock instr)
...@@ -174,7 +178,7 @@ regSpill_block platform regSlotMap (BasicBlock i instrs) ...@@ -174,7 +178,7 @@ regSpill_block platform regSlotMap (BasicBlock i instrs)
regSpill_instr regSpill_instr
:: Instruction instr :: Instruction instr
=> Platform => 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 -> LiveInstr instr
-> SpillM [LiveInstr instr] -> SpillM [LiveInstr instr]
...@@ -223,7 +227,7 @@ regSpill_instr platform regSlotMap ...@@ -223,7 +227,7 @@ regSpill_instr platform regSlotMap
-- writes to a vreg that is being spilled. -- writes to a vreg that is being spilled.
spillRead spillRead
:: Instruction instr :: Instruction instr
=> UniqFM Int => UniqFM Reg Int
-> instr -> instr
-> Reg -> Reg
-> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr'])) -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
...@@ -246,7 +250,7 @@ spillRead regSlotMap instr reg ...@@ -246,7 +250,7 @@ spillRead regSlotMap instr reg
-- writes to a vreg that is being spilled. -- writes to a vreg that is being spilled.
spillWrite spillWrite
:: Instruction instr :: Instruction instr
=> UniqFM Int => UniqFM Reg Int
-> instr -> instr
-> Reg -> Reg
-> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr'])) -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
...@@ -269,7 +273,7 @@ spillWrite regSlotMap instr reg ...@@ -269,7 +273,7 @@ spillWrite regSlotMap instr reg
-- both reads and writes to a vreg that is being spilled. -- both reads and writes to a vreg that is being spilled.
spillModify spillModify
:: Instruction instr :: Instruction instr
=> UniqFM Int => UniqFM Reg Int
-> instr -> instr
-> Reg -> Reg
-> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr'])) -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
...@@ -334,7 +338,7 @@ data SpillS ...@@ -334,7 +338,7 @@ data SpillS
stateUS :: UniqSupply stateUS :: UniqSupply
-- | Spilled vreg vs the number of times it was loaded, stored. -- | 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. -- | Create a new spiller state.
...@@ -366,7 +370,7 @@ accSpillSL (r1, s1, l1) (_, s2, l2) ...@@ -366,7 +370,7 @@ accSpillSL (r1, s1, l1) (_, s2, l2)
-- Tells us what registers were spilled. -- Tells us what registers were spilled.
data SpillStats data SpillStats
= SpillStats = SpillStats
{ spillStoreLoad :: UniqFM (Reg, Int, Int) } { spillStoreLoad :: UniqFM Reg (Reg, Int, Int) }
-- | Extract spiller statistics from the spiller state. -- | Extract spiller statistics from the spiller state.
......
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | Clean out unneeded spill\/reload instructions. -- | Clean out unneeded spill\/reload instructions.
-- --
...@@ -340,7 +341,7 @@ cleanBackward liveSlotsOnEntry noReloads acc lis ...@@ -340,7 +341,7 @@ cleanBackward liveSlotsOnEntry noReloads acc lis
cleanBackward' cleanBackward'
:: Instruction instr :: Instruction instr
=> BlockMap IntSet => BlockMap IntSet
-> UniqFM [BlockId] -> UniqFM Store [BlockId]
-> UniqSet Int -> UniqSet Int
-> [LiveInstr instr] -> [LiveInstr instr]
-> [LiveInstr instr] -> [LiveInstr instr]
...@@ -438,17 +439,17 @@ type CleanM ...@@ -438,17 +439,17 @@ type CleanM
data CleanS data CleanS
= CleanS = CleanS
{ -- | Regs which are valid at the start of each block. { -- | 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. -- | Collecting up what regs were valid across each jump.
-- in the next pass we can collate these and write the results -- in the next pass we can collate these and write the results
-- to sJumpValid. -- to sJumpValid.
, sJumpValidAcc :: UniqFM [Assoc Store] , sJumpValidAcc :: UniqFM BlockId [Assoc Store]
-- | Map of (slot -> blocks which reload from this slot) -- | Map of (slot -> blocks which reload from this slot)
-- used to decide if whether slot spilled to will ever be -- used to decide if whether slot spilled to will ever be
-- reloaded from on this path. -- reloaded from on this path.
, sReloadedBy :: UniqFM [BlockId] , sReloadedBy :: UniqFM Store [BlockId]
-- | Spills and reloads cleaned each pass (latest at front) -- | Spills and reloads cleaned each pass (latest at front)
, sCleanedCount :: [(Int, Int)] , sCleanedCount :: [(Int, Int)]
...@@ -533,7 +534,8 @@ instance Outputable Store where ...@@ -533,7 +534,8 @@ instance Outputable Store where
-- In the spill cleaner, two store locations are associated if they are known -- In the spill cleaner, two store locations are associated if they are known
-- to hold the same value. -- 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 -- | An empty association
emptyAssoc :: Assoc a emptyAssoc :: Assoc a
...@@ -541,8 +543,9 @@ emptyAssoc = emptyUFM ...@@ -541,8 +543,9 @@ emptyAssoc = emptyUFM
-- | Add an association between these two things. -- | Add an association between these two things.
addAssoc :: Uniquable a -- addAssoc :: Uniquable a
=> a -> a -> Assoc a -> Assoc a -- => a -> a -> Assoc a -> Assoc a
addAssoc :: Store -> Store -> Assoc Store -> Assoc Store
addAssoc a b m addAssoc a b m
= let m1 = addToUFM_C unionUniqSets m a (unitUniqSet b) = let m1 = addToUFM_C unionUniqSets m a (unitUniqSet b)
...@@ -551,9 +554,7 @@ addAssoc a b m ...@@ -551,9 +554,7 @@ addAssoc a b m
-- | Delete all associations to a node. -- | Delete all associations to a node.
delAssoc :: (Uniquable a) delAssoc :: Store -> Assoc Store -> Assoc Store
=> a -> Assoc a -> Assoc a
delAssoc a m delAssoc a m
| Just aSet <- lookupUFM m a | Just aSet <- lookupUFM m a
, m1 <- delFromUFM m a , m1 <- delFromUFM m a
...@@ -565,9 +566,7 @@ delAssoc a m ...@@ -565,9 +566,7 @@ delAssoc a m
-- | Delete a single association edge (a -> b). -- | Delete a single association edge (a -> b).
delAssoc1 :: Uniquable a delAssoc1 :: Store -> Store -> Assoc Store -> Assoc Store
=> a -> a -> Assoc a -> Assoc a
delAssoc1 a b m delAssoc1 a b m
| Just aSet <- lookupUFM m a | Just aSet <- lookupUFM m a
= addToUFM m a (delOneFromUniqSet aSet b) = addToUFM m a (delOneFromUniqSet aSet b)
...@@ -576,17 +575,14 @@ delAssoc1 a b m ...@@ -576,17 +575,14 @@ delAssoc1 a b m
-- | Check if these two things are associated. -- | Check if these two things are associated.
elemAssoc :: (Uniquable a) elemAssoc :: Store -> Store -> Assoc Store -> Bool
=> a -> a -> Assoc a -> Bool
elemAssoc a b m elemAssoc a b m
= elementOfUniqSet b (closeAssoc a m) = elementOfUniqSet b (closeAssoc a m)
-- | Find the refl. trans. closure of the association from this point. -- | Find the refl. trans. closure of the association from this point.
closeAssoc :: (Uniquable a) closeAssoc :: Store -> Assoc Store -> UniqSet Store
=> a -> Assoc a -> UniqSet a
closeAssoc a assoc closeAssoc a assoc
= closeAssoc' assoc emptyUniqSet (unitUniqSet a) = closeAssoc' assoc emptyUniqSet (unitUniqSet a)
where where
...@@ -615,6 +611,6 @@ closeAssoc a assoc ...@@ -615,6 +611,6 @@ closeAssoc a assoc
(unionUniqSets toVisit neighbors) (unionUniqSets toVisit neighbors)
-- | Intersect two associations. -- | Intersect two associations.
intersectAssoc :: Assoc a -> Assoc a -> Assoc a intersectAssoc :: Assoc Store -> Assoc Store -> Assoc Store
intersectAssoc a b intersectAssoc a b
= intersectUFM_C (intersectUniqSets) a b = intersectUFM_C (intersectUniqSets) a b
...@@ -48,9 +48,9 @@ type SpillCostRecord ...@@ -48,9 +48,9 @@ type SpillCostRecord
-- | Map of `SpillCostRecord` -- | Map of `SpillCostRecord`
type SpillCostInfo type SpillCostInfo
= UniqFM SpillCostRecord = UniqFM VirtualReg SpillCostRecord
type SpillCostState = State (UniqFM SpillCostRecord) () type SpillCostState = State SpillCostInfo ()
-- | An empty map of spill costs. -- | An empty map of spill costs.
zeroSpillCostInfo :: SpillCostInfo zeroSpillCostInfo :: SpillCostInfo
...@@ -264,7 +264,7 @@ spillCost_length info _ reg ...@@ -264,7 +264,7 @@ spillCost_length info _ reg
-- | Extract a map of register lifetimes from a `SpillCostInfo`. -- | Extract a map of register lifetimes from a `SpillCostInfo`.
lifeMapFromSpillCostInfo :: SpillCostInfo -> UniqFM (VirtualReg, Int) lifeMapFromSpillCostInfo :: SpillCostInfo -> UniqFM VirtualReg (VirtualReg, Int)
lifeMapFromSpillCostInfo info lifeMapFromSpillCostInfo info
= listToUFM = listToUFM
$ map (\(r, _, _, life) -> (r, (r, life))) $ map (\(r, _, _, life) -> (r, (r, life)))
......
...@@ -64,7 +64,7 @@ data RegAllocStats statics instr ...@@ -64,7 +64,7 @@ data RegAllocStats statics instr
, raGraph :: Color.Graph VirtualReg RegClass RealReg , raGraph :: Color.Graph VirtualReg RegClass RealReg
-- | The regs that were coalesced. -- | The regs that were coalesced.
, raCoalesced :: UniqFM VirtualReg , raCoalesced :: UniqFM VirtualReg VirtualReg
-- | Spiller stats. -- | Spiller stats.
, raSpillStats :: SpillStats , raSpillStats :: SpillStats
...@@ -88,7 +88,7 @@ data RegAllocStats statics instr ...@@ -88,7 +88,7 @@ data RegAllocStats statics instr
, raGraphColored :: Color.Graph VirtualReg RegClass RealReg , raGraphColored :: Color.Graph VirtualReg RegClass RealReg
-- | Regs that were coalesced. -- | Regs that were coalesced.
, raCoalesced :: UniqFM VirtualReg , raCoalesced :: UniqFM VirtualReg VirtualReg
-- | Code with coalescings applied. -- | Code with coalescings applied.
, raCodeCoalesced :: [LiveCmmDecl statics instr] , raCodeCoalesced :: [LiveCmmDecl statics instr]
...@@ -242,7 +242,7 @@ pprStatsLifetimes stats ...@@ -242,7 +242,7 @@ pprStatsLifetimes stats
$$ text "\n") $$ text "\n")
binLifetimeCount :: UniqFM (VirtualReg, Int) -> UniqFM (Int, Int) binLifetimeCount :: UniqFM VirtualReg (VirtualReg, Int) -> UniqFM Int (Int, Int)
binLifetimeCount fm binLifetimeCount fm
= let lifes = map (\l -> (l, (l, 1))) = let lifes = map (\l -> (l, (l, 1)))
$ map snd $ map snd
......
...@@ -119,6 +119,7 @@ import qualified GHC.CmmToAsm.Reg.Linear.X86 as X86 ...@@ -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 qualified GHC.CmmToAsm.Reg.Linear.X86_64 as X86_64
import GHC.CmmToAsm.Reg.Target import GHC.CmmToAsm.Reg.Target