[Git][ghc/ghc][master] Avoid Data.List.group; prefer Data.List.NonEmpty.group
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed Sep 28 21:50:47 UTC 2022
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
2f050687 by Bodigrim at 2022-09-28T17:50:28-04:00
Avoid Data.List.group; prefer Data.List.NonEmpty.group
This allows to avoid further partiality, e. g., map head . group is
replaced by map NE.head . NE.group, and there are less panic calls.
- - - - -
14 changed files:
- compiler/GHC/Cmm/Switch.hs
- compiler/GHC/CmmToAsm.hs
- compiler/GHC/CmmToAsm/Reg/Liveness.hs
- compiler/GHC/CmmToLlvm/Base.hs
- compiler/GHC/Core/Opt/Stats.hs
- compiler/GHC/HsToCore/Match/Constructor.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Tc/Gen/Expr.hs
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Tags.hs
- hadrian/src/Rules/Dependencies.hs
- testsuite/tests/lib/integer/integerGmpInternals.hs
- testsuite/tests/numeric/should_run/CarryOverflow.hs
Changes:
=====================================
compiler/GHC/Cmm/Switch.hs
=====================================
@@ -20,8 +20,7 @@ import GHC.Utils.Panic
import GHC.Cmm.Dataflow.Label (Label)
import Data.Maybe
-import Data.List (groupBy)
-import Data.Function (on)
+import qualified Data.List.NonEmpty as NE
import qualified Data.Map as M
-- Note [Cmm Switches, the general plan]
@@ -204,8 +203,8 @@ switchTargetsToList (SwitchTargets _ _ mbdef branches)
switchTargetsFallThrough :: SwitchTargets -> ([([Integer], Label)], Maybe Label)
switchTargetsFallThrough (SwitchTargets _ _ mbdef branches) = (groups, mbdef)
where
- groups = map (\xs -> (map fst xs, snd (head xs))) $
- groupBy ((==) `on` snd) $
+ groups = map (\xs -> (map fst (NE.toList xs), snd (NE.head xs))) $
+ NE.groupWith snd $
M.toList branches
-- | Custom equality helper, needed for "GHC.Cmm.CommonBlockElim"
=====================================
compiler/GHC/CmmToAsm.hs
=====================================
@@ -139,7 +139,8 @@ import GHC.Unit
import GHC.Data.Stream (Stream)
import qualified GHC.Data.Stream as Stream
-import Data.List (sortBy, groupBy)
+import Data.List (sortBy)
+import qualified Data.List.NonEmpty as NE
import Data.Maybe
import Data.Ord ( comparing )
import Control.Monad
@@ -769,17 +770,14 @@ makeImportsDoc config imports
-- Generate "symbol stubs" for all external symbols that might
-- come from a dynamic library.
dyld_stubs :: [CLabel] -> SDoc
-{- dyld_stubs imps = vcat $ map pprDyldSymbolStub $
- map head $ group $ sort imps-}
-- (Hack) sometimes two Labels pretty-print the same, but have
-- different uniques; so we compare their text versions...
dyld_stubs imps
| needImportedSymbols config
= vcat $
(pprGotDeclaration config :) $
- map ( pprImportedSymbol config . fst . head) $
- groupBy (\(_,a) (_,b) -> a == b) $
- sortBy (\(_,a) (_,b) -> compare a b) $
+ fmap ( pprImportedSymbol config . fst . NE.head) $
+ NE.groupAllWith snd $
map doPpr $
imps
| otherwise
=====================================
compiler/GHC/CmmToAsm/Reg/Liveness.hs
=====================================
@@ -67,7 +67,7 @@ import GHC.Types.Unique.Supply
import GHC.Data.Bag
import GHC.Utils.Monad.State.Strict
-import Data.List (mapAccumL, groupBy, partition)
+import Data.List (mapAccumL, partition)
import Data.Maybe
import Data.IntSet (IntSet)
@@ -911,13 +911,11 @@ livenessSCCs platform blockmap done
-> a -> b
-> (a,c)
- iterateUntilUnchanged f eq a b
- = head $
- concatMap tail $
- groupBy (\(a1, _) (a2, _) -> eq a1 a2) $
- iterate (\(a, _) -> f a b) $
- (a, panic "RegLiveness.livenessSCCs")
-
+ iterateUntilUnchanged f eq aa b = go aa
+ where
+ go a = if eq a a' then ac else go a'
+ where
+ ac@(a', _) = f a b
linearLiveness
:: Instruction instr
=====================================
compiler/GHC/CmmToLlvm/Base.hs
=====================================
@@ -59,7 +59,8 @@ import GHC.Utils.Logger
import Data.Maybe (fromJust)
import Control.Monad.Trans.State (StateT (..))
-import Data.List (sortBy, groupBy, isPrefixOf)
+import Data.List (isPrefixOf)
+import qualified Data.List.NonEmpty as NE
import Data.Ord (comparing)
-- ----------------------------------------------------------------------------
@@ -192,7 +193,7 @@ padLiveArgs platform live =
-- set of real registers to be passed. E.g. FloatReg, DoubleReg and XmmReg
-- all use the same real regs on X86-64 (XMM registers).
--
- classes = groupBy sharesClass fprLive
+ classes = NE.groupBy sharesClass fprLive
sharesClass a b = regsOverlap platform (norm a) (norm b) -- check if mapped to overlapping registers
norm x = CmmGlobal ((fpr_ctor x) 1) -- get the first register of the family
@@ -202,10 +203,10 @@ padLiveArgs platform live =
-- E.g. sortedRs = [ F2, XMM4, D5]
-- output = [D1, D3]
padded = concatMap padClass classes
- padClass rs = go sortedRs [1..]
+ padClass rs = go (NE.toList sortedRs) 1
where
- sortedRs = sortBy (comparing fpr_num) rs
- maxr = last sortedRs
+ sortedRs = NE.sortBy (comparing fpr_num) rs
+ maxr = NE.last sortedRs
ctor = fpr_ctor maxr
go [] _ = []
@@ -216,10 +217,9 @@ padLiveArgs platform live =
text "Found two different Cmm registers (" <> ppr c1 <> text "," <> ppr c2 <>
text ") both alive AND mapped to the same real register: " <> ppr real <>
text ". This isn't currently supported by the LLVM backend."
- go (c:cs) (f:fs)
- | fpr_num c == f = go cs fs -- already covered by a real register
- | otherwise = ctor f : go (c:cs) fs -- add padding register
- go _ _ = undefined -- unreachable
+ go (c:cs) f
+ | fpr_num c == f = go cs f -- already covered by a real register
+ | otherwise = ctor f : go (c:cs) (f + 1) -- add padding register
fpr_ctor :: GlobalReg -> Int -> GlobalReg
fpr_ctor (FloatReg _) = FloatReg
=====================================
compiler/GHC/Core/Opt/Stats.hs
=====================================
@@ -22,12 +22,14 @@ import GHC.Utils.Outputable as Outputable
import GHC.Data.FastString
-import Data.List (groupBy, sortBy)
+import Data.List (sortOn)
+import Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.List.NonEmpty as NE
import Data.Ord
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Map.Strict as MapStrict
-import GHC.Utils.Panic (throwGhcException, GhcException(..), panic)
+import GHC.Utils.Panic (throwGhcException, GhcException(..))
getVerboseSimplStats :: (Bool -> SDoc) -> SDoc
getVerboseSimplStats = getPprDebug -- For now, anyway
@@ -205,18 +207,16 @@ pprTickCounts :: Map Tick Int -> SDoc
pprTickCounts counts
= vcat (map pprTickGroup groups)
where
- groups :: [[(Tick,Int)]] -- Each group shares a common tag
- -- toList returns common tags adjacent
- groups = groupBy same_tag (Map.toList counts)
- same_tag (tick1,_) (tick2,_) = tickToTag tick1 == tickToTag tick2
-
-pprTickGroup :: [(Tick, Int)] -> SDoc
-pprTickGroup group@((tick1,_):_)
- = hang (int (sum [n | (_,n) <- group]) <+> text (tickString tick1))
+ groups :: [NonEmpty (Tick, Int)] -- Each group shares a common tag
+ -- toList returns common tags adjacent
+ groups = NE.groupWith (tickToTag . fst) (Map.toList counts)
+
+pprTickGroup :: NonEmpty (Tick, Int) -> SDoc
+pprTickGroup group@((tick1,_) :| _)
+ = hang (int (sum (fmap snd group)) <+> text (tickString tick1))
2 (vcat [ int n <+> pprTickCts tick
-- flip as we want largest first
- | (tick,n) <- sortBy (flip (comparing snd)) group])
-pprTickGroup [] = panic "pprTickGroup"
+ | (tick,n) <- sortOn (Down . snd) (NE.toList group)])
data Tick -- See Note [Which transformations are innocuous]
= PreInlineUnconditionally Id
=====================================
compiler/GHC/HsToCore/Match/Constructor.hs
=====================================
@@ -36,8 +36,8 @@ import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import Control.Monad(liftM)
-import Data.List (groupBy)
import Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.List.NonEmpty as NE
{-
We are confronted with the first column of patterns in a set of
@@ -143,13 +143,13 @@ matchOneConLike vars ty mult (eqn1 :| eqns) -- All eqns for a single construct
-- and returns the types of the *value* args, which is what we want
match_group :: [Id]
- -> [(ConArgPats, EquationInfo)] -> DsM (MatchResult CoreExpr)
+ -> NonEmpty (ConArgPats, EquationInfo)
+ -> DsM (MatchResult CoreExpr)
-- All members of the group have compatible ConArgPats
match_group arg_vars arg_eqn_prs
- = assert (notNull arg_eqn_prs) $
- do { (wraps, eqns') <- liftM unzip (mapM shift arg_eqn_prs)
+ = do { (wraps, eqns') <- liftM NE.unzip (mapM shift arg_eqn_prs)
; let group_arg_vars = select_arg_vars arg_vars arg_eqn_prs
- ; match_result <- match (group_arg_vars ++ vars) ty eqns'
+ ; match_result <- match (group_arg_vars ++ vars) ty (NE.toList eqns')
; return $ foldr1 (.) wraps <$> match_result
}
@@ -184,9 +184,9 @@ matchOneConLike vars ty mult (eqn1 :| eqns) -- All eqns for a single construct
-- suggestions for the new variables
-- Divide into sub-groups; see Note [Record patterns]
- ; let groups :: [[(ConArgPats, EquationInfo)]]
- groups = groupBy compatible_pats [ (pat_args (firstPat eqn), eqn)
- | eqn <- eqn1:eqns ]
+ ; let groups :: NonEmpty (NonEmpty (ConArgPats, EquationInfo))
+ groups = NE.groupBy1 compatible_pats
+ $ fmap (\eqn -> (pat_args (firstPat eqn), eqn)) (eqn1 :| eqns)
; match_results <- mapM (match_group arg_vars) groups
@@ -210,8 +210,8 @@ matchOneConLike vars ty mult (eqn1 :| eqns) -- All eqns for a single construct
-- Choose the right arg_vars in the right order for this group
-- Note [Record patterns]
- select_arg_vars :: [Id] -> [(ConArgPats, EquationInfo)] -> [Id]
- select_arg_vars arg_vars ((arg_pats, _) : _)
+ select_arg_vars :: [Id] -> NonEmpty (ConArgPats, EquationInfo) -> [Id]
+ select_arg_vars arg_vars ((arg_pats, _) :| _)
| RecCon flds <- arg_pats
, let rpats = rec_flds flds
, not (null rpats) -- Treated specially; cf conArgPats
@@ -224,7 +224,6 @@ matchOneConLike vars ty mult (eqn1 :| eqns) -- All eqns for a single construct
fld_var_env = mkNameEnv $ zipEqual "get_arg_vars" fields1 arg_vars
lookup_fld (L _ rpat) = lookupNameEnv_NF fld_var_env
(idName (hsRecFieldId rpat))
- select_arg_vars _ [] = panic "matchOneCon/select_arg_vars []"
-----------------
compatible_pats :: (ConArgPats,a) -> (ConArgPats,a) -> Bool
=====================================
compiler/GHC/Rename/HsType.hs
=====================================
@@ -80,7 +80,7 @@ import qualified GHC.LanguageExtensions as LangExt
import Language.Haskell.Syntax.Basic (FieldLabelString(..))
-import Data.List (sortBy, nubBy, partition)
+import Data.List (nubBy, partition)
import qualified Data.List.NonEmpty as NE
import Data.List.NonEmpty (NonEmpty(..))
import Control.Monad
@@ -443,7 +443,7 @@ rnImplicitTvBndrs :: HsDocContext
-> ([Name] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnImplicitTvBndrs ctx mb_assoc implicit_vs_with_dups thing_inside
- = do { implicit_vs <- forM (NE.groupBy eqLocated $ sortBy cmpLocated $ implicit_vs_with_dups) $ \case
+ = do { implicit_vs <- forM (NE.groupAllWith unLoc $ implicit_vs_with_dups) $ \case
(x :| []) -> return x
(x :| _) -> do
let msg = mkTcRnUnknownMessage $ mkPlainError noHints $
=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -93,7 +93,9 @@ import Data.Either ( partitionEithers )
import Data.Map ( Map )
import qualified Data.Map as Map
import Data.Ord ( comparing )
-import Data.List ( partition, (\\), find, sortBy, groupBy, sortOn )
+import Data.List ( partition, (\\), find, sortBy )
+import Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.List.NonEmpty as NE
import Data.Function ( on )
import qualified Data.Set as S
import Data.Foldable ( toList )
@@ -1968,7 +1970,7 @@ getMinimalImports = fmap combine . mapM mk_minimal
all_non_overloaded = all (not . flIsOverloaded)
combine :: [LImportDecl GhcRn] -> [LImportDecl GhcRn]
- combine = map merge . groupBy ((==) `on` getKey) . sortOn getKey
+ combine = map merge . NE.groupAllWith getKey
getKey :: LImportDecl GhcRn -> (Bool, Maybe ModuleName, ModuleName)
getKey decl =
@@ -1980,10 +1982,9 @@ getMinimalImports = fmap combine . mapM mk_minimal
idecl :: ImportDecl GhcRn
idecl = unLoc decl
- merge :: [LImportDecl GhcRn] -> LImportDecl GhcRn
- merge [] = error "getMinimalImports: unexpected empty list"
- merge decls@((L l decl) : _) = L l (decl { ideclImportList = Just (Exactly, L (noAnnSrcSpan (locA l)) lies) })
- where lies = concatMap (unLoc . snd) $ mapMaybe (ideclImportList . unLoc) decls
+ merge :: NonEmpty (LImportDecl GhcRn) -> LImportDecl GhcRn
+ merge decls@((L l decl) :| _) = L l (decl { ideclImportList = Just (Exactly, L (noAnnSrcSpan (locA l)) lies) })
+ where lies = concatMap (unLoc . snd) $ mapMaybe (ideclImportList . unLoc) $ NE.toList decls
printMinimalImports :: HscSource -> [ImportDeclUsage] -> RnM ()
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -88,7 +88,8 @@ import GHC.Types.Unique.Set ( UniqSet, mkUniqSet, elementOfUniqSet, nonDetEltsUn
import Language.Haskell.Syntax.Basic (FieldLabelString(..))
import Data.Function
-import Data.List (partition, sortBy, groupBy, intersect)
+import Data.List (partition, sortBy, intersect)
+import qualified Data.List.NonEmpty as NE
import GHC.Data.Bag ( unitBag )
@@ -1699,7 +1700,7 @@ badFieldsUpd rbinds data_cons
in
-- Fields that don't change the membership status of the set
-- are redundant and can be dropped.
- map (fst . head) $ groupBy ((==) `on` snd) growingSets
+ map (fst . NE.head) $ NE.groupWith snd growingSets
aMember = assert (not (null members) ) fst (head members)
(members, nonMembers) = partition (or . snd) membership
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -122,8 +122,9 @@ import qualified Data.ByteString.Char8 as BS
import Data.Char
import Data.Function
import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef )
-import Data.List ( elemIndices, find, group, intercalate, intersperse,
+import Data.List ( elemIndices, find, intercalate, intersperse,
isPrefixOf, isSuffixOf, nub, partition, sort, sortBy, (\\) )
+import qualified Data.List.NonEmpty as NE
import qualified Data.Set as S
import Data.Maybe
import qualified Data.Map as M
@@ -3699,11 +3700,11 @@ completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do
return (filter (w `isPrefixOf`) opts)
where opts = "args":"prog":"prompt":"prompt-cont":"prompt-function":
"prompt-cont-function":"editor":"stop":flagList
- flagList = map head $ group $ sort allNonDeprecatedFlags
+ flagList = map NE.head $ NE.group $ sort allNonDeprecatedFlags
completeSeti = wrapCompleter flagWordBreakChars $ \w -> do
return (filter (w `isPrefixOf`) flagList)
- where flagList = map head $ group $ sort allNonDeprecatedFlags
+ where flagList = map NE.head $ NE.group $ sort allNonDeprecatedFlags
completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do
return (filter (w `isPrefixOf`) opts)
=====================================
ghc/GHCi/UI/Tags.hs
=====================================
@@ -29,7 +29,8 @@ import GHC.Driver.Env
import Control.Monad
import Data.Function
-import Data.List (sort, sortBy, groupBy)
+import Data.List (sort, sortOn)
+import qualified Data.List.NonEmpty as NE
import Data.Maybe
import Data.Ord
import GHC.Driver.Phases
@@ -176,14 +177,13 @@ collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
makeTagGroupsWithSrcInfo :: [TagInfo] -> IO [[TagInfo]]
makeTagGroupsWithSrcInfo tagInfos = do
- let groups = groupBy ((==) `on` tagFile) $ sortBy (comparing tagFile) tagInfos
+ let groups = NE.groupAllWith tagFile tagInfos
mapM addTagSrcInfo groups
where
- addTagSrcInfo [] = throwGhcException (CmdLineError "empty tag file group??")
- addTagSrcInfo group@(tagInfo:_) = do
+ addTagSrcInfo group@(tagInfo NE.:| _) = do
file <- readFile $ tagFile tagInfo
- let sortedGroup = sortBy (comparing tagLine) group
+ let sortedGroup = sortOn tagLine (NE.toList group)
return $ perFile sortedGroup 1 0 $ lines file
perFile allTags@(tag:tags) cnt pos allLs@(l:ls)
=====================================
hadrian/src/Rules/Dependencies.hs
=====================================
@@ -2,6 +2,7 @@ module Rules.Dependencies (buildPackageDependencies) where
import Data.Bifunctor
import Data.Function
+import qualified Data.List.NonEmpty as NE
import Base
import Context
@@ -67,9 +68,8 @@ buildPackageDependencies rs = do
writeFileChanged deps . unlines
. map (\(src, deps) -> unwords $ src : deps)
. map (bimap unifyPath (map unifyPath))
- . map (bimap head concat . unzip)
- . groupBy ((==) `on` fst)
- . sortBy (compare `on` fst)
+ . map (bimap NE.head concat . NE.unzip)
+ . NE.groupAllWith fst
$ parseMakefile mkDeps
=====================================
testsuite/tests/lib/integer/integerGmpInternals.hs
=====================================
@@ -2,7 +2,7 @@
module Main (main) where
-import Data.List (group)
+import qualified Data.List.NonEmpty as NE
import Data.Bits
import Data.Word
import Control.Monad
@@ -40,7 +40,7 @@ main = do
b1024 = roll (map fromIntegral (take 128 [0x80::Int .. ]))
- rle = map (\x -> (length x, head x)) . group
+ rle = map (\x -> (length x, NE.head x)) . NE.group
roll :: [Word8] -> Integer
=====================================
testsuite/tests/numeric/should_run/CarryOverflow.hs
=====================================
@@ -5,7 +5,8 @@ import GHC.Exts
import Control.Monad
import Data.Bits
-import Data.List (sort, group)
+import Data.List (sort)
+import qualified Data.List.NonEmpty as NE
import System.Exit
allEqual :: Eq a => [a] -> Bool
@@ -13,7 +14,7 @@ allEqual [] = error "allEqual: nothing to compare"
allEqual (x:xs) = all (== x) xs
testWords :: [Word]
-testWords = map head . group . sort $
+testWords = map NE.head . NE.group . sort $
concatMap (\w -> [w - 1, w, w + 1]) $
concatMap (\w -> [w, maxBound - w]) $
trailingOnes ++ randoms
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2f050687e75ffe6fbf140cacd15fd916d2997499
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2f050687e75ffe6fbf140cacd15fd916d2997499
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/20220928/de7229b2/attachment-0001.html>
More information about the ghc-commits
mailing list