[Git][ghc/ghc][wip/ne-cyclic-scc] Replace CyclicSCC with NECyclicSCC in a few trivial places
Bodigrim (@Bodigrim)
gitlab at gitlab.haskell.org
Sat Feb 1 00:22:39 UTC 2025
Bodigrim pushed to branch wip/ne-cyclic-scc at Glasgow Haskell Compiler / GHC
Commits:
c8cf9773 by Andrew Lelechenko at 2025-02-01T00:22:26+00:00
Replace CyclicSCC with NECyclicSCC in a few trivial places
- - - - -
14 changed files:
- compiler/GHC/CmmToAsm/CFG.hs
- compiler/GHC/CmmToAsm/Reg/Linear.hs
- compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs
- compiler/GHC/Data/Graph/Directed/Reachability.hs
- compiler/GHC/Driver/MakeFile.hs
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/StgToJS/Sinker/Sinker.hs
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Unit/State.hs
- compiler/GHC/Utils/Outputable.hs
- ghc/Main.hs
- utils/haddock/haddock-api/src/Haddock/Interface.hs
Changes:
=====================================
compiler/GHC/CmmToAsm/CFG.hs
=====================================
@@ -804,7 +804,7 @@ loopMembers cfg =
setLevel :: SCC BlockId -> LabelMap Bool -> LabelMap Bool
setLevel (AcyclicSCC bid) m = mapInsert bid False m
- setLevel (CyclicSCC bids) m = foldl' (\m k -> mapInsert k True m) m bids
+ setLevel (NECyclicSCC bids) m = foldl' (\m k -> mapInsert k True m) m bids
loopLevels :: CFG -> BlockId -> LabelMap Int
loopLevels cfg root = liLevels loopInfos
=====================================
compiler/GHC/CmmToAsm/Reg/Linear.hs
=====================================
@@ -140,6 +140,8 @@ import GHC.Platform
import Data.Containers.ListUtils
import Data.Maybe
import Data.List (sortOn)
+import Data.List.NonEmpty (NonEmpty)
+import qualified Data.List.NonEmpty as NE
import Control.Monad
-- -----------------------------------------------------------------------------
@@ -273,7 +275,7 @@ linearRA_SCCs entry_ids block_live blocksAcc (AcyclicSCC block : sccs)
((reverse blocks') ++ blocksAcc)
sccs
-linearRA_SCCs entry_ids block_live blocksAcc (CyclicSCC blocks : sccs)
+linearRA_SCCs entry_ids block_live blocksAcc (NECyclicSCC blocks : sccs)
= do
blockss' <- process entry_ids block_live blocks
linearRA_SCCs entry_ids block_live
@@ -295,10 +297,10 @@ linearRA_SCCs entry_ids block_live blocksAcc (CyclicSCC blocks : sccs)
process :: forall freeRegs instr. (OutputableRegConstraint freeRegs instr)
=> [BlockId]
-> BlockMap (UniqSet RegWithFormat)
- -> [GenBasicBlock (LiveInstr instr)]
+ -> NonEmpty (GenBasicBlock (LiveInstr instr))
-> RegM freeRegs [[NatBasicBlock instr]]
process entry_ids block_live =
- \blocks -> go blocks [] (return []) False
+ \blocks -> go (NE.toList blocks) [] (return []) False
where
go :: [GenBasicBlock (LiveInstr instr)]
-> [GenBasicBlock (LiveInstr instr)]
=====================================
compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs
=====================================
@@ -33,6 +33,8 @@ import GHC.Utils.Outputable
import GHC.CmmToAsm.Format
import GHC.Types.Unique.Set
+import Data.List.NonEmpty (NonEmpty(..))
+
-- | For a jump instruction at the end of a block, generate fixup code so its
-- vregs are in the correct regs for its destination.
--
@@ -327,7 +329,7 @@ handleComponent delta _ (AcyclicSCC (DigraphNode vreg src dsts))
-- require a fixup.
--
handleComponent delta instr
- (CyclicSCC ((DigraphNode vreg (InReg (RealRegUsage sreg scls)) ((InReg (RealRegUsage dreg dcls): _))) : rest))
+ (NECyclicSCC ((DigraphNode vreg (InReg (RealRegUsage sreg scls)) ((InReg (RealRegUsage dreg dcls): _))) :| rest))
-- dest list may have more than one element, if the reg is also InMem.
= do
-- spill the source into its slot
@@ -344,7 +346,7 @@ handleComponent delta instr
-- so we don't end up clobbering the source values.
return (instrSpill ++ concat remainingFixUps ++ instrLoad)
-handleComponent _ _ (CyclicSCC _)
+handleComponent _ _ (NECyclicSCC _)
= panic "Register Allocator: handleComponent cyclic"
=====================================
compiler/GHC/Data/Graph/Directed/Reachability.hs
=====================================
@@ -21,6 +21,7 @@ import Data.Graph ( Vertex, SCC(..) )
import Data.Array ((!))
import qualified Data.IntMap as IM
import qualified Data.IntSet as IS
+import qualified Data.List.NonEmpty as NE
import GHC.Data.Graph.Directed.Internal
@@ -84,9 +85,9 @@ cyclicGraphReachability (Graph g from to) =
earlier_neighbours = neighboursOf v
earlier_further = mapMaybe (flip IM.lookup earlier) earlier_neighbours
all_remotes = IS.unions (IS.fromList earlier_neighbours : earlier_further)
- add_one_comp earlier (CyclicSCC vs) = IM.union (IM.fromList [(v, local v `IS.union` all_remotes) | v <- vs]) earlier
+ add_one_comp earlier (NECyclicSCC vs) = IM.union (IM.fromList [(v, local v `IS.union` all_remotes) | v <- NE.toList vs]) earlier
where
- all_locals = IS.fromList vs
+ all_locals = IS.fromList (NE.toList vs)
local v = IS.delete v all_locals
-- Arguably, for a cyclic SCC we should include each
-- vertex in its own reachable set. However, this could
=====================================
compiler/GHC/Driver/MakeFile.hs
=====================================
@@ -211,9 +211,9 @@ processDeps :: DynFlags
--
-- For {-# SOURCE #-} imports the "hi" will be "hi-boot".
-processDeps _ _ _ _ _ (CyclicSCC nodes)
+processDeps _ _ _ _ _ (NECyclicSCC nodes)
= -- There shouldn't be any cycles; report them
- throwOneError $ cyclicModuleErr nodes
+ throwOneError $ cyclicModuleErr $ NE.toList nodes
processDeps _ _ _ _ _ (AcyclicSCC (InstantiationNode _uid node))
= -- There shouldn't be any backpack instantiations; report them as well
=====================================
compiler/GHC/HsToCore/Binds.hs
=====================================
@@ -75,6 +75,7 @@ import GHC.Data.Maybe
import GHC.Data.OrdList
import GHC.Data.Graph.Directed
import GHC.Data.Bag
+import qualified Data.List.NonEmpty as NE
import qualified Data.Set as S
import GHC.Utils.Constants (debugIsOn)
@@ -1384,9 +1385,9 @@ dsEvBinds ev_binds thing_inside
new_unspecables
| transitively_unspecable = S.singleton v
| otherwise = mempty
- ds_component unspecables (CyclicSCC nodes) = (Rec pairs, new_unspecables)
+ ds_component unspecables (NECyclicSCC nodes) = (Rec pairs, new_unspecables)
where
- (pairs, direct_canonicity) = unzip $ map unpack_node nodes
+ (pairs, direct_canonicity) = unzip $ map unpack_node $ NE.toList nodes
is_unspecable_remote dep = dep `S.member` unspecables
transitively_unspecable = or [ is_unspecable this_canonical || any is_unspecable_remote deps
=====================================
compiler/GHC/Iface/Recomp.hs
=====================================
@@ -70,6 +70,7 @@ import GHC.Unit.Module.Deps
import Control.Monad
import Data.List (sortBy, sort, sortOn)
+import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Word (Word64)
@@ -1062,8 +1063,8 @@ addFingerprints hsc_env iface0
env' <- extend_hash_env local_env (hash,decl)
return (env', (hash,decl) : decls_w_hashes)
- fingerprint_group (local_env, decls_w_hashes) (CyclicSCC abis)
- = do let stable_abis = sortBy cmp_abiNames abis
+ fingerprint_group (local_env, decls_w_hashes) (NECyclicSCC abis)
+ = do let stable_abis = sortBy cmp_abiNames (NE.toList abis)
stable_decls = map abiDecl stable_abis
local_env1 <- foldM extend_hash_env local_env
(zip (map mkRecFingerprint [0..]) stable_decls)
=====================================
compiler/GHC/Rename/Bind.hs
=====================================
@@ -77,6 +77,7 @@ import Language.Haskell.Syntax.Basic (FieldLabelString(..))
import Control.Monad
import Data.List ( partition )
import Data.List.NonEmpty ( NonEmpty(..) )
+import qualified Data.List.NonEmpty as NE
import GHC.Types.Unique.DSet (mkUniqDSet)
import GHC.Data.BooleanFormula (bfTraverse)
@@ -651,13 +652,13 @@ depAnalBinds binds_w_dus
binds_w_dus
get_binds (AcyclicSCC (bind, _, _)) = (NonRecursive, [bind])
- get_binds (CyclicSCC binds_w_dus) = (Recursive, [b | (b,_,_) <- binds_w_dus])
+ get_binds (NECyclicSCC binds_w_dus) = (Recursive, [b | (b,_,_) <- NE.toList binds_w_dus])
get_du (AcyclicSCC (_, bndrs, uses)) = (Just (mkNameSet bndrs), uses)
- get_du (CyclicSCC binds_w_dus) = (Just defs, uses)
+ get_du (NECyclicSCC binds_w_dus) = (Just defs, uses)
where
- defs = mkNameSet [b | (_,bs,_) <- binds_w_dus, b <- bs]
- uses = unionNameSets [u | (_,_,u) <- binds_w_dus]
+ defs = mkNameSet [b | (_,bs,_) <- NE.toList binds_w_dus, b <- bs]
+ uses = unionNameSets [u | (_,_,u) <- NE.toList binds_w_dus]
---------------------
-- Bind the top-level forall'd type variables in the sigs.
=====================================
compiler/GHC/StgToJS/Sinker/Sinker.hs
=====================================
@@ -137,6 +137,6 @@ topSortDecls _m binds = rest ++ nr'
[ (i, b) | StgVarArg i <- args, i `elementOfUniqSet` keys ]
collectDeps _ = []
g = graphFromVerticesAndAdjacency vs (concatMap collectDeps nr)
- nr' | (not . null) [()| CyclicSCC _ <- stronglyConnCompG g]
+ nr' | (not . null) [()| NECyclicSCC _ <- stronglyConnCompG g]
= error "topSortDecls: unexpected cycle"
| otherwise = map node_payload (topologicalSortG g)
=====================================
compiler/GHC/Tc/Gen/Bind.hs
=====================================
@@ -92,6 +92,7 @@ import GHC.Data.Maybe
import Control.Monad
import Data.Foldable (find, traverse_)
+import qualified Data.List.NonEmpty as NE
{-
************************************************************************
@@ -398,7 +399,7 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside
go [] = do { thing <- thing_inside; return ([], thing) }
tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind]
- tc_scc (CyclicSCC binds) = tc_sub_group Recursive binds
+ tc_scc (NECyclicSCC binds) = tc_sub_group Recursive (NE.toList binds)
tc_sub_group rec_tc binds = tcPolyBinds top_lvl sig_fn prag_fn
Recursive rec_tc closed binds
=====================================
compiler/GHC/Unit/State.hs
=====================================
@@ -111,6 +111,7 @@ import Control.Monad
import Data.Graph (stronglyConnComp, SCC(..))
import Data.Char ( toUpper )
import Data.List ( intersperse, partition, sortBy, isSuffixOf, sortOn )
+import qualified Data.List.NonEmpty as NE
import Data.Set (Set)
import Data.Monoid (First(..))
import qualified Data.Semigroup as Semigroup
@@ -1266,10 +1267,10 @@ reportCycles :: Logger -> [SCC UnitInfo] -> IO ()
reportCycles logger sccs = mapM_ report sccs
where
report (AcyclicSCC _) = return ()
- report (CyclicSCC vs) =
+ report (NECyclicSCC vs) =
debugTraceMsg logger 2 $
text "these packages are involved in a cycle:" $$
- nest 2 (hsep (map (ppr . unitId) vs))
+ nest 2 (hsep (map (ppr . unitId) (NE.toList vs)))
reportUnusable :: Logger -> UnusableUnits -> IO ()
reportUnusable logger pkgs = mapM_ report (nonDetUniqMapToList pkgs)
@@ -1431,7 +1432,7 @@ validateDatabase cfg pkg_map1 =
-- Find recursive units
sccs = stronglyConnComp [ (pkg, unitId pkg, unitDepends pkg)
| pkg <- nonDetEltsUniqMap pkg_map2 ]
- getCyclicSCC (CyclicSCC vs) = map unitId vs
+ getCyclicSCC (NECyclicSCC vs) = map unitId (NE.toList vs)
getCyclicSCC (AcyclicSCC _) = []
(pkg_map3, cyclic) = removeUnits (concatMap getCyclicSCC sccs) index pkg_map2
unusable_cyclic = mk_unusable CyclicDependencies depsNotAvailable pkg_map3 cyclic
=====================================
compiler/GHC/Utils/Outputable.hs
=====================================
@@ -1069,7 +1069,7 @@ instance Outputable Fingerprint where
instance Outputable a => Outputable (SCC a) where
ppr (AcyclicSCC v) = text "NONREC" $$ (nest 3 (ppr v))
- ppr (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr vs)))
+ ppr (NECyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr (NEL.toList vs))))
instance Outputable Serialized where
ppr (Serialized the_type bytes) = int (length bytes) <+> text "of type" <+> text (show the_type)
=====================================
ghc/Main.hs
=====================================
@@ -898,7 +898,7 @@ checkUnitCycles dflags graph = processSCCs (HUG.hugSCCs graph)
processSCCs [] = return ()
processSCCs (AcyclicSCC _: other_sccs) = processSCCs other_sccs
- processSCCs (CyclicSCC uids: _) = throwGhcException $ CmdLineError $ showSDoc dflags (cycle_err uids)
+ processSCCs (NECyclicSCC uids: _) = throwGhcException $ CmdLineError $ showSDoc dflags (cycle_err uids)
cycle_err uids =
@@ -910,8 +910,8 @@ checkUnitCycles dflags graph = processSCCs (HUG.hugSCCs graph)
(map (\uid -> text "-" <+> ppr uid <+> text "depends on") start)
++ [text "-" <+> ppr final]
where
- start = init uids
- final = last uids
+ start = NE.init uids
+ final = NE.last uids
-- | Check that we don't have multiple units with the same UnitId.
checkDuplicateUnits :: DynFlags -> [(FilePath, DynFlags)] -> Ghc ()
=====================================
utils/haddock/haddock-api/src/Haddock/Interface.hs
=====================================
@@ -229,7 +229,7 @@ createIfaces verbosity modules flags instIfaceMap = do
| NotBoot <- isBootSummary ms = [ms]
| otherwise = []
go (AcyclicSCC _) = []
- go (CyclicSCC _) = error "haddock: module graph cyclic even with boot files"
+ go (NECyclicSCC _) = error "haddock: module graph cyclic even with boot files"
-- Visit modules in that order
sortedMods = concatMap go $ topSortModuleGraph False modGraph Nothing
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c8cf9773c9f32f8c069a89e22db06f93454bfa83
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c8cf9773c9f32f8c069a89e22db06f93454bfa83
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/20250131/d64557a9/attachment-0001.html>
More information about the ghc-commits
mailing list