[Git][ghc/ghc][master] 3 commits: Refactor uses of `partitionEithers . map`
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed Sep 27 05:18:57 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
d697a6c2 by Stefan Holdermans at 2023-09-26T20:58:37+00:00
Refactor uses of `partitionEithers . map`
This patch changes occurences of the idiom
`partitionEithers (map f xs)` by the simpler form
`partitionWith f xs` where `partitionWith` is the utility function
defined in `GHC.Utils.Misc`.
Resolves: #23953
- - - - -
8a2968b7 by Stefan Holdermans at 2023-09-26T20:58:37+00:00
Refactor uses of `partitionEithers <$> mapM f xs`
This patch changes occurences of the idiom
`partitionEithers <$> mapM f xs` by the simpler form
`partitionWithM f xs` where `partitionWithM` is a utility function
newly added to `GHC.Utils.Misc`.
- - - - -
6a27eb97 by Stefan Holdermans at 2023-09-26T20:58:37+00:00
Mark `GHC.Utils.Misc.partitionWithM` as inlineable
This patch adds an `INLINEABLE` pragma for `partitionWithM` to ensure
that the right-hand side of the definition of this function remains
available for specialisation at call sites.
- - - - -
12 changed files:
- compiler/GHC/Cmm/DebugBlock.hs
- compiler/GHC/Cmm/Pipeline.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/HsToCore/Pmc/Solver.hs
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/StgToJS/Deps.hs
- compiler/GHC/StgToJS/Expr.hs
- compiler/GHC/StgToJS/Sinker.hs
- compiler/GHC/Unit/Module/Graph.hs
- compiler/GHC/Utils/Misc.hs
Changes:
=====================================
compiler/GHC/Cmm/DebugBlock.hs
=====================================
@@ -47,7 +47,7 @@ import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Types.SrcLoc
import GHC.Types.Tickish
-import GHC.Utils.Misc ( seqList )
+import GHC.Utils.Misc ( partitionWith, seqList )
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Collections
@@ -58,7 +58,6 @@ import Data.Maybe
import Data.List ( minimumBy, nubBy )
import Data.Ord ( comparing )
import qualified Data.Map as Map
-import Data.Either ( partitionEithers )
-- | Debug information about a block of code. Ticks scope over nested
-- blocks.
@@ -110,7 +109,7 @@ cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes
-- Analyse tick scope structure: Each one is either a top-level
-- tick scope, or the child of another.
(topScopes, childScopes)
- = partitionEithers $ map (\a -> findP a a) $ Map.keys blockCtxs
+ = partitionWith (\a -> findP a a) $ Map.keys blockCtxs
findP tsc GlobalScope = Left tsc -- top scope
findP tsc scp | scp' `Map.member` blockCtxs = Right (scp', tsc)
| otherwise = findP tsc scp'
=====================================
compiler/GHC/Cmm/Pipeline.hs
=====================================
@@ -26,11 +26,11 @@ import GHC.Types.Unique.Supply
import GHC.Utils.Error
import GHC.Utils.Logger
import GHC.Utils.Outputable
+import GHC.Utils.Misc ( partitionWithM )
import GHC.Platform
import Control.Monad
-import Data.Either (partitionEithers)
-----------------------------------------------------------------------------
-- | Top level driver for C-- pipeline
@@ -50,9 +50,7 @@ cmmPipeline logger cmm_config srtInfo prog = do
let forceRes (info, group) = info `seq` foldr seq () group
let platform = cmmPlatform cmm_config
withTimingSilent logger (text "Cmm pipeline") forceRes $ do
- tops <- {-# SCC "tops" #-} mapM (cpsTop logger platform cmm_config) prog
-
- let (procs, data_) = partitionEithers tops
+ (procs, data_) <- {-# SCC "tops" #-} partitionWithM (cpsTop logger platform cmm_config) prog
(srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs cmm_config srtInfo procs data_
dumpWith logger Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (pdoc platform cmms)
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -1569,9 +1569,8 @@ downsweep :: HscEnv
-- which case there can be repeats
downsweep hsc_env old_summaries excl_mods allow_dup_roots
= do
- rootSummaries <- mapM getRootSummary roots
- let (root_errs, rootSummariesOk) = partitionEithers rootSummaries -- #17549
- root_map = mkRootMap rootSummariesOk
+ (root_errs, rootSummariesOk) <- partitionWithM getRootSummary roots -- #17549
+ let root_map = mkRootMap rootSummariesOk
checkDuplicates root_map
(deps, pkg_deps, map0) <- loopSummaries rootSummariesOk (M.empty, Set.empty, root_map)
let closure_errs = checkHomeUnitsClosed (hsc_unit_env hsc_env) (hsc_all_home_unit_ids hsc_env) (Set.toList pkg_deps)
=====================================
compiler/GHC/Driver/Pipeline.hs
=====================================
@@ -124,7 +124,6 @@ import System.IO
import Control.Monad
import qualified Control.Monad.Catch as MC (handle)
import Data.Maybe
-import Data.Either ( partitionEithers )
import qualified Data.Set as Set
import Data.Time ( getCurrentTime )
@@ -489,8 +488,7 @@ linkingNeeded logger dflags unit_env staticLink linkables pkg_deps = do
Right t -> do
-- first check object files and extra_ld_inputs
let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ]
- e_extra_times <- mapM (tryIO . getModificationUTCTime) extra_ld_inputs
- let (errs,extra_times) = partitionEithers e_extra_times
+ (errs,extra_times) <- partitionWithM (tryIO . getModificationUTCTime) extra_ld_inputs
let obj_times = map linkableTime linkables ++ extra_times
if not (null errs) || any (t <) obj_times
then return $ needsRecompileBecause ObjectsChanged
@@ -514,9 +512,7 @@ linkingNeeded logger dflags unit_env staticLink linkables pkg_deps = do
pkg_libfiles <- mapM (uncurry (findHSLib platform (ways dflags))) pkg_hslibs
if any isNothing pkg_libfiles then return $ needsRecompileBecause LibraryChanged else do
- e_lib_times <- mapM (tryIO . getModificationUTCTime)
- (catMaybes pkg_libfiles)
- let (lib_errs,lib_times) = partitionEithers e_lib_times
+ (lib_errs,lib_times) <- partitionWithM (tryIO . getModificationUTCTime) (catMaybes pkg_libfiles)
if not (null lib_errs) || any (t <) lib_times
then return $ needsRecompileBecause LibraryChanged
else do
=====================================
compiler/GHC/HsToCore/Pmc/Solver.hs
=====================================
@@ -91,7 +91,6 @@ import Control.Monad (foldM, forM, guard, mzero, when, filterM)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State.Strict
import Data.Coerce
-import Data.Either (partitionEithers)
import Data.Foldable (foldlM, minimumBy, toList)
import Data.Monoid (Any(..))
import Data.List (sortBy, find)
@@ -608,7 +607,7 @@ addPhiCts nabla cts = runMaybeT $ do
inhabitationTest initFuel (nabla_ty_st nabla) nabla''
partitionPhiCts :: PhiCts -> ([PredType], [PhiCt])
-partitionPhiCts = partitionEithers . map to_either . toList
+partitionPhiCts = partitionWith to_either . toList
where
to_either (PhiTyCt pred_ty) = Left pred_ty
to_either ct = Right ct
=====================================
compiler/GHC/Linker/Deps.hs
=====================================
@@ -55,7 +55,6 @@ import Control.Applicative
import qualified Data.Set as Set
import qualified Data.Map as M
import Data.List (isSuffixOf)
-import Data.Either
import System.FilePath
import System.Directory
@@ -131,7 +130,7 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
let
-- 2. Exclude ones already linked
-- Main reason: avoid findModule calls in get_linkable
- (mods_needed, links_got) = partitionEithers (map split_mods mods_s)
+ (mods_needed, links_got) = partitionWith split_mods mods_s
pkgs_needed = eltsUDFM $ getUniqDSet pkgs_s `minusUDFM` pkgs_loaded pls
split_mods mod =
=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -130,7 +130,6 @@ import Control.Monad
import Control.Monad.Catch as MC
import Data.Array
import Data.Dynamic
-import Data.Either
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.List (find,intercalate)
@@ -808,7 +807,7 @@ findGlobalRdrEnv :: HscEnv -> [InteractiveImport]
findGlobalRdrEnv hsc_env imports
= do { idecls_env <- hscRnImportDecls hsc_env idecls
-- This call also loads any orphan modules
- ; return $ case partitionEithers (map mkEnv imods) of
+ ; return $ case partitionWith mkEnv imods of
(err : _, _) -> Left err
([], imods_env0) ->
-- Need to rehydrate the 'GlobalRdrEnv' to recover the 'GREInfo's.
=====================================
compiler/GHC/StgToJS/Deps.hs
=====================================
@@ -48,7 +48,6 @@ import qualified Data.IntSet as IS
import qualified GHC.Data.Word64Map as WM
import GHC.Data.Word64Map (Word64Map)
import Data.Array
-import Data.Either
import Data.Word
import Control.Monad
@@ -101,9 +100,9 @@ genDependencyData mod units = do
-> Int
-> StateT DependencyDataCache G (Int, BlockDeps, Bool, [ExportedFun])
oneDep (LinkableUnit _ idExports otherExports idDeps pseudoIdDeps otherDeps req _frefs) n = do
- (edi, bdi) <- partitionEithers <$> mapM (lookupIdFun n) idDeps
- (edo, bdo) <- partitionEithers <$> mapM lookupOtherFun otherDeps
- (edp, bdp) <- partitionEithers <$> mapM (lookupPseudoIdFun n) pseudoIdDeps
+ (edi, bdi) <- partitionWithM (lookupIdFun n) idDeps
+ (edo, bdo) <- partitionWithM lookupOtherFun otherDeps
+ (edp, bdp) <- partitionWithM (lookupPseudoIdFun n) pseudoIdDeps
expi <- mapM lookupExportedId (filter isExportedId idExports)
expo <- mapM lookupExportedOther otherExports
-- fixme thin deps, remove all transitive dependencies!
=====================================
compiler/GHC/StgToJS/Expr.hs
=====================================
@@ -80,7 +80,6 @@ import qualified GHC.Data.List.SetOps as ListSetOps
import Data.Monoid
import Data.Maybe
import Data.Function
-import Data.Either
import qualified Data.List as L
import qualified Data.Set as S
import qualified Data.Map as M
@@ -496,9 +495,10 @@ optimizeFree offset ids = do
l = length ids'
slots <- drop offset . take l . (++repeat SlotUnknown) <$> getSlots
let slm = M.fromList (zip slots [0..])
- (remaining, fixed) = partitionEithers $
- map (\inp@(i,n) -> maybe (Left inp) (\j -> Right (i,n,j,True))
- (M.lookup (SlotId i n) slm)) ids'
+ (remaining, fixed) = partitionWith (\inp@(i,n) -> maybe (Left inp)
+ (\j -> Right (i,n,j,True))
+ (M.lookup (SlotId i n) slm))
+ ids'
takenSlots = S.fromList (fmap (\(_,_,x,_) -> x) fixed)
freeSlots = filter (`S.notMember` takenSlots) [0..l-1]
remaining' = zipWith (\(i,n) j -> (i,n,j,False)) remaining freeSlots
@@ -508,7 +508,7 @@ optimizeFree offset ids = do
-- | Allocate local closures
allocCls :: Maybe JStat -> [(Id, CgStgRhs)] -> G JStat
allocCls dynMiddle xs = do
- (stat, dyn) <- partitionEithers <$> mapM toCl xs
+ (stat, dyn) <- partitionWithM toCl xs
ac <- allocDynAll False dynMiddle dyn
pure (mconcat stat <> ac)
where
=====================================
compiler/GHC/StgToJS/Sinker.hs
=====================================
@@ -15,10 +15,10 @@ import GHC.Unit.Module
import GHC.Types.Literal
import GHC.Data.Graph.Directed
+import GHC.Utils.Misc (partitionWith)
import GHC.StgToJS.Utils
import Data.Char
-import Data.Either
import Data.List (partition)
import Data.Maybe
@@ -38,7 +38,7 @@ sinkPgm m pgm = (sunk, map StgTopLifted pgm'' ++ stringLits)
where
selectLifted (StgTopLifted b) = Left b
selectLifted x = Right x
- (pgm', stringLits) = partitionEithers (map selectLifted pgm)
+ (pgm', stringLits) = partitionWith selectLifted pgm
(sunk, pgm'') = sinkPgm' m pgm'
sinkPgm'
=====================================
compiler/GHC/Unit/Module/Graph.hs
=====================================
@@ -58,6 +58,7 @@ import GHC.Types.SourceFile ( hscSourceString )
import GHC.Unit.Module.ModSummary
import GHC.Unit.Types
import GHC.Utils.Outputable
+import GHC.Utils.Misc ( partitionWith )
import System.FilePath
import qualified Data.Map as Map
@@ -68,7 +69,6 @@ import GHC.Unit.Module
import GHC.Linker.Static.Utils
import Data.Bifunctor
-import Data.Either
import Data.Function
import Data.List (sort)
import GHC.Data.List.SetOps
@@ -336,7 +336,7 @@ moduleGraphNodes drop_hs_boot_nodes summaries =
(graphFromEdgedVerticesUniq nodes, lookup_node)
where
-- Map from module to extra boot summary dependencies which need to be merged in
- (boot_summaries, nodes) = bimap Map.fromList id $ partitionEithers (map go numbered_summaries)
+ (boot_summaries, nodes) = bimap Map.fromList id $ partitionWith go numbered_summaries
where
go (s, key) =
=====================================
compiler/GHC/Utils/Misc.hs
=====================================
@@ -23,7 +23,7 @@ module GHC.Utils.Misc (
mapFst, mapSnd, chkAppend,
mapAndUnzip, mapAndUnzip3, mapAndUnzip4,
- filterOut, partitionWith,
+ filterOut, partitionWith, partitionWithM,
dropWhileEndLE, spanEnd, last2, lastMaybe, onJust,
@@ -219,6 +219,17 @@ partitionWith f (x:xs) = case f x of
Right c -> (bs, c:cs)
where (bs,cs) = partitionWith f xs
+partitionWithM :: Monad m => (a -> m (Either b c)) -> [a] -> m ([b], [c])
+-- ^ Monadic version of `partitionWith`
+partitionWithM _ [] = return ([], [])
+partitionWithM f (x:xs) = do
+ y <- f x
+ (bs, cs) <- partitionWithM f xs
+ case y of
+ Left b -> return (b:bs, cs)
+ Right c -> return (bs, c:cs)
+{-# INLINEABLE partitionWithM #-}
+
chkAppend :: [a] -> [a] -> [a]
-- Checks for the second argument being empty
-- Used in situations where that situation is common
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6a896ce88ec2a8840e28141a8e40334438058869...6a27eb97c7005ff0cb96d7b12eb495804556c862
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6a896ce88ec2a8840e28141a8e40334438058869...6a27eb97c7005ff0cb96d7b12eb495804556c862
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/20230927/f2b329d4/attachment-0001.html>
More information about the ghc-commits
mailing list