[Git][ghc/ghc][wip/romes/12935] More NonDet
Matthew Pickering (@mpickering)
gitlab at gitlab.haskell.org
Thu Jul 11 17:01:25 UTC 2024
Matthew Pickering pushed to branch wip/romes/12935 at Glasgow Haskell Compiler / GHC
Commits:
7cf3301e by Matthew Pickering at 2024-07-11T17:58:38+01:00
More NonDet
- - - - -
9 changed files:
- compiler/GHC/Cmm/DebugBlock.hs
- compiler/GHC/CmmToAsm.hs
- compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs
- compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs
- compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs
- compiler/GHC/CmmToAsm/Reg/Linear.hs
- compiler/GHC/CmmToAsm/Reg/Linear/Base.hs
- compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs
- compiler/GHC/CmmToAsm/Reg/Liveness.hs
Changes:
=====================================
compiler/GHC/Cmm/DebugBlock.hs
=====================================
@@ -57,6 +57,7 @@ import Data.Maybe
import Data.List ( minimumBy, nubBy )
import Data.Ord ( comparing )
import qualified Data.Map as Map
+import qualified GHC.Cmm.Dataflow.Label.NonDet as NonDet
-- | Debug information about a block of code. Ticks scope over nested
-- blocks.
@@ -250,7 +251,7 @@ cmmDebugLabels is_valid_label isMeta nats = seqList lbls lbls
-- | Sets position and unwind table fields in the debug block tree according to
-- native generated code.
-cmmDebugLink :: [Label] -> LabelMap [UnwindPoint]
+cmmDebugLink :: [Label] -> NonDet.LabelMap [UnwindPoint]
-> [DebugBlock] -> [DebugBlock]
cmmDebugLink labels unwindPts blocks = mapMaybe link blocks
where blockPos :: LabelMap Int
@@ -262,7 +263,7 @@ cmmDebugLink labels unwindPts blocks = mapMaybe link blocks
pos -> Just $ block
{ dblPosition = pos
, dblBlocks = mapMaybe link (dblBlocks block)
- , dblUnwind = fromMaybe mempty $ mapLookup (dblLabel block) unwindPts
+ , dblUnwind = fromMaybe mempty $ NonDet.mapLookup (dblLabel block) unwindPts
}
-- | Converts debug blocks into a label map for easier lookups
=====================================
compiler/GHC/CmmToAsm.hs
=====================================
@@ -169,7 +169,7 @@ data NativeGenAcc statics instr
, ngs_labels :: ![Label]
, ngs_debug :: ![DebugBlock]
, ngs_dwarfFiles :: !DwarfFiles
- , ngs_unwinds :: !(LabelMap [UnwindPoint])
+ , ngs_unwinds :: !(NonDet.LabelMap [UnwindPoint])
-- ^ see Note [Unwinding information in the NCG]
-- and Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock".
}
@@ -213,7 +213,7 @@ nativeCodeGen' logger config modLoc ncgImpl h us cmms
-- Pretty if it weren't for the fact that we do lots of little
-- printDocs here (in order to do codegen in constant space).
bufh <- newBufHandle h
- let ngs0 = NGS [] [] [] [] [] [] emptyUFM mapEmpty
+ let ngs0 = NGS [] [] [] [] [] [] emptyUFM NonDet.mapEmpty
(ngs, us', a) <- cmmNativeGenStream logger config modLoc ncgImpl bufh us
cmms ngs0
_ <- finishNativeGen logger config modLoc bufh us' ngs
@@ -408,7 +408,7 @@ cmmNativeGens logger config ncgImpl h dbgMap = go
, ngs_linearStats = linearStats `mCon` ngs_linearStats ngs
, ngs_labels = ngs_labels ngs ++ labels'
, ngs_dwarfFiles = fileIds'
- , ngs_unwinds = ngs_unwinds ngs `mapUnion` unwinds
+ , ngs_unwinds = ngs_unwinds ngs `NonDet.mapUnion` unwinds
}
go us' cmms ngs' (count + 1)
@@ -442,7 +442,7 @@ cmmNativeGen
, [CLabel] -- things imported by this cmm
, Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator
, Maybe [Linear.RegAllocStats] -- stats for the linear register allocators
- , LabelMap [UnwindPoint] -- unwinding information for blocks
+ , BlockMap [UnwindPoint] -- unwinding information for blocks
, Maybe CFG -- final CFG
)
@@ -671,10 +671,10 @@ cmmNativeGen logger ncgImpl us fileIds dbgMap cmm count
let unwinds :: BlockMap [UnwindPoint]
unwinds =
{-# SCC "unwindingInfo" #-}
- foldl' addUnwind mapEmpty branchOpt
+ foldl' addUnwind NonDet.mapEmpty branchOpt
where
addUnwind acc proc =
- acc `mapUnion` computeUnwinding config ncgImpl proc
+ acc `NonDet.mapUnion` computeUnwinding config ncgImpl proc
return ( us_seq
, fileIds'
@@ -719,12 +719,12 @@ computeUnwinding :: Instruction instr
-> NcgImpl statics instr jumpDest
-> NatCmmDecl statics instr
-- ^ the native code generated for the procedure
- -> LabelMap [UnwindPoint]
+ -> BlockMap [UnwindPoint]
-- ^ unwinding tables for all points of all blocks of the
-- procedure
computeUnwinding config _ _
- | not (ncgComputeUnwinding config) = mapEmpty
-computeUnwinding _ _ (CmmData _ _) = mapEmpty
+ | not (ncgComputeUnwinding config) = NonDet.mapEmpty
+computeUnwinding _ _ (CmmData _ _) = NonDet.mapEmpty
computeUnwinding _ ncgImpl (CmmProc _ _ _ (ListGraph blks)) =
-- In general we would need to push unwinding information down the
-- block-level call-graph to ensure that we fully account for all
@@ -734,8 +734,8 @@ computeUnwinding _ ncgImpl (CmmProc _ _ _ (ListGraph blks)) =
-- Sp. The fact that GHC.Cmm.LayoutStack already ensures that we have unwind
-- information at the beginning of every block means that there is no need
-- to perform this sort of push-down.
- mapFromList [ (blk_lbl, extractUnwindPoints ncgImpl instrs)
- | BasicBlock blk_lbl instrs <- blks ]
+ NonDet.mapFromList [ (blk_lbl, extractUnwindPoints ncgImpl instrs)
+ | BasicBlock blk_lbl instrs <- blks ]
-- | Build a doc for all the imports.
--
=====================================
compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs
=====================================
@@ -15,8 +15,7 @@ import GHC.CmmToAsm.Instr
import GHC.Platform.Reg
import GHC.Cmm hiding (RegSet)
import GHC.Cmm.BlockId
-import GHC.Cmm.Dataflow.Label (mapFoldlWithKey, mapLookup, mapInsert)
---import qualified GHC.Cmm.Dataflow.Label.NonDet as NonDet
+import qualified GHC.Cmm.Dataflow.Label.NonDet as NonDet
import GHC.Utils.Monad
import GHC.Utils.Monad.State.Strict
@@ -124,7 +123,7 @@ regSpill_top platform regSlotMap cmm
-- after we've done a successful allocation.
let liveSlotsOnEntry' :: BlockMap IntSet
liveSlotsOnEntry'
- = mapFoldlWithKey patchLiveSlot
+ = NonDet.nonDetMapFoldlWithKey patchLiveSlot
liveSlotsOnEntry liveVRegsOnEntry
let info'
@@ -148,7 +147,7 @@ regSpill_top platform regSlotMap cmm
= let
-- Slots that are already recorded as being live.
curSlotsLive = fromMaybe IntSet.empty
- $ mapLookup blockId slotMap
+ $ NonDet.mapLookup blockId slotMap
moreSlotsLive = IntSet.fromList
$ mapMaybe (lookupUFM regSlotMap)
@@ -156,8 +155,8 @@ regSpill_top platform regSlotMap cmm
-- See Note [Unique Determinism and code generation]
slotMap'
- = mapInsert blockId (IntSet.union curSlotsLive moreSlotsLive)
- slotMap
+ = NonDet.mapInsert blockId (IntSet.union curSlotsLive moreSlotsLive)
+ slotMap
in slotMap'
=====================================
compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs
=====================================
@@ -49,8 +49,7 @@ import GHC.Utils.Monad.State.Strict
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Platform
-import GHC.Cmm.Dataflow.Label (mapLookup)
---import qualified GHC.Cmm.Dataflow.Label.NonDet as NonDet (mapLookup)
+import qualified GHC.Cmm.Dataflow.Label.NonDet as NonDet (mapLookup)
import Data.List (nub, foldl1', find)
import Data.Maybe
@@ -391,7 +390,7 @@ cleanBackward' liveSlotsOnEntry reloadedBy noReloads acc (li : instrs)
= do
let slotsReloadedByTargets
= IntSet.unions
- $ mapMaybe (flip mapLookup liveSlotsOnEntry)
+ $ mapMaybe (flip NonDet.mapLookup liveSlotsOnEntry)
$ targets
let noReloads'
=====================================
compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs
=====================================
@@ -24,7 +24,6 @@ import GHC.Platform.Reg
import GHC.Data.Graph.Base
-import GHC.Cmm.Dataflow.Label (mapLookup)
import qualified GHC.Cmm.Dataflow.Label.NonDet as NonDet (mapLookup, Label, LabelMap)
import GHC.Cmm
import GHC.Types.Unique.FM
@@ -99,7 +98,7 @@ slurpSpillCostInfo platform cfg cmm
-- the info table from the CmmProc.
countBlock info freqMap (BasicBlock blockId instrs)
| LiveInfo _ _ blockLive _ <- info
- , Just rsLiveEntry <- mapLookup blockId blockLive
+ , Just rsLiveEntry <- NonDet.mapLookup blockId blockLive
, rsLiveEntry_virt <- takeVirtuals rsLiveEntry
= countLIs (ceiling $ blockFreq freqMap blockId) rsLiveEntry_virt instrs
=====================================
compiler/GHC/CmmToAsm/Reg/Linear.hs
=====================================
@@ -122,7 +122,7 @@ import GHC.Platform.Reg
import GHC.Platform.Reg.Class (RegClass(..))
import GHC.Cmm.BlockId
-import GHC.Cmm.Dataflow.Label (mapLookup)
+import qualified GHC.Cmm.Dataflow.Label.NonDet as NonDet (mapLookup)
import GHC.Cmm hiding (RegSet)
import GHC.Data.Graph.Directed
@@ -359,7 +359,7 @@ initBlock id block_live
-- empty.
Nothing
-> do -- pprTrace "initFreeRegs" (text $ show initFreeRegs) (return ())
- case mapLookup id block_live of
+ case NonDet.mapLookup id block_live of
Nothing ->
setFreeRegsR (frInitFreeRegs platform)
Just live ->
=====================================
compiler/GHC/CmmToAsm/Reg/Linear/Base.hs
=====================================
@@ -34,8 +34,7 @@ import GHC.Types.Unique
import GHC.Types.Unique.FM
import GHC.Types.Unique.DSM
import GHC.Cmm.BlockId
-import GHC.Cmm.Dataflow.Label
---import qualified GHC.Cmm.Dataflow.Label as NonDet
+import qualified GHC.Cmm.Dataflow.Label.NonDet as NonDet
import GHC.CmmToAsm.Reg.Utils
data ReadingOrWriting = Reading | Writing deriving (Eq,Ord)
@@ -51,7 +50,7 @@ data BlockAssignment freeRegs
-- | Find the register mapping for a specific BlockId.
lookupBlockAssignment :: BlockId -> BlockAssignment freeRegs -> Maybe (freeRegs, RegMap Loc)
-lookupBlockAssignment bid ba = mapLookup bid (blockMap ba)
+lookupBlockAssignment bid ba = NonDet.mapLookup bid (blockMap ba)
-- | Lookup which register a virtual register was first assigned to.
lookupFirstUsed :: VirtualReg -> BlockAssignment freeRegs -> Maybe RealReg
@@ -59,7 +58,7 @@ lookupFirstUsed vr ba = lookupUFM (firstUsed ba) vr
-- | An initial empty 'BlockAssignment'
emptyBlockAssignment :: BlockAssignment freeRegs
-emptyBlockAssignment = BlockAssignment mapEmpty mempty
+emptyBlockAssignment = BlockAssignment NonDet.mapEmpty mempty
-- | Add new register mappings for a specific block.
updateBlockAssignment :: BlockId
@@ -67,7 +66,7 @@ updateBlockAssignment :: BlockId
-> BlockAssignment freeRegs
-> BlockAssignment freeRegs
updateBlockAssignment dest (freeRegs, regMap) (BlockAssignment {..}) =
- BlockAssignment (mapInsert dest (freeRegs, regMap) blockMap)
+ BlockAssignment (NonDet.mapInsert dest (freeRegs, regMap) blockMap)
(mergeUFM combWithExisting id (mapMaybeUFM fromLoc) (firstUsed) (toVRegMap regMap))
where
-- The blocks are processed in dependency order, so if there's already an
=====================================
compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs
=====================================
@@ -23,7 +23,7 @@ import GHC.CmmToAsm.Types
import GHC.Platform.Reg
import GHC.Cmm.BlockId
-import GHC.Cmm.Dataflow.Label (mapLookup)
+import qualified GHC.Cmm.Dataflow.Label.NonDet as NonDet (mapLookup)
import GHC.Data.Graph.Directed
import GHC.Utils.Panic
import GHC.Utils.Monad (concatMapM)
@@ -89,7 +89,7 @@ joinToTargets' block_live new_blocks block_id instr (dest:dests)
-- adjust the current assignment to remove any vregs that are not live
-- on entry to the destination block.
- let Just live_set = mapLookup dest block_live
+ let Just live_set = NonDet.mapLookup dest block_live
let still_live uniq _ = uniq `elemUniqSet_Directly` live_set
let adjusted_assig = filterUFM_Directly still_live assig
=====================================
compiler/GHC/CmmToAsm/Reg/Liveness.hs
=====================================
@@ -46,9 +46,9 @@ import GHC.CmmToAsm.Types
import GHC.CmmToAsm.Utils
import GHC.Cmm.BlockId
-import GHC.Cmm.Dataflow.Label (LabelMap, mapInsert, mapEmpty, mapFilterWithKey, mapLookup, mapMap, mapMapWithKey, mapToList)
+import GHC.Cmm.Dataflow.Label (LabelMap, mapFilterWithKey)
import GHC.Cmm.Dataflow.Label.NonDet (LabelSet, setMember, setFromList)
---import qualified GHC.Cmm.Dataflow.Label.NonDet as NonDet
+import qualified GHC.Cmm.Dataflow.Label.NonDet as NonDet
import GHC.Cmm hiding (RegSet, emptyRegSet)
import GHC.Data.Graph.Directed
@@ -82,7 +82,7 @@ emptyRegMap = emptyUFM
emptyRegSet :: RegSet
emptyRegSet = emptyUniqSet
-type BlockMap a = LabelMap a
+type BlockMap a = NonDet.LabelMap a
type SlotMap a = UniqFM Slot a
@@ -348,7 +348,7 @@ slurpConflicts live
slurpBlock info rs (BasicBlock blockId instrs)
| LiveInfo _ _ blockLive _ <- info
- , Just rsLiveEntry <- mapLookup blockId blockLive
+ , Just rsLiveEntry <- NonDet.mapLookup blockId blockLive
, (conflicts, moves) <- slurpLIs rsLiveEntry rs instrs
= (consBag rsLiveEntry conflicts, moves)
@@ -625,7 +625,7 @@ patchEraseLive patchF cmm
= let
patchRegSet set = mkUniqSet $ map patchF $ nonDetEltsUFM set
-- See Note [Unique Determinism and code generation]
- blockMap' = mapMap (patchRegSet . getUniqSet) blockMap
+ blockMap' = NonDet.mapMap (patchRegSet . getUniqSet) blockMap
info' = LiveInfo static id blockMap' mLiveSlots
in CmmProc info' label live $ map patchSCC sccs
@@ -705,10 +705,10 @@ natCmmTopToLive _ (CmmData i d)
= CmmData i d
natCmmTopToLive _ (CmmProc info lbl live (ListGraph []))
- = CmmProc (LiveInfo info [] mapEmpty mapEmpty) lbl live []
+ = CmmProc (LiveInfo info [] NonDet.mapEmpty NonDet.mapEmpty) lbl live []
natCmmTopToLive mCfg proc@(CmmProc info lbl live (ListGraph blocks@(first : _)))
- = CmmProc (LiveInfo info' (first_id : entry_ids) mapEmpty mapEmpty)
+ = CmmProc (LiveInfo info' (first_id : entry_ids) NonDet.mapEmpty NonDet.mapEmpty)
lbl live sccsLive
where
first_id = blockId first
@@ -794,7 +794,7 @@ regLiveness _ (CmmData i d)
regLiveness _ (CmmProc info lbl live [])
| LiveInfo static mFirst _ _ <- info
= return $ CmmProc
- (LiveInfo static mFirst mapEmpty mapEmpty)
+ (LiveInfo static mFirst NonDet.mapEmpty NonDet.mapEmpty)
lbl live []
regLiveness platform (CmmProc info lbl live sccs)
@@ -876,7 +876,7 @@ computeLiveness
computeLiveness platform sccs
= case checkIsReverseDependent sccs of
- Nothing -> livenessSCCs platform mapEmpty [] sccs
+ Nothing -> livenessSCCs platform NonDet.mapEmpty [] sccs
Just bad -> let sccs' = fmap (fmap (fmap (fmap (pprInstr platform)))) sccs
in pprPanic "RegAlloc.Liveness.computeLiveness"
(vcat [ text "SCCs aren't in reverse dependent order"
@@ -928,8 +928,8 @@ livenessSCCs platform blockmap done
-- BlockMaps for equality.
equalBlockMaps a b
= a' == b'
- where a' = mapToList $ mapMapWithKey f a
- b' = mapToList $ mapMapWithKey f b
+ where a' = NonDet.nonDetMapToList $ NonDet.mapMapWithKey f a
+ b' = NonDet.nonDetMapToList $ NonDet.mapMapWithKey f b
f key elt = (key, nonDetEltsUniqSet elt)
-- See Note [Unique Determinism and code generation]
@@ -948,7 +948,7 @@ livenessBlock platform blockmap (BasicBlock block_id instrs)
= let
(regsLiveOnEntry, instrs1)
= livenessBack platform emptyUniqSet blockmap [] (reverse instrs)
- blockmap' = mapInsert block_id regsLiveOnEntry blockmap
+ blockmap' = NonDet.mapInsert block_id regsLiveOnEntry blockmap
instrs2 = livenessForward platform regsLiveOnEntry instrs1
@@ -1058,7 +1058,7 @@ liveness1 platform liveregs blockmap (LiveInstr instr _)
not_a_branch = null targets
targetLiveRegs target
- = case mapLookup target blockmap of
+ = case NonDet.mapLookup target blockmap of
Just ra -> ra
Nothing -> emptyRegSet
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7cf3301e1fdb0136d4087e4977330b6775858a28
--
This project does not include diff previews in email notifications.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7cf3301e1fdb0136d4087e4977330b6775858a28
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/20240711/8ebac792/attachment-0001.html>
More information about the ghc-commits
mailing list