summaryrefslogtreecommitdiff
path: root/compiler/GHC
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC')
-rw-r--r--compiler/GHC/CmmToAsm.hs2
-rw-r--r--compiler/GHC/CmmToAsm/BlockLayout.hs2
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs3
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs3
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs4
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs7
-rw-r--r--compiler/GHC/Data/Graph/Color.hs3
-rw-r--r--compiler/GHC/Data/Graph/Ops.hs2
-rw-r--r--compiler/GHC/Driver/Backpack.hs2
-rw-r--r--compiler/GHC/Driver/GenerateCgIPEStub.hs7
-rw-r--r--compiler/GHC/Llvm/Ppr.hs4
-rw-r--r--compiler/GHC/Parser.y2
-rw-r--r--compiler/GHC/Tc/Gen/Bind.hs2
-rw-r--r--compiler/GHC/Types/CostCentre.hs6
-rw-r--r--compiler/GHC/Types/Name/Occurrence.hs12
-rw-r--r--compiler/GHC/Types/RepType.hs9
-rw-r--r--compiler/GHC/Utils/Json.hs2
-rw-r--r--compiler/GHC/Utils/Lexeme.hs18
-rw-r--r--compiler/GHC/Wasm/ControlFlow/FromCmm.hs3
19 files changed, 44 insertions, 49 deletions
diff --git a/compiler/GHC/CmmToAsm.hs b/compiler/GHC/CmmToAsm.hs
index 5de914fcc9..d4da4dc51b 100644
--- a/compiler/GHC/CmmToAsm.hs
+++ b/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
diff --git a/compiler/GHC/CmmToAsm/BlockLayout.hs b/compiler/GHC/CmmToAsm/BlockLayout.hs
index 1a5aec2f51..56afdfb668 100644
--- a/compiler/GHC/CmmToAsm/BlockLayout.hs
+++ b/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.
diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs b/compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs
index 9f66793a03..b2965013a0 100644
--- a/compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs
+++ b/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]
diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs b/compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs
index 60757544be..cb13e62137 100644
--- a/compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs
+++ b/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'
diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs b/compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs
index 9375122567..fabe5b1d75 100644
--- a/compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs
+++ b/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)
diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs b/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs
index ab63e18bbd..f15f9ff4ba 100644
--- a/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs
+++ b/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))
diff --git a/compiler/GHC/Data/Graph/Color.hs b/compiler/GHC/Data/Graph/Color.hs
index 496f98b205..7429ad3317 100644
--- a/compiler/GHC/Data/Graph/Color.hs
+++ b/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
diff --git a/compiler/GHC/Data/Graph/Ops.hs b/compiler/GHC/Data/Graph/Ops.hs
index d2671f252d..dc90b9e5ad 100644
--- a/compiler/GHC/Data/Graph/Ops.hs
+++ b/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
diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs
index 93422e4161..cf94e0cf1d 100644
--- a/compiler/GHC/Driver/Backpack.hs
+++ b/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])
diff --git a/compiler/GHC/Driver/GenerateCgIPEStub.hs b/compiler/GHC/Driver/GenerateCgIPEStub.hs
index be478f1bdb..40927bbc6e 100644
--- a/compiler/GHC/Driver/GenerateCgIPEStub.hs
+++ b/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)
diff --git a/compiler/GHC/Llvm/Ppr.hs b/compiler/GHC/Llvm/Ppr.hs
index f48e7aa034..787b6efcf7 100644
--- a/compiler/GHC/Llvm/Ppr.hs
+++ b/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
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index beff8acf64..dda119bafd 100644
--- a/compiler/GHC/Parser.y
+++ b/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 }
diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs
index e430584931..cf2cac142b 100644
--- a/compiler/GHC/Tc/Gen/Bind.hs
+++ b/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
diff --git a/compiler/GHC/Types/CostCentre.hs b/compiler/GHC/Types/CostCentre.hs
index 75b500694e..e20a4977ec 100644
--- a/compiler/GHC/Types/CostCentre.hs
+++ b/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 }
diff --git a/compiler/GHC/Types/Name/Occurrence.hs b/compiler/GHC/Types/Name/Occurrence.hs
index 51045066d6..bfc3b8aa95 100644
--- a/compiler/GHC/Types/Name/Occurrence.hs
+++ b/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)
diff --git a/compiler/GHC/Types/RepType.hs b/compiler/GHC/Types/RepType.hs
index d7f0f75219..9c394771cf 100644
--- a/compiler/GHC/Types/RepType.hs
+++ b/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")
diff --git a/compiler/GHC/Utils/Json.hs b/compiler/GHC/Utils/Json.hs
index acccc88658..47f599c950 100644
--- a/compiler/GHC/Utils/Json.hs
+++ b/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
diff --git a/compiler/GHC/Utils/Lexeme.hs b/compiler/GHC/Utils/Lexeme.hs
index f71bf1674a..ef7a076faf 100644
--- a/compiler/GHC/Utils/Lexeme.hs
+++ b/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
diff --git a/compiler/GHC/Wasm/ControlFlow/FromCmm.hs b/compiler/GHC/Wasm/ControlFlow/FromCmm.hs
index e003fff96a..8235b59ed6 100644
--- a/compiler/GHC/Wasm/ControlFlow/FromCmm.hs
+++ b/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 <$~>
View Lorry Controller Status