[Git][ghc/ghc][wip/andreask/typedUniqFM] 2 commits: Add haddock changes for CI
Andreas Klebinger
gitlab at gitlab.haskell.org
Wed Jun 24 19:09:39 UTC 2020
Andreas Klebinger pushed to branch wip/andreask/typedUniqFM at Glasgow Haskell Compiler / GHC
Commits:
2e7872da by Andreas Klebinger at 2020-06-24T17:02:40+02:00
Add haddock changes for CI
- - - - -
ca404598 by Andreas Klebinger at 2020-06-24T21:09:23+02:00
some cleanup
- - - - -
20 changed files:
- .gitmodules
- compiler/GHC/Builtin/Utils.hs
- compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs
- compiler/GHC/CmmToAsm/Reg/Linear.hs
- compiler/GHC/CmmToAsm/Reg/Linear/Base.hs
- compiler/GHC/CmmToAsm/Reg/Linear/StackMap.hs
- compiler/GHC/CmmToAsm/Reg/Linear/State.hs
- compiler/GHC/CmmToAsm/Reg/Linear/Stats.hs
- compiler/GHC/CmmToAsm/Reg/Liveness.hs
- compiler/GHC/CmmToAsm/Reg/Utils.hs
- compiler/GHC/Core/FamInstEnv.hs
- compiler/GHC/Core/InstEnv.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/Types/Unique/DFM.hs
- compiler/GHC/Types/Unique/FM.hs
- compiler/GHC/Types/Unique/Set.hs
- compiler/GHC/Types/Var/Env.hs
- compiler/GHC/Utils/Binary.hs
- compiler/ghc.cabal.in
- utils/haddock
Changes:
=====================================
.gitmodules
=====================================
@@ -89,9 +89,9 @@
ignore = untracked
[submodule "utils/haddock"]
path = utils/haddock
- url = https://gitlab.haskell.org/ghc/haddock.git
+ url = https://github.com/AndreasPK/haddock.git
ignore = untracked
- branch = ghc-head
+ branch = wip/typed_uniqfm
[submodule "nofib"]
path = nofib
url = https://gitlab.haskell.org/ghc/nofib.git
=====================================
compiler/GHC/Builtin/Utils.hs
=====================================
@@ -206,7 +206,7 @@ isKnownKeyName n =
isJust (knownUniqueName $ nameUnique n) || elemUFM n knownKeysMap
knownKeysMap :: UniqFM Name Name
-knownKeysMap = listToUFM_Directly [ (nameUnique n, n) | n <- knownKeyNames ]
+knownKeysMap = listToIdentityUFM knownKeyNames
-- | Given a 'Unique' lookup any associated arbitrary SDoc's to be displayed by
-- GHCi's ':info' command.
=====================================
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)
@@ -70,8 +71,8 @@ regSpill platform code slotsFree slotCount regs
-- Allocate a slot for each of the spilled regs.
let slots = take (sizeUniqSet regs) $ nonDetEltsUniqSet slotsFree
let
- regSlotMap = unsafeCastUFMKey -- Cast keys from VirtualReg to Reg
- -- See Note [UniqFM and the register allocator]
+ 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
@@ -278,7 +279,7 @@ spillModify
-> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
spillModify regSlotMap instr reg
- | Just slot <- lookupUFM_U regSlotMap reg
+ | Just slot <- lookupUFM regSlotMap reg
= do (instr', nReg) <- patchInstr reg instr
modify $ \s -> s
=====================================
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
@@ -140,35 +141,6 @@ import Data.List
import Control.Monad
import Control.Applicative
-{- 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 it's 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 as result where we cast the types
- of keys in some places and introduce other sins. But the sins
- were always here. The now-typed keys just make them visible.
-
- 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.
--}
-
-- -----------------------------------------------------------------------------
-- Top level of the register allocator
@@ -456,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
@@ -592,8 +564,8 @@ genRaInsn block_live new_instrs block_id instr r_dying w_dying = do
-- (i) Patch the instruction
patch_map :: UniqFM Reg Reg
patch_map
- = unsafeCastUFMKey $ -- Cast key from VirtualReg to Reg
- -- See Note [UniqFM and the register allocator]
+ = 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
@@ -695,7 +667,8 @@ saveClobberedTemps clobbered dying
return instrs
where
- clobber :: UniqFM Reg Loc -> [instr] -> [(Unique,RealReg)] -> RegM freeRegs ([instr], RegMap Loc)
+ -- See Note [UniqFM and the register allocator]
+ clobber :: RegMap Loc -> [instr] -> [(Unique,RealReg)] -> RegM freeRegs ([instr], RegMap Loc)
clobber assig instrs []
= return (instrs, assig)
@@ -802,11 +775,11 @@ 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 (unsafeCastUFMKey assig)
- case lookupUFM_U assig r of
+ let doSpill = allocRegsAndSpill_spill reading keep spills alloc r rs assig
+ case lookupUFM assig r of
-- case (1a): already in a register
Just (InReg my_reg) ->
allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
@@ -817,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_U assig r (InReg my_reg)))
+ -> do when (not reading) (setAssigR $ toRegMap (addToUFM_U 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...
@@ -842,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_U (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
@@ -886,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_U 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
@@ -908,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 ]
@@ -929,7 +903,7 @@ allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc
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
@@ -948,7 +922,7 @@ allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc
-- update the register assignment
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
=====================================
compiler/GHC/CmmToAsm/Reg/Linear/Base.hs
=====================================
@@ -100,7 +100,8 @@ data SpillReason
-- | Used to carry interesting stats out of the register allocator.
data RegAllocStats
= RegAllocStats
- { ra_spillInstrs :: UniqFM Unique [Int]
+ { ra_spillInstrs :: UniqFM Unique [Int] -- Keys are the uniques of regs
+ -- and taken from SpillReason
, ra_fixupList :: [(BlockId,BlockId,BlockId)]
-- ^ (from,fixup,to) : We inserted fixup code between from and to
}
=====================================
compiler/GHC/CmmToAsm/Reg/Linear/StackMap.hs
=====================================
@@ -34,6 +34,7 @@ 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 Unique StackSlot }
=====================================
compiler/GHC/CmmToAsm/Reg/Linear/State.hs
=====================================
@@ -52,7 +52,6 @@ import GHC.Cmm.BlockId
import GHC.Platform
import GHC.Types.Unique
-import GHC.Types.Unique.FM
import GHC.Types.Unique.Supply
import Control.Monad (ap)
@@ -151,19 +150,13 @@ setFreeRegsR :: freeRegs -> RegM freeRegs ()
setFreeRegsR regs = RegM $ \ s ->
RA_Result s{ra_freeregs = regs} ()
--- | Key will always be Reg or VirtualReg.
--- But UniqFM doesn't support polymorphic keys...
--- See Note [UniqFM and the register allocator]
-getAssigR :: RegM freeRegs (UniqFM key Loc)
+getAssigR :: RegM freeRegs (RegMap Loc)
getAssigR = RegM $ \ s at RA_State{ra_assig = assig} ->
- RA_Result s (unsafeCastUFMKey assig)
+ RA_Result s assig
--- | Key will always be Reg or VirtualReg.
--- But UniqFM doesn't support polymorphic keys...
--- See Note [UniqFM and the register allocator]
-setAssigR :: UniqFM key Loc -> RegM freeRegs ()
+setAssigR :: RegMap Loc -> RegM freeRegs ()
setAssigR assig = RegM $ \ s ->
- RA_Result s{ra_assig=unsafeCastUFMKey assig} ()
+ RA_Result s{ra_assig=assig} ()
getBlockAssigR :: RegM freeRegs (BlockAssignment freeRegs)
getBlockAssigR = RegM $ \ s at RA_State{ra_blockassig = assig} ->
=====================================
compiler/GHC/CmmToAsm/Reg/Linear/Stats.hs
=====================================
@@ -21,7 +21,7 @@ import GHC.Utils.Monad.State
-- | Build a map of how many times each reg was alloced, clobbered, loaded etc.
binSpillReasons
:: [SpillReason] -> UniqFM Unique [Int]
-
+ -- See Note [UniqFM and the register allocator]
binSpillReasons reasons
= addListToUFM_C
(zipWith (+))
@@ -62,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
=====================================
compiler/GHC/CmmToAsm/Reg/Liveness.hs
=====================================
@@ -67,6 +67,10 @@ import Data.IntSet (IntSet)
type RegSet = UniqSet Reg
-- | 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 :: RegMap a
@@ -475,6 +479,7 @@ slurpReloadCoalesce live
mergeSlotMaps map1 map2
-- 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
=====================================
compiler/GHC/CmmToAsm/Reg/Utils.hs
=====================================
@@ -1,12 +1,59 @@
module GHC.CmmToAsm.Reg.Utils
- ( toRegMap
- , toVRegMap
- )
+ ( 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 it's 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 anyKey -> UniqFM Reg elt
+toRegMap :: UniqFM VirtualReg elt -> UniqFM Reg elt
toRegMap = unsafeCastUFMKey
--- toVRegMap
\ No newline at end of file
+toVRegMap :: UniqFM Reg elt -> UniqFM VirtualReg elt
+toVRegMap = unsafeCastUFMKey
+
=====================================
compiler/GHC/Core/FamInstEnv.hs
=====================================
@@ -352,10 +352,10 @@ UniqFM and UniqDFM.
See Note [Deterministic UniqFM].
-}
--- This is used both with Names, and TyCons.
--- But every tyCon has a name so just use the
--- names as key for now.
-type FamInstEnv = UniqDFM Name 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]
@@ -368,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)
@@ -391,7 +399,7 @@ familyInstances :: (FamInstEnv, FamInstEnv) -> TyCon -> [FamInst]
familyInstances (pkg_fie, home_fie) fam
= get home_fie ++ get pkg_fie
where
- get env = case lookupUDFM env (tyConName fam) of
+ get env = case lookupUDFM env fam of
Just (FamIE insts) -> insts
Nothing -> []
@@ -401,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)
@@ -770,7 +778,7 @@ lookupFamInstEnvByTyCon :: FamInstEnvs -> TyCon -> [FamInst]
lookupFamInstEnvByTyCon (pkg_ie, home_ie) fam_tc
= get pkg_ie ++ get home_ie
where
- get ie = case lookupUDFM ie (tyConName fam_tc) of
+ get ie = case lookupUDFM ie fam_tc of
Nothing -> []
Just (FamIE fis) -> fis
@@ -942,7 +950,7 @@ lookupFamInstEnvInjectivityConflicts injList (pkg_ie, home_ie)
| otherwise = True
lookup_inj_fam_conflicts ie
- | isOpenFamilyTyCon fam, Just (FamIE insts) <- lookupUDFM ie (tyConName fam)
+ | isOpenFamilyTyCon fam, Just (FamIE insts) <- lookupUDFM ie fam
= map (coAxiomSingleBranch . fi_axiom) $
filter isInjConflict insts
| otherwise = []
@@ -982,7 +990,7 @@ lookup_fam_inst_env' -- The worker, local to this module
-> [FamInstMatch]
lookup_fam_inst_env' match_fun ie fam match_tys
| isOpenFamilyTyCon fam
- , Just (FamIE insts) <- lookupUDFM ie (tyConName fam)
+ , Just (FamIE insts) <- lookupUDFM ie fam
= find insts -- The common case
| otherwise = []
where
=====================================
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,12 +386,16 @@ Testing with nofib and validate detected no difference between UniqFM and
UniqDFM. See also Note [Deterministic UniqFM]
-}
--- Class has a Unique which is the same as it's tyCon.
--- TyCon has a unique which is the same as it's Name.
--- Name just has a unique which is it's own.
--- We use all three to index into InstEnv ...
--- For now I'm giving it a key of Name.
-type InstEnv = UniqDFM Name 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 at .
+-- 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
@@ -453,7 +458,7 @@ classInstances :: InstEnvs -> Class -> [ClsInst]
classInstances (InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods }) cls
= get home_ie ++ get pkg_ie
where
- get env = case lookupUDFM env (className cls) of
+ get env = case lookupUDFM env cls of
Just (ClsIE insts) -> filter (instIsVisible vis_mods) insts
Nothing -> []
@@ -462,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))
@@ -472,20 +477,20 @@ 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)
deleteDFunFromInstEnv :: InstEnv -> DFunId -> InstEnv
-- Delete a specific instance fron an InstEnv
deleteDFunFromInstEnv inst_env dfun
- = adjustUDFM adjust inst_env (className cls)
+ = adjustUDFM adjust inst_env cls
where
(_, _, cls, _) = tcSplitDFunTy (idType dfun)
adjust (ClsIE items) = ClsIE (filterOut same_dfun items)
@@ -795,7 +800,7 @@ lookupInstEnv' ie vis_mods cls tys
all_tvs = all isNothing rough_tcs
--------------
- lookup env = case lookupUDFM env (className cls) of
+ lookup env = case lookupUDFM env cls of
Nothing -> ([],[]) -- No instances for this class
Just (ClsIE insts) -> find [] [] insts
=====================================
compiler/GHC/HsToCore/Monad.hs
=====================================
@@ -533,6 +533,9 @@ dsGetCompleteMatches :: TyCon -> DsM [CompleteMatch]
dsGetCompleteMatches tc = do
eps <- getEps
env <- getGblEnv
+ -- 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
=====================================
compiler/GHC/Types/Unique/DFM.hs
=====================================
@@ -29,16 +29,18 @@ module GHC.Types.Unique.DFM (
unitUDFM,
addToUDFM,
addToUDFM_C,
+ addToUDFM_C_Directly,
addToUDFM_Directly,
addListToUDFM,
delFromUDFM,
delListFromUDFM,
adjustUDFM,
+ adjustUDFM_Directly,
alterUDFM,
mapUDFM,
plusUDFM,
plusUDFM_C,
- lookupUDFM, lookupUDFM_Directly,
+ lookupUDFM, lookupUDFM_Directly, lookupUDFM_uncheckedKey,
elemUDFM,
foldUDFM,
eltsUDFM,
@@ -58,6 +60,7 @@ module GHC.Types.Unique.DFM (
udfmToList,
udfmToUfm,
nonDetStrictFoldUDFM,
+ unsafeCastUDFMKey,
alwaysUnsafeUfmToUdfm,
) where
@@ -73,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]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -175,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 key elt
-> Unique -> elt
-> UniqDFM key elt
-addToUDFM_Directly_C f (UDFM m i) u v
+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)
@@ -194,7 +198,7 @@ addToUDFM_C
-> UniqDFM key elt -- old
-> key -> elt -- new
-> UniqDFM key elt -- result
-addToUDFM_C f m k v = addToUDFM_Directly_C f m (getUnique k) v
+addToUDFM_C f m k v = addToUDFM_C_Directly f m (getUnique k) v
addListToUDFM :: Uniquable key => UniqDFM key elt -> [(key,elt)] -> UniqDFM key elt
addListToUDFM = foldl' (\m (k, v) -> addToUDFM m k v)
@@ -204,7 +208,7 @@ addListToUDFM_Directly = foldl' (\m (k, v) -> addToUDFM_Directly m k v)
addListToUDFM_Directly_C
:: (elt -> elt -> elt) -> UniqDFM key elt -> [(Unique,elt)] -> UniqDFM key elt
-addListToUDFM_Directly_C f = foldl' (\m (k, v) -> addToUDFM_Directly_C f m k v)
+addListToUDFM_Directly_C f = foldl' (\m (k, v) -> addToUDFM_C_Directly f m k v)
delFromUDFM :: Uniquable key => UniqDFM key elt -> key -> UniqDFM key elt
delFromUDFM (UDFM m i) k = UDFM (M.delete (getKey $ getUnique k) m) i
@@ -270,6 +274,12 @@ lookupUDFM (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey $ getUnique k) m
lookupUDFM_Directly :: UniqDFM key elt -> Unique -> Maybe elt
lookupUDFM_Directly (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey k) m
+-- | Avoid if possible.
+--
+-- looks up an element by unique ignoring the keys type.
+lookupUDFM_uncheckedKey :: Uniquable anyKey => UniqDFM key elt -> anyKey -> Maybe elt
+lookupUDFM_uncheckedKey (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey $ getUnique k) m
+
elemUDFM :: Uniquable key => key -> UniqDFM key elt -> Bool
elemUDFM k (UDFM m _i) = M.member (getKey $ getUnique k) m
@@ -369,6 +379,10 @@ listToUDFM_Directly = foldl' (\m (u, v) -> addToUDFM_Directly m u v) emptyUDFM
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
@@ -409,6 +423,14 @@ instance Monoid (UniqDFM key a) where
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 key a) where
=====================================
compiler/GHC/Types/Unique/FM.hs
=====================================
@@ -37,6 +37,7 @@ module GHC.Types.Unique.FM (
listToUFM,
listToUFM_Directly,
listToUFM_C,
+ listToIdentityUFM,
addToUFM,addToUFM_C,addToUFM_Acc, addToUFM_C_Directly,
addListToUFM,addListToUFM_C, addListToUFM_C_Directly,
addToUFM_Directly, addToUFM_U,
@@ -118,6 +119,9 @@ listToUFM = foldl' (\m (k, v) -> addToUFM m k v) emptyUFM
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)
=====================================
compiler/GHC/Types/Unique/Set.hs
=====================================
@@ -146,7 +146,7 @@ isEmptyUniqSet :: UniqSet a -> Bool
isEmptyUniqSet (UniqSet s) = isNullUFM s
-- | What's the point you might ask? We might have changed an object
--- without it's key. In which case this lookup makes sense.
+-- 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
=====================================
compiler/GHC/Types/Var/Env.hs
=====================================
@@ -552,7 +552,7 @@ type DVarEnv elt = UniqDFM Var elt
-- | Deterministic Identifier Environment
-- Sadly not always indexed by Id, but it is in the common case.
-type DIdEnv elt = UniqDFM Id elt
+type DIdEnv elt = UniqDFM Var elt
-- | Deterministic Type Variable Environment
type DTyVarEnv elt = UniqDFM TyVar elt
=====================================
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 key (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)))
=====================================
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
=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit 02a1def8d147da88a0433726590f8586f486c760
+Subproject commit 3885f80bf653fdf173f13a397692b97015bfd812
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/874e5c6598d1526f0cb55c914056371338ec7f82...ca404598aa0178a46aaa851acc1c2a6c89a33144
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/874e5c6598d1526f0cb55c914056371338ec7f82...ca404598aa0178a46aaa851acc1c2a6c89a33144
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200624/ac4e9b5e/attachment-0001.html>
More information about the ghc-commits
mailing list