[Git][ghc/ghc][master] Misc cleanup
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed Nov 16 19:50:28 UTC 2022
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
37cfe3c0 by Krzysztof Gogolewski at 2022-11-16T14:50:06-05:00
Misc cleanup
* Replace catMaybes . map f with mapMaybe f
* Use concatFS to concatenate multiple FastStrings
* Fix documentation of -exclude-module
* Cleanup getIgnoreCount in GHCi.UI
- - - - -
23 changed files:
- compiler/GHC/CmmToAsm.hs
- compiler/GHC/CmmToAsm/BlockLayout.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/JoinToTargets.hs
- compiler/GHC/Data/Graph/Color.hs
- compiler/GHC/Data/Graph/Ops.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/GenerateCgIPEStub.hs
- compiler/GHC/Llvm/Ppr.hs
- compiler/GHC/Parser.y
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Types/CostCentre.hs
- compiler/GHC/Types/Name/Occurrence.hs
- compiler/GHC/Types/RepType.hs
- compiler/GHC/Utils/Json.hs
- compiler/GHC/Utils/Lexeme.hs
- compiler/GHC/Wasm/ControlFlow/FromCmm.hs
- docs/users_guide/expected-undocumented-flags.txt
- docs/users_guide/separate_compilation.rst
- ghc/GHCi/UI.hs
- hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
Changes:
=====================================
compiler/GHC/CmmToAsm.hs
=====================================
@@ -807,7 +807,7 @@ generateJumpTables
generateJumpTables ncgImpl xs = concatMap f xs
where f p@(CmmProc _ _ _ (ListGraph xs)) = p : concatMap g xs
f p = [p]
- g (BasicBlock _ xs) = catMaybes (map (generateJumpTableForInstr ncgImpl) xs)
+ g (BasicBlock _ xs) = mapMaybe (generateJumpTableForInstr ncgImpl) xs
-- -----------------------------------------------------------------------------
-- Shortcut branches
=====================================
compiler/GHC/CmmToAsm/BlockLayout.hs
=====================================
@@ -657,7 +657,7 @@ sequenceChain _info _weights [] = []
sequenceChain _info _weights [x] = [x]
sequenceChain info weights blocks@((BasicBlock entry _):_) =
let directEdges :: [CfgEdge]
- directEdges = sortBy (flip compare) $ catMaybes . map relevantWeight $ (infoEdgeList weights)
+ directEdges = sortBy (flip compare) $ mapMaybe relevantWeight (infoEdgeList weights)
where
-- Apply modifiers to turn edge frequencies into useable weights
-- for computing code layout.
=====================================
compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs
=====================================
@@ -147,8 +147,7 @@ regSpill_top platform regSlotMap cmm
$ mapLookup blockId slotMap
moreSlotsLive = IntSet.fromList
- $ catMaybes
- $ map (lookupUFM regSlotMap)
+ $ mapMaybe (lookupUFM regSlotMap)
$ nonDetEltsUniqSet regsLive
-- See Note [Unique Determinism and code generation]
=====================================
compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs
=====================================
@@ -390,8 +390,7 @@ cleanBackward' liveSlotsOnEntry reloadedBy noReloads acc (li : instrs)
= do
let slotsReloadedByTargets
= IntSet.unions
- $ catMaybes
- $ map (flip mapLookup liveSlotsOnEntry)
+ $ mapMaybe (flip mapLookup liveSlotsOnEntry)
$ targets
let noReloads'
=====================================
compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs
=====================================
@@ -130,8 +130,8 @@ slurpSpillCostInfo platform cfg cmm
-- Increment counts for what regs were read/written from.
let (RU read written) = regUsageOfInstr platform instr
- mapM_ (incUses scale) $ catMaybes $ map takeVirtualReg $ nub read
- mapM_ (incDefs scale) $ catMaybes $ map takeVirtualReg $ nub written
+ mapM_ (incUses scale) $ mapMaybe takeVirtualReg $ nub read
+ mapM_ (incDefs scale) $ mapMaybe takeVirtualReg $ nub written
-- Compute liveness for entry to next instruction.
let liveDieRead_virt = takeVirtuals (liveDieRead live)
=====================================
compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs
=====================================
@@ -31,6 +31,8 @@ import GHC.Types.Unique
import GHC.Types.Unique.FM
import GHC.Types.Unique.Set
+import GHC.Utils.Outputable
+
-- | For a jump instruction at the end of a block, generate fixup code so its
-- vregs are in the correct regs for its destination.
--
@@ -375,6 +377,5 @@ makeMove delta vreg src dst
-- we don't handle memory to memory moves.
-- they shouldn't happen because we don't share
-- stack slots between vregs.
- panic ("makeMove " ++ show vreg ++ " (" ++ show src ++ ") ("
- ++ show dst ++ ")"
- ++ " we don't handle mem->mem moves.")
+ pprPanic "makeMove: we don't handle mem->mem moves"
+ (ppr vreg <+> parens (ppr src) <+> parens (ppr dst))
=====================================
compiler/GHC/Data/Graph/Color.hs
=====================================
@@ -328,8 +328,7 @@ selectColor colors graph u
-- See Note [Unique Determinism and code generation]
colors_conflict = mkUniqSet
- $ catMaybes
- $ map nodeColor nsConflicts
+ $ mapMaybe nodeColor nsConflicts
-- the prefs of our neighbors
colors_neighbor_prefs
=====================================
compiler/GHC/Data/Graph/Ops.hs
=====================================
@@ -633,7 +633,7 @@ checkNode graph node
$ nonDetEltsUniqSet $ nodeConflicts node
-- See Note [Unique Determinism and code generation]
- , neighbourColors <- catMaybes $ map nodeColor neighbors
+ , neighbourColors <- mapMaybe nodeColor neighbors
, elem color neighbourColors
= False
=====================================
compiler/GHC/Driver/Backpack.hs
=====================================
@@ -939,4 +939,4 @@ hsModuleToModSummary home_keys pn hsc_src modname
newUnitId :: UnitId -> Maybe FastString -> UnitId
newUnitId uid mhash = case mhash of
Nothing -> uid
- Just hash -> UnitId (unitIdFS uid `appendFS` mkFastString "+" `appendFS` hash)
+ Just hash -> UnitId (concatFS [unitIdFS uid, fsLit "+", hash])
=====================================
compiler/GHC/Driver/GenerateCgIPEStub.hs
=====================================
@@ -3,7 +3,7 @@
module GHC.Driver.GenerateCgIPEStub (generateCgIPEStub) where
import qualified Data.Map.Strict as Map
-import Data.Maybe (catMaybes, listToMaybe)
+import Data.Maybe (mapMaybe, listToMaybe)
import GHC.Cmm
import GHC.Cmm.CLabel (CLabel)
import GHC.Cmm.Dataflow (Block, C, O)
@@ -210,7 +210,7 @@ generateCgIPEStub hsc_env this_mod denv s = do
collectNothing _ cmmGroupSRTs = pure ([], cmmGroupSRTs)
collectInfoTables :: CmmGroupSRTs -> [(Label, CmmInfoTable)]
- collectInfoTables cmmGroup = concat $ catMaybes $ map extractInfoTables cmmGroup
+ collectInfoTables cmmGroup = concat $ mapMaybe extractInfoTables cmmGroup
extractInfoTables :: GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph -> Maybe [(Label, CmmInfoTable)]
extractInfoTables (CmmProc h _ _ _) = Just $ mapToList (info_tbls h)
@@ -249,8 +249,7 @@ generateCgIPEStub hsc_env this_mod denv s = do
lastTickInBlock block =
listToMaybe $
- catMaybes $
- map maybeTick $ (reverse . blockToList) block
+ mapMaybe maybeTick $ (reverse . blockToList) block
maybeTick :: CmmNode O O -> Maybe IpeSourceLocation
maybeTick (CmmTick (SourceNote span name)) = Just (span, name)
=====================================
compiler/GHC/Llvm/Ppr.hs
=====================================
@@ -517,8 +517,8 @@ ppName opts v = case v of
ppPlainName :: LlvmCgConfig -> LlvmVar -> SDoc
ppPlainName opts v = case v of
(LMGlobalVar x _ _ _ _ _) -> ftext x
- (LMLocalVar x LMLabel ) -> text (show x)
- (LMLocalVar x _ ) -> text ('l' : show x)
+ (LMLocalVar x LMLabel ) -> pprUniqueAlways x
+ (LMLocalVar x _ ) -> char 'l' <> pprUniqueAlways x
(LMNLocalVar x _ ) -> ftext x
(LMLitVar x ) -> ppLit opts x
=====================================
compiler/GHC/Parser.y
=====================================
@@ -825,7 +825,7 @@ HYPHEN :: { [AddEpAnn] }
litpkgname :: { Located FastString }
: litpkgname_segment { $1 }
-- a bit of a hack, means p - b is parsed same as p-b, enough for now.
- | litpkgname_segment HYPHEN litpkgname { sLL $1 $> $ appendFS (unLoc $1) (consFS '-' (unLoc $3)) }
+ | litpkgname_segment HYPHEN litpkgname { sLL $1 $> $ concatFS [unLoc $1, fsLit "-", (unLoc $3)] }
mayberns :: { Maybe [LRenaming] }
: {- empty -} { Nothing }
=====================================
compiler/GHC/Tc/Gen/Bind.hs
=====================================
@@ -675,7 +675,7 @@ funBindTicks loc fun_id mod sigs
= sl_fs $ unLoc cc_str
| otherwise
= getOccFS (Var.varName fun_id)
- cc_name = moduleNameFS (moduleName mod) `appendFS` consFS '.' cc_str
+ cc_name = concatFS [moduleNameFS (moduleName mod), fsLit ".", cc_str]
= do
flavour <- DeclCC <$> getCCIndexTcM cc_name
let cc = mkUserCC cc_name mod loc flavour
=====================================
compiler/GHC/Types/CostCentre.hs
=====================================
@@ -161,9 +161,9 @@ mkAutoCC id mod
-- Unique.
-- See bug #249, tests prof001, prof002, also #2411
str | isExternalName name = occNameFS (getOccName id)
- | otherwise = occNameFS (getOccName id)
- `appendFS`
- mkFastString ('_' : show (getUnique name))
+ | otherwise = concatFS [occNameFS (getOccName id),
+ fsLit "_",
+ mkFastString (show (getUnique name))]
mkAllCafsCC :: Module -> SrcSpan -> CostCentre
mkAllCafsCC m loc = AllCafsCC { cc_mod = m, cc_loc = loc }
=====================================
compiler/GHC/Types/Name/Occurrence.hs
=====================================
@@ -519,9 +519,9 @@ parenSymOcc occ doc | isSymOcc occ = parens doc
startsWithUnderscore :: OccName -> Bool
-- ^ Haskell 98 encourages compilers to suppress warnings about unused
-- names in a pattern if they start with @_@: this implements that test
-startsWithUnderscore occ = case unconsFS (occNameFS occ) of
- Just ('_', _) -> True
- _ -> False
+startsWithUnderscore occ = case unpackFS (occNameFS occ) of
+ '_':_ -> True
+ _ -> False
{-
************************************************************************
@@ -860,13 +860,13 @@ tidyOccName env occ@(OccName occ_sp fs)
base1 = mkFastString (base ++ "1")
find !k !n
- = case lookupUFM env new_fs of
- Just {} -> find (k+1 :: Int) (n+k)
+ = case elemUFM new_fs env of
+ True -> find (k+1 :: Int) (n+k)
-- By using n+k, the n argument to find goes
-- 1, add 1, add 2, add 3, etc which
-- moves at quadratic speed through a dense patch
- Nothing -> (new_env, OccName occ_sp new_fs)
+ False -> (new_env, OccName occ_sp new_fs)
where
new_fs = mkFastString (base ++ show n)
new_env = addToUFM (addToUFM env new_fs 1) base1 (n+1)
=====================================
compiler/GHC/Types/RepType.hs
=====================================
@@ -302,11 +302,10 @@ instance Outputable SlotTy where
ppr (VecSlot n e) = text "VecSlot" <+> ppr n <+> ppr e
typeSlotTy :: UnaryType -> Maybe SlotTy
-typeSlotTy ty
- | isZeroBitTy ty
- = Nothing
- | otherwise
- = Just (primRepSlot (typePrimRep1 ty))
+typeSlotTy ty = case typePrimRep ty of
+ [] -> Nothing
+ [rep] -> Just (primRepSlot rep)
+ reps -> pprPanic "typeSlotTy" (ppr ty $$ ppr reps)
primRepSlot :: PrimRep -> SlotTy
primRepSlot VoidRep = pprPanic "primRepSlot" (text "No slot for VoidRep")
=====================================
compiler/GHC/Utils/Json.hs
=====================================
@@ -24,7 +24,7 @@ renderJSON :: JsonDoc -> SDoc
renderJSON d =
case d of
JSNull -> text "null"
- JSBool b -> text $ if b then "true" else "false"
+ JSBool b -> if b then text "true" else text "false"
JSInt n -> ppr n
JSString s -> doubleQuotes $ text $ escapeJsonString s
JSArray as -> brackets $ pprList renderJSON as
=====================================
compiler/GHC/Utils/Lexeme.hs
=====================================
@@ -67,17 +67,17 @@ isLexId cs = isLexConId cs || isLexVarId cs
isLexSym cs = isLexConSym cs || isLexVarSym cs
-------------
-isLexConId cs = case unconsFS cs of -- Prefix type or data constructors
- Nothing -> False -- e.g. "Foo", "[]", "(,)"
- Just (c, _) -> cs == fsLit "[]" || startsConId c
+isLexConId cs = case unpackFS cs of -- Prefix type or data constructors
+ [] -> False -- e.g. "Foo", "[]", "(,)"
+ c:_ -> cs == fsLit "[]" || startsConId c
-isLexVarId cs = case unconsFS cs of -- Ordinary prefix identifiers
- Nothing -> False -- e.g. "x", "_x"
- Just (c, _) -> startsVarId c
+isLexVarId cs = case unpackFS cs of -- Ordinary prefix identifiers
+ [] -> False -- e.g. "x", "_x"
+ c:_ -> startsVarId c
-isLexConSym cs = case unconsFS cs of -- Infix type or data constructors
- Nothing -> False -- e.g. ":-:", ":", "->"
- Just (c, _) -> cs == fsLit "->" || startsConSym c
+isLexConSym cs = case unpackFS cs of -- Infix type or data constructors
+ [] -> False -- e.g. ":-:", ":", "->"
+ c:_ -> cs == fsLit "->" || startsConSym c
isLexVarSym fs -- Infix identifiers e.g. "+"
| fs == (fsLit "~R#") = True
=====================================
compiler/GHC/Wasm/ControlFlow/FromCmm.hs
=====================================
@@ -29,7 +29,6 @@ import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Outputable ( Outputable, text, (<+>), ppr
, pprWithCommas
- , showSDocUnsafe
)
import GHC.Wasm.ControlFlow
@@ -338,7 +337,7 @@ instance Outputable ContainingSyntax where
findLabelIn :: HasDebugCallStack => Label -> LabelMap a -> a
findLabelIn lbl = mapFindWithDefault failed lbl
where failed =
- panic $ "label " ++ showSDocUnsafe (ppr lbl) ++ " not found in control-flow graph"
+ pprPanic "label not found in control-flow graph" (ppr lbl)
infixl 4 <$~>
=====================================
docs/users_guide/expected-undocumented-flags.txt
=====================================
@@ -26,7 +26,6 @@
-dsource-stats
-dstg-stats
-dsuppress-stg-exts
--exclude-module
-fallow-incoherent-instances
-fallow-overlapping-instances
-fallow-undecidable-instances
=====================================
docs/users_guide/separate_compilation.rst
=====================================
@@ -1483,7 +1483,7 @@ generation are:
on ``.hi``, ``.a_hs`` on ``.a_hi``, and ``.b_hs`` on ``.b_hi``.
If you do not use this flag then the empty suffix is used.
-.. ghc-flag:: --exclude-module=⟨file⟩
+.. ghc-flag:: -exclude-module=⟨file⟩
:shortdesc: Regard ``⟨file⟩`` as "stable"; i.e., exclude it from having
dependencies on it.
:type: dynamic
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -3864,7 +3864,7 @@ continueCmd argLine = withSandboxOnly ":continue" $
where
contSwitch :: [String] -> Either SDoc (Maybe Int)
contSwitch [ ] = Right Nothing
- contSwitch [x] = getIgnoreCount x
+ contSwitch [x] = Just <$> getIgnoreCount x
contSwitch _ = Left $
text "After ':continue' only one ignore count is allowed"
@@ -3992,30 +3992,24 @@ ignoreCmd argLine = withSandboxOnly ":ignore" $ do
result <- ignoreSwitch (words argLine)
case result of
Left sdoc -> printForUser sdoc
- Right (loc, mbCount) -> do
+ Right (loc, count) -> do
let breakInfo = GHC.BreakInfo (breakModule loc) (breakTick loc)
- count = fromMaybe 0 mbCount
setupBreakpoint breakInfo count
-ignoreSwitch :: GhciMonad m => [String] -> m (Either SDoc (BreakLocation, Maybe Int))
+ignoreSwitch :: GhciMonad m => [String] -> m (Either SDoc (BreakLocation, Int))
ignoreSwitch [break, count] = do
sdoc_loc <- getBreakLoc break
pure $ (,) <$> sdoc_loc <*> getIgnoreCount count
ignoreSwitch _ = pure $ Left $ text "Syntax: :ignore <breaknum> <count>"
-getIgnoreCount :: String -> Either SDoc (Maybe Int)
+getIgnoreCount :: String -> Either SDoc Int
getIgnoreCount str =
- let checkJust :: Maybe Int -> Either SDoc (Maybe Int)
- checkJust mbCnt
- | (isJust mbCnt) = Right mbCnt
- | otherwise = Left $ sdocIgnore <+> text "is not numeric"
- checkPositive :: Maybe Int -> Either SDoc (Maybe Int)
- checkPositive mbCnt
- | isJust mbCnt && fromJust mbCnt >= 0 = Right mbCnt
- | otherwise = Left $ sdocIgnore <+> text "must be >= 0"
- mbCnt :: Maybe Int = readMaybe str
- sdocIgnore = (text "Ignore count") <+> quotes (text str)
- in Right mbCnt >>= checkJust >>= checkPositive
+ case readMaybe str of
+ Nothing -> Left $ sdocIgnore <+> "is not numeric"
+ Just cnt | cnt < 0 -> Left $ sdocIgnore <+> "must be >= 0"
+ | otherwise -> Right cnt
+ where
+ sdocIgnore = text "Ignore count" <+> quotes (text str)
setupBreakpoint :: GhciMonad m => GHC.BreakInfo -> Int -> m()
setupBreakpoint loc count = do
=====================================
hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
=====================================
@@ -89,7 +89,7 @@ parsePackageData pkg = do
allDeps = concat (libDeps : exeDeps)
sorted = sort [ C.unPackageName p | C.Dependency p _ _ <- allDeps ]
deps = nubOrd sorted \\ [name]
- depPkgs = catMaybes $ map findPackageByName deps
+ depPkgs = mapMaybe findPackageByName deps
return $ PackageData name version
(C.fromShortText (C.synopsis pd))
(C.fromShortText (C.description pd))
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/37cfe3c0f4fb16189bbe3bb735f758cd6e3d9157
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/37cfe3c0f4fb16189bbe3bb735f758cd6e3d9157
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/20221116/fee675c1/attachment-0001.html>
More information about the ghc-commits
mailing list