diff --git a/compiler/GHC/Cmm/MachOp.hs b/compiler/GHC/Cmm/MachOp.hs
index fb6e5a8664738888855e98732c52eca07f682dc6..90aa4715ee6195de86539d3d320e9f6e5a657342 100644
--- a/compiler/GHC/Cmm/MachOp.hs
+++ b/compiler/GHC/Cmm/MachOp.hs
@@ -1,7 +1,5 @@
{-# LANGUAGE LambdaCase #-}
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
module GHC.Cmm.MachOp
( MachOp(..)
, pprMachOp, isCommutableMachOp, isAssociativeMachOp
@@ -39,6 +37,9 @@ import GHC.Prelude
import GHC.Platform
import GHC.Cmm.Type
import GHC.Utils.Outputable
+import GHC.Utils.Misc (expectNonEmpty)
+
+import Data.List.NonEmpty (NonEmpty (..))
-----------------------------------------------------------------------------
-- MachOp
@@ -542,7 +543,7 @@ machOpResultType platform mop tys =
MO_RelaxedRead w -> cmmBits w
MO_AlignmentCheck _ _ -> ty1
where
- (ty1:_) = tys
+ ty1:|_ = expectNonEmpty "machOpResultType" tys
comparisonResultRep :: Platform -> CmmType
comparisonResultRep = bWord -- is it?
diff --git a/compiler/GHC/Cmm/Utils.hs b/compiler/GHC/Cmm/Utils.hs
index b2e3d29a31f09e0e633aba462329ff953098dddb..5895af7576b45f60a390acb7009d31976cdac96d 100644
--- a/compiler/GHC/Cmm/Utils.hs
+++ b/compiler/GHC/Cmm/Utils.hs
@@ -1,8 +1,6 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
-----------------------------------------------------------------------------
--
-- Cmm utilities.
@@ -83,6 +81,7 @@ import GHC.Platform.Regs
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
+import Data.Foldable (toList)
import GHC.Cmm.Dataflow.Graph
import GHC.Cmm.Dataflow.Label
import GHC.Cmm.Dataflow.Block
@@ -520,14 +519,12 @@ ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyM
-- | like 'toBlockList', but the entry block always comes first
toBlockListEntryFirst :: CmmGraph -> [CmmBlock]
-toBlockListEntryFirst g
- | mapNull m = []
- | otherwise = entry_block : others
+toBlockListEntryFirst g = do
+ entry_block <- toList $ mapLookup entry_id m
+ entry_block : filter ((/= entry_id) . entryLabel) (mapElems m)
where
m = toBlockMap g
entry_id = g_entry g
- Just entry_block = mapLookup entry_id m
- others = filter ((/= entry_id) . entryLabel) (mapElems m)
-- | Like 'toBlockListEntryFirst', but we strive to ensure that we order blocks
-- so that the false case of a conditional jumps to the next block in the output
@@ -538,13 +535,10 @@ toBlockListEntryFirst g
-- of successors returned for CmmCondBranch by the NonLocal instance for CmmNode
-- defined in "GHC.Cmm.Node". -GBM
toBlockListEntryFirstFalseFallthrough :: CmmGraph -> [CmmBlock]
-toBlockListEntryFirstFalseFallthrough g
- | mapNull m = []
- | otherwise = dfs setEmpty [entry_block]
+toBlockListEntryFirstFalseFallthrough g = dfs setEmpty $ toList $ mapLookup entry_id m
where
m = toBlockMap g
entry_id = g_entry g
- Just entry_block = mapLookup entry_id m
dfs :: LabelSet -> [CmmBlock] -> [CmmBlock]
dfs _ [] = []
diff --git a/compiler/GHC/CmmToAsm/CFG.hs b/compiler/GHC/CmmToAsm/CFG.hs
index 086ad699c510064538c25ffeb8385dc0adffa9a6..fafed0b62b46f6d4b0733d1b6e55048e01806fba 100644
--- a/compiler/GHC/CmmToAsm/CFG.hs
+++ b/compiler/GHC/CmmToAsm/CFG.hs
@@ -600,7 +600,7 @@ addNodesBetween weights m updates =
-}
-- | Generate weights for a Cmm proc based on some simple heuristics.
-getCfgProc :: Platform -> Weights -> RawCmmDecl -> CFG
+getCfgProc :: Platform -> Weights -> GenCmmDecl d h CmmGraph -> CFG
getCfgProc _ _ (CmmData {}) = mapEmpty
getCfgProc platform weights (CmmProc _info _lab _live graph) = getCfg platform weights graph
diff --git a/compiler/GHC/CmmToAsm/PPC/Instr.hs b/compiler/GHC/CmmToAsm/PPC/Instr.hs
index a93c77f87cf082d90ccf83e408df7cc2650d87b4..830224b78087a4a4c9c748e4da2741147c7be566 100644
--- a/compiler/GHC/CmmToAsm/PPC/Instr.hs
+++ b/compiler/GHC/CmmToAsm/PPC/Instr.hs
@@ -1,5 +1,3 @@
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
-----------------------------------------------------------------------------
--
-- Machine-dependent assembly language
@@ -60,7 +58,7 @@ import GHC.Types.Unique.DSM
import Data.Foldable (toList)
import qualified Data.List.NonEmpty as NE
import GHC.Data.FastString (FastString)
-import Data.Maybe (fromMaybe)
+import GHC.Data.Maybe (expectJust, fromMaybe)
--------------------------------------------------------------------------------
@@ -721,7 +719,7 @@ makeFarBranches _platform info_env blocks
= BCCFAR cond tgt p
| otherwise
= BCC cond tgt p
- where Just targetAddr = lookupUFM blockAddressMap tgt
+ where targetAddr = expectJust "makeFarBranches" $ lookupUFM blockAddressMap tgt
makeFar _ other = other
-- 8192 instructions are allowed; let's keep some distance, as
diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs b/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs
index 261d5523234cc508e3587fd06e12c2112b299b73..acb647969aceb968c7bb62fe9747d2f70755b497 100644
--- a/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs
+++ b/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs
@@ -1,6 +1,3 @@
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
-- | Carries interesting info for debugging / profiling of the
-- graph coloring register allocator.
module GHC.CmmToAsm.Reg.Graph.Stats (
@@ -287,18 +284,19 @@ pprStatsLifeConflict stats graph
$ foldl' plusSpillCostInfo zeroSpillCostInfo
$ [ sc | RegAllocStatsStart{ raSpillCosts = sc } <- stats ]
- scatter = map (\r -> let lifetime = case lookupUFM lifeMap r of
- Just (_, l) -> l
- Nothing -> 0
- Just node = Color.lookupNode graph r
- in parens $ hcat $ punctuate (text ", ")
- [ doubleQuotes $ ppr $ Color.nodeId node
- , ppr $ sizeUniqSet (Color.nodeConflicts node)
- , ppr $ lifetime ])
- $ map Color.nodeId
- $ nonDetEltsUFM
+ scatter =
+ [ let lifetime = case lookupUFM lifeMap r of
+ Just (_, l) -> l
+ Nothing -> 0
+ in parens $ hcat $ punctuate (text ", ")
+ [ doubleQuotes $ ppr $ Color.nodeId node
+ , ppr $ sizeUniqSet (Color.nodeConflicts node)
+ , ppr $ lifetime ]
+ | node <- nonDetEltsUFM
-- See Note [Unique Determinism and code generation]
$ Color.graphMap graph
+ , let r = Color.nodeId node
+ ]
in ( text "-- vreg-conflict-lifetime"
$$ text "-- (vreg, vreg_conflicts, vreg_lifetime)"
diff --git a/compiler/GHC/CmmToAsm/Reg/Linear.hs b/compiler/GHC/CmmToAsm/Reg/Linear.hs
index 3ec351260eaab0a12e15d4ad2d4ea1998b799713..e5664ed7af250b3ea8867c257fb8b6ef8ba35b9f 100644
--- a/compiler/GHC/CmmToAsm/Reg/Linear.hs
+++ b/compiler/GHC/CmmToAsm/Reg/Linear.hs
@@ -1,6 +1,4 @@
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
-----------------------------------------------------------------------------
--
-- The register allocator
@@ -141,7 +139,7 @@ import GHC.Platform
import Data.Containers.ListUtils
import Data.Maybe
-import Data.List (partition)
+import Data.List (sortOn)
import Control.Monad
-- -----------------------------------------------------------------------------
@@ -178,8 +176,7 @@ regAlloc config (CmmProc static lbl live sccs)
-- make sure the block that was first in the input list
-- stays at the front of the output
- let !(!(!first':_), !rest')
- = partition ((== first_id) . blockId) final_blocks
+ let !final_blocks' = sortOn ((/= first_id) . blockId) final_blocks
let max_spill_slots = maxSpillSlots config
extra_stack
@@ -188,7 +185,7 @@ regAlloc config (CmmProc static lbl live sccs)
| otherwise
= Nothing
- return ( CmmProc info lbl live (ListGraph (first' : rest'))
+ return ( CmmProc info lbl live (ListGraph final_blocks')
, extra_stack
, Just stats)
diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs b/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs
index 8692727a55d164e6bc10daacb90c8222e0cb4789..bd7980ca0ccf83f1c5f64f821ba6ba414e71e49d 100644
--- a/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs
+++ b/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs
@@ -1,5 +1,3 @@
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
-- | Handles joining of a jump instruction to its targets.
-- The first time we encounter a jump to a particular basic block, we
@@ -25,6 +23,7 @@ import GHC.Platform.Reg
import GHC.Cmm.BlockId
import GHC.Cmm.Dataflow.Label
import GHC.Data.Graph.Directed
+import GHC.Data.Maybe
import GHC.Utils.Panic
import GHC.Utils.Monad (concatMapM)
import GHC.Types.Unique
@@ -90,7 +89,7 @@ joinToTargets' block_live new_blocks block_id instr (dest:dests)
-- adjust the current assignment to remove any vregs that are not live
-- on entry to the destination block.
- let Just live_set = mapLookup dest block_live
+ let live_set = expectJust "joinToTargets'" $ mapLookup dest block_live
let still_live uniq _ = uniq `elemUniqSet_Directly` live_set
let adjusted_assig = filterUFM_Directly still_live assig
diff --git a/compiler/GHC/CmmToAsm/Reg/Liveness.hs b/compiler/GHC/CmmToAsm/Reg/Liveness.hs
index 138226650091403effabb0abddaa40a6aaa9696c..4642c417ee070b789f2cbd353285563f9d1b795a 100644
--- a/compiler/GHC/CmmToAsm/Reg/Liveness.hs
+++ b/compiler/GHC/CmmToAsm/Reg/Liveness.hs
@@ -1,8 +1,5 @@
{-# LANGUAGE TypeFamilies #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
-----------------------------------------------------------------------------
--
-- The register liveness determinator
@@ -62,7 +59,7 @@ import GHC.Types.Unique.DSM
import GHC.Data.Bag
import GHC.Utils.Monad.State.Strict
-import Data.List (mapAccumL, partition)
+import Data.List (mapAccumL, sortOn)
import Data.Maybe
import Data.IntSet (IntSet)
import GHC.Utils.Misc
@@ -530,11 +527,10 @@ stripLive config live
-- make sure the block that was first in the input list
-- stays at the front of the output. This is the entry point
-- of the proc, and it needs to come first.
- ((first':_), rest')
- = partition ((== first_id) . blockId) final_blocks
+ final_blocks' = sortOn ((/= first_id) . blockId) final_blocks
- in CmmProc info label live
- (ListGraph $ map (stripLiveBlock config) $ first' : rest')
+ in CmmProc info label live $ ListGraph $
+ map (stripLiveBlock config) final_blocks'
-- If the proc has blocks but we don't know what the first one was, then we're dead.
stripCmm proc
diff --git a/compiler/GHC/CmmToLlvm/CodeGen.hs b/compiler/GHC/CmmToLlvm/CodeGen.hs
index 5f1b784d0be82e21c94743fe0d09721de8aa81c5..515569f06df0acc621277ef1705aed0481407ea5 100644
--- a/compiler/GHC/CmmToLlvm/CodeGen.hs
+++ b/compiler/GHC/CmmToLlvm/CodeGen.hs
@@ -1,7 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs, MultiWayIf #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-- | Handle conversion of CmmProc to LLVM code.
module GHC.CmmToLlvm.CodeGen ( genLlvmProc ) where
@@ -27,6 +26,7 @@ import GHC.Cmm.Dataflow.Graph
import GHC.Cmm.Dataflow.Label
import GHC.Data.FastString
+import GHC.Data.Maybe (expectJust)
import GHC.Data.OrdList
import GHC.Types.ForeignCall
@@ -43,7 +43,10 @@ import Control.Monad.Trans.Writer
import Control.Monad
import qualified Data.Semigroup as Semigroup
+import Data.Foldable ( toList )
import Data.List ( nub )
+import qualified Data.List as List
+import Data.List.NonEmpty ( NonEmpty (..), nonEmpty )
import Data.Maybe ( catMaybes, isJust )
type Atomic = Maybe MemoryOrdering
@@ -55,9 +58,8 @@ data Signage = Signed | Unsigned deriving (Eq, Show)
-- | Top-level of the LLVM proc Code generator
--
genLlvmProc :: RawCmmDecl -> LlvmM [LlvmCmmDecl]
-genLlvmProc (CmmProc infos lbl live graph) = do
- let blocks = toBlockListEntryFirstFalseFallthrough graph
-
+genLlvmProc (CmmProc infos lbl live graph)
+ | Just blocks <- nonEmpty $ toBlockListEntryFirstFalseFallthrough graph = do
(lmblocks, lmdata) <- basicBlocksCodeGen live blocks
let info = mapLookup (g_entry graph) infos
proc = CmmProc info lbl live (ListGraph lmblocks)
@@ -77,9 +79,8 @@ newtype UnreachableBlockId = UnreachableBlockId BlockId
-- | Generate code for a list of blocks that make up a complete
-- procedure. The first block in the list is expected to be the entry
-- point.
-basicBlocksCodeGen :: LiveGlobalRegUses -> [CmmBlock]
+basicBlocksCodeGen :: LiveGlobalRegUses -> NonEmpty CmmBlock
-> LlvmM ([LlvmBasicBlock], [LlvmCmmDecl])
-basicBlocksCodeGen _ [] = panic "no entry block!"
basicBlocksCodeGen live cmmBlocks
= do -- Emit the prologue
-- N.B. this must be its own block to ensure that the entry block of the
@@ -97,7 +98,7 @@ basicBlocksCodeGen live cmmBlocks
let ubblock = BasicBlock ubid' [Unreachable]
-- Generate code
- (blocks, topss) <- fmap unzip $ mapM (basicBlockCodeGen ubid) cmmBlocks
+ (blocks, topss) <- fmap unzip $ mapM (basicBlockCodeGen ubid) $ toList cmmBlocks
-- Compose
return (entryBlock : ubblock : blocks, prologueTops ++ concat topss)
@@ -2194,7 +2195,7 @@ convertMemoryOrdering MemOrderSeqCst = SyncSeqCst
-- question is never written. Therefore we skip it where we can to
-- save a few lines in the output and hopefully speed compilation up a
-- bit.
-funPrologue :: LiveGlobalRegUses -> [CmmBlock] -> LlvmM StmtData
+funPrologue :: LiveGlobalRegUses -> NonEmpty CmmBlock -> LlvmM StmtData
funPrologue live cmmBlocks = do
platform <- getPlatform
@@ -2226,7 +2227,7 @@ funPrologue live cmmBlocks = do
return (concatOL stmtss `snocOL` jumpToEntry, [])
where
- entryBlk : _ = cmmBlocks
+ entryBlk :| _ = cmmBlocks
jumpToEntry = Branch $ blockIdToLlvm (entryLabel entryBlk)
-- | Function epilogue. Load STG variables to use as argument for call.
@@ -2339,9 +2340,8 @@ pprPanic s d = Panic.pprPanic ("GHC.CmmToLlvm.CodeGen." ++ s) d
-- | Returns TBAA meta data by unique
getTBAAMeta :: Unique -> LlvmM [MetaAnnot]
-getTBAAMeta u = do
- mi <- getUniqMeta u
- return [MetaAnnot tbaa (MetaNode i) | let Just i = mi]
+getTBAAMeta u =
+ List.singleton . MetaAnnot tbaa . MetaNode . expectJust "getTBAAMeta" <$> getUniqMeta u
-- | Returns TBAA meta data for given register
getTBAARegMeta :: GlobalReg -> LlvmM [MetaAnnot]
diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs
index 05f13db2888350cb9357248d286f8df70a029e90..080fae818fe594f74aff6ea1eefe4089bc3998e2 100644
--- a/compiler/GHC/Core/Make.hs
+++ b/compiler/GHC/Core/Make.hs
@@ -1,5 +1,3 @@
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
-- | Handy functions for creating much Core syntax
module GHC.Core.Make (
-- * Constructing normal syntax
@@ -83,8 +81,10 @@ import GHC.Utils.Panic
import GHC.Settings.Constants( mAX_TUPLE_SIZE )
import GHC.Data.FastString
+import GHC.Data.Maybe ( expectJust )
import Data.List ( partition )
+import Data.List.NonEmpty ( NonEmpty (..) )
import Data.Char ( ord )
infixl 4 `mkCoreApp`, `mkCoreApps`
@@ -236,7 +236,7 @@ mkLitRubbish ty
| otherwise
= Just (Lit (LitRubbish torc rep) `mkTyApps` [ty])
where
- Just (torc, rep) = sORTKind_maybe (typeKind ty)
+ (torc, rep) = expectJust "mkLitRubbish" $ sORTKind_maybe (typeKind ty)
{-
************************************************************************
@@ -616,8 +616,13 @@ mkBigTupleSelector vars the_var scrut_var scrut
where
tpl_tys = [mkBoxedTupleTy (map idType gp) | gp <- vars_s]
tpl_vs = mkTemplateLocals tpl_tys
- [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkBigTupleSelector" tpl_vs vars_s,
- the_var `elem` gp ]
+ (tpl_v, group) = case
+ [ (tpl,gp)
+ | (tpl,gp) <- zipEqual "mkBigTupleSelector" tpl_vs vars_s
+ , the_var `elem` gp
+ ] of
+ [x] -> x
+ _ -> panic "mkBigTupleSelector"
-- ^ 'mkBigTupleSelectorSolo' is like 'mkBigTupleSelector'
-- but one-tuples are NOT flattened (see Note [Flattening one-tuples])
mkBigTupleSelectorSolo vars the_var scrut_var scrut
@@ -1284,7 +1289,7 @@ mkRuntimeErrorTy :: TypeOrConstraint -> Type
mkRuntimeErrorTy torc = mkSpecForAllTys [runtimeRep1TyVar, tyvar] $
mkFunctionType ManyTy addrPrimTy (mkTyVarTy tyvar)
where
- (tyvar:_) = mkTemplateTyVars [kind]
+ tyvar:|_ = expectNonEmpty "mkRuntimeErrorTy" $ mkTemplateTyVars [kind]
kind = case torc of
TypeLike -> mkTYPEapp runtimeRep1Ty
ConstraintLike -> mkCONSTRAINTapp runtimeRep1Ty
diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs
index 7fb2c497c7802288d13dc82d2c6572d2b404e56d..71e22f8e9f68b5fdd04714dcfcfed5a0c64a0232 100644
--- a/compiler/GHC/Core/Opt/ConstantFold.hs
+++ b/compiler/GHC/Core/Opt/ConstantFold.hs
@@ -20,7 +20,7 @@ ToDo:
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
-{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE -Wno-incomplete-uni-patterns #-}
+{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
-- | Constant Folder
module GHC.Core.Opt.ConstantFold
@@ -55,7 +55,7 @@ import GHC.Core.Rules.Config
import GHC.Core.Type
import GHC.Core.TyCo.Compare( eqType )
import GHC.Core.TyCon
- ( TyCon, tyConDataCons_maybe, tyConDataCons, tyConFamilySize
+ ( TyCon, tyConDataCons_maybe, tyConDataCons, tyConSingleDataCon, tyConFamilySize
, isEnumerationTyCon, isValidDTT2TyCon, isNewTyCon )
import GHC.Core.Map.Expr ( eqCoreExpr )
@@ -2059,7 +2059,7 @@ unsafeEqualityProofRule
; fn <- getFunction
; let (_, ue) = splitForAllTyCoVars (idType fn)
tc = tyConAppTyCon ue -- tycon: UnsafeEquality
- (dc:_) = tyConDataCons tc -- data con: UnsafeRefl
+ dc = tyConSingleDataCon tc -- data con: UnsafeRefl
-- UnsafeRefl :: forall (r :: RuntimeRep) (a :: TYPE r).
-- UnsafeEquality r a a
; return (mkTyApps (Var (dataConWrapId dc)) [rep, t1]) }
diff --git a/compiler/GHC/Core/Opt/Simplify/Iteration.hs b/compiler/GHC/Core/Opt/Simplify/Iteration.hs
index 0ef58aec223b9a07654c0c60fe4b9d72e4906347..3fb98f6688da1e4a817c21b875b2554e91489e74 100644
--- a/compiler/GHC/Core/Opt/Simplify/Iteration.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Iteration.hs
@@ -8,7 +8,6 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiWayIf #-}
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Core.Opt.Simplify.Iteration ( simplTopBinds, simplExpr, simplImpRules ) where
import GHC.Prelude
@@ -69,6 +68,7 @@ import GHC.Utils.Logger
import GHC.Utils.Misc
import Control.Monad
+import Data.List.NonEmpty (NonEmpty (..))
{-
The guts of the simplifier is in this module, but the driver loop for
@@ -3866,7 +3866,7 @@ mkDupableContWithDmds env _
, thumbsUpPlanA cont
= -- Use Plan A of Note [Duplicating StrictArg]
-- pprTrace "Using plan A" (ppr (ai_fun fun) $$ text "args" <+> ppr (ai_args fun) $$ text "cont" <+> ppr cont) $
- do { let (_ : dmds) = ai_dmds fun
+ do { let _ :| dmds = expectNonEmpty "mkDupableContWithDmds" $ ai_dmds fun
; (floats1, cont') <- mkDupableContWithDmds env dmds cont
-- Use the demands from the function to add the right
-- demand info on any bindings we make for further args
@@ -3912,7 +3912,7 @@ mkDupableContWithDmds env dmds
-- let a = ...arg...
-- in [...hole...] a
-- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable
- do { let (dmd:cont_dmds) = dmds -- Never fails
+ do { let dmd:|cont_dmds = expectNonEmpty "mkDupableContWithDmds" dmds
; (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont
; let env' = env `setInScopeFromF` floats1
; (_, se', arg') <- simplLazyArg env' dup hole_ty Nothing se arg
diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs
index 45029e2a26414c79c1c9a22982f48761aee58f90..a0ac40495738cff3b947f3f06eca752512a67764 100644
--- a/compiler/GHC/Core/Opt/SpecConstr.hs
+++ b/compiler/GHC/Core/Opt/SpecConstr.hs
@@ -11,10 +11,6 @@ ToDo [Oct 2013]
\section[SpecConstr]{Specialise over constructors}
-}
-
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
module GHC.Core.Opt.SpecConstr(
specConstrProgram,
SpecConstrAnnotation(..),
@@ -65,7 +61,7 @@ import GHC.Types.Unique.Supply
import GHC.Types.Unique.FM
import GHC.Types.Unique( hasKey )
-import GHC.Data.Maybe ( orElse, catMaybes, isJust, isNothing )
+import GHC.Data.Maybe ( fromMaybe, orElse, catMaybes, isJust, isNothing )
import GHC.Data.FastString
import GHC.Utils.Misc
@@ -81,6 +77,7 @@ import GHC.Serialized ( deserializeWithData )
import Control.Monad
import Data.List ( sortBy, partition, dropWhileEnd, mapAccumL )
+import Data.List.NonEmpty ( NonEmpty (..) )
import Data.Maybe( mapMaybe )
import Data.Ord( comparing )
import Data.Tuple
@@ -1305,10 +1302,10 @@ combineUsages :: [ScUsage] -> ScUsage
combineUsages [] = nullUsage
combineUsages us = foldr1 combineUsage us
-lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc])
+lookupOccs :: Traversable f => ScUsage -> f OutVar -> (ScUsage, f ArgOcc)
lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs
= (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs},
- [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs])
+ fromMaybe NoOcc . lookupVarEnv sc_occs <$> bndrs)
data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument
| UnkOcc -- Used in some unknown way
@@ -1584,7 +1581,7 @@ scExpr' env (Case scrut b ty alts)
= do { let (env1, bs1) = extendBndrsWith RecArg env bs
(env2, bs2) = extendCaseBndrs env1 scrut' b' con bs1
; (usg, rhs', ws) <- scExpr env2 rhs
- ; let (usg', b_occ:arg_occs) = lookupOccs usg (b':bs2)
+ ; let (usg', b_occ:|arg_occs) = lookupOccs usg (b':|bs2)
scrut_occ = case con of
DataAlt dc -- See Note [Do not specialise evals]
| not (single_alt && all deadArgOcc arg_occs)
@@ -2511,22 +2508,21 @@ trim_pats :: ScEnv -> Id -> SpecInfo -> [CallPat] -> (Bool, [CallPat])
-- True <=> some patterns were discarded
-- See Note [Choosing patterns]
trim_pats env fn (SI { si_n_specs = done_spec_count }) pats
- | sc_force env
- || isNothing mb_scc
- || n_remaining >= n_pats
- = -- pprTrace "trim_pats: no-trim" (ppr (sc_force env) $$ ppr mb_scc $$ ppr n_remaining $$ ppr n_pats)
- (False, pats) -- No need to trim
+ | False <- sc_force env
+ , Just max_specs <- mb_scc
+ , let n_remaining = max_specs - done_spec_count
+ , n_remaining < n_pats
+ = emit_trace max_specs n_remaining $ -- Need to trim, so keep the best ones
+ (True, take n_remaining sorted_pats)
| otherwise
- = emit_trace $ -- Need to trim, so keep the best ones
- (True, take n_remaining sorted_pats)
+ = -- pprTrace "trim_pats: no-trim" (ppr (sc_force env) $$ ppr mb_scc $$ ppr n_remaining $$ ppr n_pats)
+ (False, pats) -- No need to trim
where
n_pats = length pats
spec_count' = n_pats + done_spec_count
- n_remaining = max_specs - done_spec_count
mb_scc = sc_count $ sc_opts env
- Just max_specs = mb_scc
sorted_pats = map fst $
sortBy (comparing snd) $
@@ -2549,21 +2545,24 @@ trim_pats env fn (SI { si_n_specs = done_spec_count }) pats
n_cons (Lit {}) = 1
n_cons _ = 0
- emit_trace result
+ emit_trace max_specs n_remaining result
| debugIsOn || sc_debug (sc_opts env)
-- Suppress this scary message for ordinary users! #5125
= pprTrace "SpecConstr" msg result
| otherwise
= result
- msg = vcat [ sep [ text "Function" <+> quotes (ppr fn)
- , nest 2 (text "has" <+>
- speakNOf spec_count' (text "call pattern") <> comma <+>
- text "but the limit is" <+> int max_specs) ]
- , text "Use -fspec-constr-count=n to set the bound"
- , text "done_spec_count =" <+> int done_spec_count
- , text "Keeping " <+> int n_remaining <> text ", out of" <+> int n_pats
- , text "Discarding:" <+> ppr (drop n_remaining sorted_pats) ]
-
+ where
+ msg = vcat
+ [ sep
+ [ text "Function" <+> quotes (ppr fn)
+ , nest 2
+ ( text "has" <+>
+ speakNOf spec_count' (text "call pattern") <> comma <+>
+ text "but the limit is" <+> int max_specs ) ]
+ , text "Use -fspec-constr-count=n to set the bound"
+ , text "done_spec_count =" <+> int done_spec_count
+ , text "Keeping " <+> int n_remaining <> text ", out of" <+> int n_pats
+ , text "Discarding:" <+> ppr (drop n_remaining sorted_pats) ]
callToPat :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
-- The [Var] is the variables to quantify over in the rule
diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs
index 706646dddd22d03a512714367e6fc14d9f6e35f7..a9b50cb86af612b3fa7db2d53542fe58a7dd8697 100644
--- a/compiler/GHC/Core/Opt/Specialise.hs
+++ b/compiler/GHC/Core/Opt/Specialise.hs
@@ -1,5 +1,3 @@
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
{-
(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
@@ -1318,7 +1316,7 @@ specCase env scrut' case_bndr [Alt con args rhs]
-- ; pprTrace "specCase" (ppr case_bndr $$ ppr scrut_bind) $
; return (Var case_bndr_flt, case_bndr', [alt'], all_uds) }
where
- (env_rhs, (case_bndr':args')) = substBndrs env (case_bndr:args)
+ (env_rhs, (case_bndr':|args')) = substBndrs env (case_bndr:|args)
sc_args' = filter is_flt_sc_arg args'
clone_me bndr = do { uniq <- getUniqueM
@@ -3466,7 +3464,7 @@ substBndr :: SpecEnv -> CoreBndr -> (SpecEnv, CoreBndr)
substBndr env bs = case Core.substBndr (se_subst env) bs of
(subst', bs') -> (env { se_subst = subst' }, bs')
-substBndrs :: SpecEnv -> [CoreBndr] -> (SpecEnv, [CoreBndr])
+substBndrs :: Traversable f => SpecEnv -> f CoreBndr -> (SpecEnv, f CoreBndr)
substBndrs env bs = case Core.substBndrs (se_subst env) bs of
(subst', bs') -> (env { se_subst = subst' }, bs')
diff --git a/compiler/GHC/Core/TyCo/Tidy.hs b/compiler/GHC/Core/TyCo/Tidy.hs
index 4875c2d5790d9f6499551919ab7d07cca0d1589f..f5eb845a7edc2e01e6389a5c6b32f4f708cbc4db 100644
--- a/compiler/GHC/Core/TyCo/Tidy.hs
+++ b/compiler/GHC/Core/TyCo/Tidy.hs
@@ -1,5 +1,3 @@
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
-- | Tidying types and coercions for printing in error messages.
module GHC.Core.TyCo.Tidy
(
diff --git a/compiler/GHC/Core/Unify.hs b/compiler/GHC/Core/Unify.hs
index d19bc47ee43c6891135a2916c1da9409d550ff03..5b2c3ec2e3fbcf32fb59a8efd9a01eda3186276f 100644
--- a/compiler/GHC/Core/Unify.hs
+++ b/compiler/GHC/Core/Unify.hs
@@ -2063,11 +2063,12 @@ emptyFlattenEnv in_scope
updateInScopeSet :: FlattenEnv -> (InScopeSet -> InScopeSet) -> FlattenEnv
updateInScopeSet env upd = env { fe_in_scope = upd (fe_in_scope env) }
-flattenTys :: InScopeSet -> [Type] -> [Type]
+flattenTys :: Traversable f => InScopeSet -> f Type -> f Type
-- See Note [Flattening type-family applications when matching instances]
-flattenTys in_scope tys = fst (flattenTysX in_scope tys)
+flattenTys = \ in_scope tys -> fst (flattenTysX in_scope tys)
+{-# INLINE flattenTys #-}
-flattenTysX :: InScopeSet -> [Type] -> ([Type], TyVarEnv (TyCon, [Type]))
+flattenTysX :: Traversable f => InScopeSet -> f Type -> (f Type, TyVarEnv (TyCon, [Type]))
-- See Note [Flattening type-family applications when matching instances]
-- NB: the returned types mention the fresh type variables
-- in the domain of the returned env, whose range includes
@@ -2083,14 +2084,16 @@ flattenTysX in_scope tys
= let (env, result) = coreFlattenTys emptyTvSubstEnv (emptyFlattenEnv in_scope) tys in
(result, build_env (fe_type_map env))
where
- build_env :: TypeMap (TyVar, TyCon, [Type]) -> TyVarEnv (TyCon, [Type])
+ build_env :: TypeMap (TyVar, TyCon, f Type) -> TyVarEnv (TyCon, f Type)
build_env env_in
= foldTM (\(tv, tc, tys) env_out -> extendVarEnv env_out tv (tc, tys))
env_in emptyVarEnv
+{-# SPECIALIZE flattenTysX :: InScopeSet -> [Type] -> ([Type], TyVarEnv (TyCon, [Type])) #-}
-coreFlattenTys :: TvSubstEnv -> FlattenEnv
- -> [Type] -> (FlattenEnv, [Type])
-coreFlattenTys subst = mapAccumL (coreFlattenTy subst)
+coreFlattenTys :: Traversable f => TvSubstEnv -> FlattenEnv
+ -> f Type -> (FlattenEnv, f Type)
+coreFlattenTys = mapAccumL . coreFlattenTy
+{-# INLINE coreFlattenTys #-}
coreFlattenTy :: TvSubstEnv -> FlattenEnv
-> Type -> (FlattenEnv, Type)
diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs
index 187a43c704d1debfea343790a75ebfa0fc743632..cc8f82d2106cd29c115848ffc87a0febebc6b6ba 100644
--- a/compiler/GHC/CoreToStg/Prep.hs
+++ b/compiler/GHC/CoreToStg/Prep.hs
@@ -1,7 +1,5 @@
{-# LANGUAGE ViewPatterns #-}
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
{-
(c) The University of Glasgow, 1994-2006
@@ -765,7 +763,9 @@ cpeJoinPair :: CorePrepEnv -> JoinId -> CoreExpr
-- No eta-expansion: see Note [Do not eta-expand join points] in GHC.Core.Opt.Simplify.Utils
cpeJoinPair env bndr rhs
= assert (isJoinId bndr) $
- do { let JoinPoint join_arity = idJoinPointHood bndr
+ do { let join_arity = case idJoinPointHood bndr of
+ JoinPoint join_arity -> join_arity
+ _ -> panic "cpeJoinPair"
(bndrs, body) = collectNBinders join_arity rhs
; (env', bndrs') <- cpCloneBndrs env bndrs
diff --git a/compiler/GHC/Driver/Pipeline/Execute.hs b/compiler/GHC/Driver/Pipeline/Execute.hs
index 5ba39e4bb23455cacbd9c66d79950028d5b91854..05f16c43f570a4f2be19b8909fe31688177ba2eb 100644
--- a/compiler/GHC/Driver/Pipeline/Execute.hs
+++ b/compiler/GHC/Driver/Pipeline/Execute.hs
@@ -4,7 +4,6 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GADTs #-}
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
#include <ghcplatform.h>
{- Functions for providing the default interpretation of the 'TPhase' actions
@@ -963,7 +962,7 @@ llvmOptions llvm_config dflags =
where target = platformMisc_llvmTarget $ platformMisc dflags
target_os = platformOS (targetPlatform dflags)
- Just (LlvmTarget _ mcpu mattr) = lookup target (llvmTargets llvm_config)
+ LlvmTarget _ mcpu mattr = expectJust "llvmOptions" $ lookup target (llvmTargets llvm_config)
-- Relocation models
rmodel | gopt Opt_PIC dflags
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index bf1db99c3b37f48dd94b8affde7edf2cdecb47d2..8ca131af960d0cc61eb37c64ba757f145ae8da64 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -17,8 +17,6 @@
--
-------------------------------------------------------------------------------
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
module GHC.Driver.Session (
-- * Dynamic flags and associated configuration types
DumpFlag(..),
@@ -285,6 +283,7 @@ import Data.Functor.Identity
import Data.Ord
import Data.Char
import Data.List (intercalate, sortBy, partition)
+import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import qualified Data.Set as Set
@@ -707,15 +706,15 @@ setDumpPrefixForce f d = d { dumpPrefixForce = f}
-- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"]
-- Config.hs should really use Option.
setPgmP f = alterToolSettings (\s -> s { toolSettings_pgm_P = (pgm, map Option args)})
- where (pgm:args) = words f
+ where pgm:|args = expectNonEmpty "setPgmP" $ words f
-- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"]
-- Config.hs should really use Option.
setPgmJSP f = alterToolSettings (\s -> s { toolSettings_pgm_JSP = (pgm, map Option args)})
- where (pgm:args) = words f
+ where pgm:|args = expectNonEmpty "setPgmJSP" $ words f
-- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"]
-- Config.hs should really use Option.
setPgmCmmP f = alterToolSettings (\s -> s { toolSettings_pgm_CmmP = (pgm, map Option args)})
- where (pgm:args) = words f
+ where pgm:|args = expectNonEmpty "setPgmCmmP" $ words f
addOptl f = alterToolSettings (\s -> s { toolSettings_opt_l = f : toolSettings_opt_l s})
addOptc f = alterToolSettings (\s -> s { toolSettings_opt_c = f : toolSettings_opt_c s})
addOptcxx f = alterToolSettings (\s -> s { toolSettings_opt_cxx = f : toolSettings_opt_cxx s})
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index 36efbf17b5d4251e2e42a36b933382651027d4de..5a937889e5a49840f36de5255b7116b78764a86a 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -12,8 +12,6 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
-----------------------------------------------------------------------------
--
-- (c) The University of Glasgow 2006
@@ -120,8 +118,8 @@ mkMetaWrappers q@(QuoteWrapper quote_var_raw m_var) = do
-- to be used to construct the monadWrapper.
quote_tc <- dsLookupTyCon quoteClassName
monad_tc <- dsLookupTyCon monadClassName
- let Just cls = tyConClass_maybe quote_tc
- Just monad_cls = tyConClass_maybe monad_tc
+ let cls = expectJust "mkMetaWrappers" $ tyConClass_maybe quote_tc
+ monad_cls = expectJust "mkMetaWrappers" $ tyConClass_maybe monad_tc
-- Quote m -> Monad m
monad_sel = classSCSelId cls 0
@@ -176,7 +174,7 @@ dsBracket (HsBracketTc { hsb_wrap = mb_wrap, hsb_splices = splices, hsb_quote =
DecBrG _ gp -> runOverloaded $ do { MkC ds1 <- repTopDs gp ; return ds1 }
DecBrL {} -> panic "dsUntypedBracket: unexpected DecBrL"
where
- Just wrap = mb_wrap -- Not used in VarBr case
+ wrap = expectJust "dsBracket" mb_wrap -- Not used in VarBr case
-- In the overloaded case we have to get given a wrapper, it is just
-- the VarBr case that there is no wrapper, because they
-- have a simple type.
diff --git a/compiler/GHC/HsToCore/Usage.hs b/compiler/GHC/HsToCore/Usage.hs
index 8960d025dce9bfecdec6c2534d54ac607a8e69a5..b1ece2e22c3e2f13a92e1ef55c9e16dd4a8d1970 100644
--- a/compiler/GHC/HsToCore/Usage.hs
+++ b/compiler/GHC/HsToCore/Usage.hs
@@ -1,7 +1,3 @@
-
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
module GHC.HsToCore.Usage (
-- * Dependency/fingerprinting code (used by GHC.Iface.Make)
mkUsageInfo, mkUsedNames,
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index b8d77ab653870d3f12af66284872ea36b77b8488..84ba63f62d17fd241134a4034dfe8ef1291b3ff8 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -14,7 +14,6 @@
{-# LANGUAGE UndecidableSuperClasses #-}
{-# LANGUAGE RankNTypes #-}
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -Wno-orphans #-} -- For the HasLoc instances
{-
@@ -59,6 +58,7 @@ import GHC.Utils.Misc
import GHC.Data.Maybe
import GHC.Data.FastString
import qualified GHC.Data.Strict as Strict
+import GHC.Data.Pair
import GHC.Iface.Ext.Types
import GHC.Iface.Ext.Utils
@@ -83,6 +83,7 @@ import Control.Monad.Trans.Class ( lift )
import Control.Applicative ( (<|>) )
import GHC.Types.TypeEnv ( TypeEnv )
import Control.Arrow ( second )
+import Data.Traversable ( mapAccumR )
{- Note [Updating HieAst for changes in the GHC AST]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -508,24 +509,19 @@ data TVScoped a = TVS TyVarScope Scope a -- TyVarScope
-- things to its right, ala RScoped
-- | Each element scopes over the elements to the right
-listScopes :: Scope -> [LocatedA a] -> [RScoped (LocatedA a)]
-listScopes _ [] = []
-listScopes rhsScope [pat] = [RS rhsScope pat]
-listScopes rhsScope (pat : pats) = RS sc pat : pats'
- where
- pats'@((RS scope p):_) = listScopes rhsScope pats
- sc = combineScopes scope $ mkScope $ getLocA p
+listScopes :: Traversable f => Scope -> f (LocatedA a) -> f (RScoped (LocatedA a))
+listScopes = fmap snd . mapAccumR (\ (scope :: Scope) pat -> let scope' = combineScopes scope $ mkScope $ getLocA pat in (scope', RS scope pat))
-- | 'listScopes' specialised to 'PScoped' things
patScopes
- :: Maybe Span
+ :: Traversable f
+ => Maybe Span
-> Scope
-> Scope
- -> [LPat (GhcPass p)]
- -> [PScoped (LPat (GhcPass p))]
-patScopes rsp useScope patScope xs =
- map (\(RS sc a) -> PS rsp useScope sc a) $
- listScopes patScope xs
+ -> f (LPat (GhcPass p))
+ -> f (PScoped (LPat (GhcPass p)))
+patScopes rsp useScope patScope =
+ fmap (\(RS sc a) -> PS rsp useScope sc a) . listScopes patScope
-- | 'listScopes' specialised to 'HsConPatTyArg'
taScopes
@@ -1093,7 +1089,7 @@ instance HiePass p => ToHie (PScoped (LocatedA (Pat (GhcPass p)))) where
(patScopes rsp scope pscope args)
where argscope = foldr combineScopes NoScope $ map mkScope args
contextify (InfixCon a b) = InfixCon a' b'
- where [a', b'] = patScopes rsp scope pscope [a,b]
+ where Pair a' b' = patScopes rsp scope pscope (Pair a b)
contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r
contextify_rec (HsRecFields x fds a) = HsRecFields x (map go scoped_fds) a
where
diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs
index fc65ce445e0609aaf924c9954fed463a57cfa48f..d5c407b3dff919a991905e5b97e22337b205a153 100644
--- a/compiler/GHC/Iface/Tidy.hs
+++ b/compiler/GHC/Iface/Tidy.hs
@@ -1,7 +1,5 @@
{-# LANGUAGE DeriveFunctor #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# LANGUAGE NamedFieldPuns #-}
{-
@@ -1313,7 +1311,7 @@ tidyTopPair unfold_env boot_exports rhs_tidy_env (bndr, rhs)
(bndr1, rhs1)
where
- Just (name',show_unfold) = lookupVarEnv unfold_env bndr
+ (name',show_unfold) = expectJust "tidyTopPair" $ lookupVarEnv unfold_env bndr
!cbv_bndr = tidyCbvInfoTop boot_exports bndr rhs
bndr1 = mkGlobalId details name' ty' idinfo'
details = idDetails cbv_bndr -- Preserve the IdDetails
diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs
index a37aa79a37f6667ed355e41b0a42e7cdcf3e353d..ede475bb0560a2e959bbeeb8cb03b2ac314ccbd7 100644
--- a/compiler/GHC/Rename/Bind.hs
+++ b/compiler/GHC/Rename/Bind.hs
@@ -1,8 +1,6 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
@@ -1087,7 +1085,7 @@ renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty)
; (new_ty, fvs) <- rnHsSigType ty_ctxt TypeLevel ty
; return (ClassOpSig noAnn is_deflt new_v new_ty, fvs) }
where
- (v1:_) = vs
+ v1:|_ = expectNonEmpty "renameSig" vs
ty_ctxt = GenericCtx (text "a class method signature for"
<+> quotes (ppr v1))
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index f2e5695f798a6ca6b0f42efda61b5435201b147e..59049cddbb50cc7f391d176eb8ca8614267527a9 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -10,7 +10,6 @@
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs
index 62723bf4d6b7b43f21b020802d890a757710074e..8a5d0c086c664bafa734fc267661ec5ab33f6d18 100644
--- a/compiler/GHC/Runtime/Eval.hs
+++ b/compiler/GHC/Runtime/Eval.hs
@@ -2,8 +2,6 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
-- -----------------------------------------------------------------------------
--
-- (c) The University of Glasgow, 2005-2007
@@ -678,7 +676,7 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
noSkolems = noFreeVarsOfType . idType
improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do
let tmp_ids = [id | AnId id <- ic_tythings ic]
- Just id = find (\i -> idName i == name) tmp_ids
+ id = expectJust "rttiEnvironment" $ find (\i -> idName i == name) tmp_ids
if noSkolems id
then return hsc_env
else do
diff --git a/compiler/GHC/Stg/Unarise.hs b/compiler/GHC/Stg/Unarise.hs
index b6271ce7ca3c5263ca56792185be4162060f941d..bd2b0794e88bb981a9aa88fed65bac79f062d4af 100644
--- a/compiler/GHC/Stg/Unarise.hs
+++ b/compiler/GHC/Stg/Unarise.hs
@@ -732,9 +732,7 @@ unariseAlts rho (MultiValAlt _) bndr [GenStgAlt{ alt_con = DEFAULT
unariseAlts rho (MultiValAlt _) bndr alts
| isUnboxedSumBndr bndr
= do (rho_sum_bndrs, scrt_bndrs) <- unariseConArgBinder rho bndr
- let (tag_bndr, real_bndrs) = case scrt_bndrs of
- [] -> panic "unariseAlts: empty scrt_bndrs"
- x:xs -> (x, xs)
+ let tag_bndr:|real_bndrs = expectNonEmpty "unariseAlts" scrt_bndrs
alts' <- unariseSumAlts rho_sum_bndrs (map StgVarArg real_bndrs) alts
let inner_case = StgCase (StgApp tag_bndr []) tag_bndr tagAltTy alts'
return [GenStgAlt{ alt_con = DataAlt (tupleDataCon Unboxed (length scrt_bndrs))
diff --git a/compiler/GHC/StgToCmm/CgUtils.hs b/compiler/GHC/StgToCmm/CgUtils.hs
index 3d8681932892deead6042573b8f8267fd0e284b2..cf598ede1f24a88b4cd2caa211c1cbf9137ca02c 100644
--- a/compiler/GHC/StgToCmm/CgUtils.hs
+++ b/compiler/GHC/StgToCmm/CgUtils.hs
@@ -147,7 +147,7 @@ get_Regtable_addr_from_offset platform offset =
-- | Fixup global registers so that they assign to locations within the
-- RegTable if they aren't pinned for the current target.
-fixStgRegisters :: Platform -> RawCmmDecl -> RawCmmDecl
+fixStgRegisters :: Platform -> GenCmmDecl d h (GenCmmGraph CmmNode) -> GenCmmDecl d h (GenCmmGraph CmmNode)
fixStgRegisters _ top@(CmmData _ _) = top
fixStgRegisters platform (CmmProc info lbl live graph) =
diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs
index 504024fc491af731f71da93f48a8aa52e1342041..4af57c73766d2dd5f6898609525c5b84d8623741 100644
--- a/compiler/GHC/StgToCmm/Expr.hs
+++ b/compiler/GHC/StgToCmm/Expr.hs
@@ -1,4 +1,3 @@
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
@@ -729,7 +728,9 @@ cgAlts gc_plan bndr (PrimAlt _) alts
; tagged_cmms <- cgAltRhss gc_plan bndr alts
; let bndr_reg = CmmLocal (idToReg platform bndr)
- (DEFAULT,deflt) = head tagged_cmms
+ deflt = case tagged_cmms of
+ (DEFAULT,deflt):_ -> deflt
+ _ -> panic "cgAlts PrimAlt"
-- PrimAlts always have a DEFAULT case
-- and it always comes first
diff --git a/compiler/GHC/Tc/Deriv.hs b/compiler/GHC/Tc/Deriv.hs
index e51b1854c75295c1873fe142c4e6a940af5991eb..d4e1925995585d0dcfb64a7a4af1df2ebdb5e701 100644
--- a/compiler/GHC/Tc/Deriv.hs
+++ b/compiler/GHC/Tc/Deriv.hs
@@ -578,7 +578,9 @@ derivePred tc tys mb_lderiv_strat via_tvs deriv_pred =
(cls_tvs, cls, cls_tys, cls_arg_kinds) <- tcHsDeriv deriv_pred
when (cls_arg_kinds `lengthIsNot` 1) $
failWithTc (TcRnNonUnaryTypeclassConstraint DerivClauseCtxt deriv_pred)
- let [cls_arg_kind] = cls_arg_kinds
+ let cls_arg_kind = case cls_arg_kinds of
+ [x] -> x
+ _ -> panic "derivePred"
mb_deriv_strat = fmap unLoc mb_lderiv_strat
if (className cls == typeableClassName)
then do warnUselessTypeable
@@ -723,12 +725,12 @@ deriveStandalone (L loc (DerivDecl (warn, _) deriv_ty mb_lderiv_strat overlap_mo
inst_ty_kind = typeKind inst_ty
mb_match = tcUnifyTy inst_ty_kind via_kind
- checkTc (isJust mb_match)
- (TcRnCannotDeriveInstance cls mempty Nothing NoGeneralizedNewtypeDeriving $
- DerivErrDerivingViaWrongKind inst_ty_kind via_ty via_kind)
+ kind_subst <- checkJustTc
+ ( TcRnCannotDeriveInstance cls mempty Nothing NoGeneralizedNewtypeDeriving $
+ DerivErrDerivingViaWrongKind inst_ty_kind via_ty via_kind )
+ mb_match
- let Just kind_subst = mb_match
- ki_subst_range = getSubstRangeTyCoFVs kind_subst
+ let ki_subst_range = getSubstRangeTyCoFVs kind_subst
-- See Note [Unification of two kind variables in deriving]
unmapped_tkvs = filter (\v -> v `notElemSubst` kind_subst
&& not (v `elemVarSet` ki_subst_range))
@@ -853,9 +855,10 @@ deriveTyData tc tc_args mb_deriv_strat deriv_tvs cls cls_tys cls_arg_kind
, text "tycon:" <+> ppr tc <+> dcolon <+> ppr (tyConKind tc)
, text "cls_arg:" <+> ppr (mkTyConApp tc tc_args_to_keep) <+> dcolon <+> ppr inst_ty_kind
, text "cls_arg_kind:" <+> ppr cls_arg_kind ]
- ; checkTc (enough_args && isJust mb_match)
- (TcRnCannotDeriveInstance cls cls_tys Nothing NoGeneralizedNewtypeDeriving $
- DerivErrNotWellKinded tc cls_arg_kind n_args_to_keep)
+ ; kind_subst <- checkJustTc
+ ( TcRnCannotDeriveInstance cls cls_tys Nothing NoGeneralizedNewtypeDeriving $
+ DerivErrNotWellKinded tc cls_arg_kind n_args_to_keep )
+ ( guard enough_args *> mb_match )
; let -- Returns a singleton-element list if using ViaStrategy and an
-- empty list otherwise. Useful for free-variable calculations.
@@ -883,7 +886,6 @@ deriveTyData tc tc_args mb_deriv_strat deriv_tvs cls cls_tys cls_arg_kind
; let tkvs = scopedSort $ fvVarList $
unionFV (tyCoFVsOfTypes tc_args_to_keep)
(FV.mkFVs deriv_tvs)
- Just kind_subst = mb_match
(tkvs', cls_tys', tc_args', mb_deriv_strat')
= propagate_subst kind_subst tkvs cls_tys
tc_args_to_keep mb_deriv_strat
@@ -899,11 +901,11 @@ deriveTyData tc tc_args mb_deriv_strat deriv_tvs cls cls_tys cls_arg_kind
= typeKind (mkTyConApp tc tc_args')
via_match = tcUnifyTy inst_ty_kind via_kind
- checkTc (isJust via_match)
- (TcRnCannotDeriveInstance cls mempty Nothing NoGeneralizedNewtypeDeriving $
- DerivErrDerivingViaWrongKind inst_ty_kind via_ty via_kind)
+ via_subst <- checkJustTc
+ ( TcRnCannotDeriveInstance cls mempty Nothing NoGeneralizedNewtypeDeriving $
+ DerivErrDerivingViaWrongKind inst_ty_kind via_ty via_kind )
+ via_match
- let Just via_subst = via_match
pure $ propagate_subst via_subst tkvs' cls_tys'
tc_args' mb_deriv_strat'
diff --git a/compiler/GHC/Tc/Gen/Do.hs b/compiler/GHC/Tc/Gen/Do.hs
index 19ceb9a5b68171beaebf93d276b38a290561655a..521a0b239e44f215ae307d119b72e464656fd8e2 100644
--- a/compiler/GHC/Tc/Gen/Do.hs
+++ b/compiler/GHC/Tc/Gen/Do.hs
@@ -6,8 +6,6 @@
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs
index e8232a1553eb2c053657db4e779175a5288b2a0c..d1b4d052526fcbd8ea0af848e95dd6ffcbdce5a4 100644
--- a/compiler/GHC/Tc/Gen/HsType.hs
+++ b/compiler/GHC/Tc/Gen/HsType.hs
@@ -7,8 +7,6 @@
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RecursiveDo #-}
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
diff --git a/compiler/GHC/Tc/Instance/Class.hs b/compiler/GHC/Tc/Instance/Class.hs
index 086a71cfcdca3b62fe20b2911ce42f027c2d0dcc..5f17f2ca1fe8e5b3126abcbaa91dc2ec6a19949a 100644
--- a/compiler/GHC/Tc/Instance/Class.hs
+++ b/compiler/GHC/Tc/Instance/Class.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE MultiWayIf #-}
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Tc.Instance.Class (
matchGlobalInst, matchEqualityInst,
@@ -58,6 +57,7 @@ import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc( splitAtList, fstOf3 )
import GHC.Data.FastString
+import GHC.Data.Maybe ( expectJust )
import GHC.Unit.Module.Warnings
@@ -465,8 +465,8 @@ matchWithDict [cls, mty]
(Var sv `Cast` mkTransCo (mkSubCo co2) (mkSymCo co))
; tc <- tcLookupTyCon withDictClassName
- ; let Just withdict_data_con
- = tyConSingleDataCon_maybe tc -- "Data constructor"
+ ; let withdict_data_con = expectJust "matchWithDict"
+ $ tyConSingleDataCon_maybe tc -- "Data constructor"
-- for WithDict
mk_ev [c] = evDataConApp withdict_data_con
[cls, mty] [evWithDict (evTermCoercion (EvExpr c))]
@@ -1279,7 +1279,8 @@ matchHasField dflags short_cut clas tys mb_ct_loc
`mkTransCo` mkSymCo co2
mk_ev [] = panic "matchHasField.mk_ev"
- Just (_, co2) = tcInstNewTyCon_maybe (classTyCon clas) tys
+ (_, co2) = expectJust "matchHasField" $
+ tcInstNewTyCon_maybe (classTyCon clas) tys
-- The selector must not be "naughty" (i.e. the field
-- cannot have an existentially quantified type),
diff --git a/compiler/GHC/Tc/Solver/InertSet.hs b/compiler/GHC/Tc/Solver/InertSet.hs
index 3923c8080cafd58f8c991b30d4e357cf109a1456..8b0cb61870b825240f394c8d0f7d20b66bc64ca7 100644
--- a/compiler/GHC/Tc/Solver/InertSet.hs
+++ b/compiler/GHC/Tc/Solver/InertSet.hs
@@ -2,8 +2,6 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
module GHC.Tc.Solver.InertSet (
-- * The work list
WorkList(..), isEmptyWorkList, emptyWorkList,
@@ -78,6 +76,7 @@ import GHC.Builtin.Names( eqPrimTyConKey, heqTyConKey, eqTyConKey )
import GHC.Utils.Misc ( partitionWith )
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Data.Pair
import GHC.Data.Maybe
import GHC.Data.Bag
@@ -1894,8 +1893,8 @@ mightEqualLater inert_set given_pred given_loc wanted_pred wanted_loc
-- that the fresh variables are really fresh between the given and
-- the wanted. Flattening both at the same time is needed to get
-- Example 10 from the Note.
- ([flattened_given, flattened_wanted], var_mapping)
- = flattenTysX in_scope [given_pred, wanted_pred]
+ (Pair flattened_given flattened_wanted, var_mapping)
+ = flattenTysX in_scope (Pair given_pred wanted_pred)
bind_fun :: BindFun
bind_fun tv rhs_ty
diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs
index fc258c5fef4929a2266e05e2bebe014b07c1a47e..269f70f1240becaae4db7fb15eb070dd458b0402 100644
--- a/compiler/GHC/Tc/TyCl.hs
+++ b/compiler/GHC/Tc/TyCl.hs
@@ -10,8 +10,6 @@
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE LambdaCase #-}
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
-- | Typecheck type and class declarations
module GHC.Tc.TyCl (
tcTyAndClassDecls,
diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs
index 33cc6c8ab8b3755315a4620d7d837845c2b42ada..be7190aae3ba58d58c0ad2a1bf992041b9d2fd20 100644
--- a/compiler/GHC/Tc/TyCl/Utils.hs
+++ b/compiler/GHC/Tc/TyCl/Utils.hs
@@ -1,8 +1,6 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1999
@@ -736,13 +734,14 @@ updateRoleEnv :: Name -> Int -> Role -> RoleM ()
updateRoleEnv name n role
= RM $ \_ _ _ state@(RIS { role_env = role_env }) -> ((),
case lookupNameEnv role_env name of
- Nothing -> pprPanic "updateRoleEnv" (ppr name)
- Just roles -> let (before, old_role : after) = splitAt n roles in
- if role `ltRole` old_role
+ Just roles
+ | (before, old_role : after) <- splitAt n roles
+ -> if role `ltRole` old_role
then let roles' = before ++ role : after
role_env' = extendNameEnv role_env name roles' in
RIS { role_env = role_env', update = True }
- else state )
+ else state
+ _ -> pprPanic "updateRoleEnv" (ppr name))
{- *********************************************************************
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index a723d252f39f8ee648b01f680b93c90afdf37361..fbe249419092ae0695880edae11f7b829fd772f1 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -88,6 +88,7 @@ module GHC.Tc.Utils.Monad(
addErrTcM,
failWithTc, failWithTcM,
checkTc, checkTcM,
+ checkJustTc, checkJustTcM,
failIfTc, failIfTcM,
mkErrCtxt,
addTcRnDiagnostic, addDetailedDiagnostic,
@@ -1585,6 +1586,12 @@ checkTcM :: Bool -> (TidyEnv, TcRnMessage) -> TcM ()
checkTcM True _ = return ()
checkTcM False err = failWithTcM err
+checkJustTc :: TcRnMessage -> Maybe a -> TcM a
+checkJustTc err = maybe (failWithTc err) pure
+
+checkJustTcM :: (TidyEnv, TcRnMessage) -> Maybe a -> TcM a
+checkJustTcM err = maybe (failWithTcM err) pure
+
failIfTc :: Bool -> TcRnMessage -> TcM () -- Check that the boolean is false
failIfTc False _ = return ()
failIfTc True err = failWithTc err
diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs
index 023d8be5f6ca0e5c1ab003352be57d2a2e1c9bab..1f1826b99f73201aede1a52c7d088101da22519d 100644
--- a/compiler/GHC/Tc/Validity.hs
+++ b/compiler/GHC/Tc/Validity.hs
@@ -1,9 +1,6 @@
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase #-}
-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
diff --git a/compiler/GHC/Types/Unique/FM.hs b/compiler/GHC/Types/Unique/FM.hs
index 11ba3815ec0afd970a33b05757b8f9da535dd9fe..c9a15a32642a9cb732a464ff410a33d12876b56e 100644
--- a/compiler/GHC/Types/Unique/FM.hs
+++ b/compiler/GHC/Types/Unique/FM.hs
@@ -240,11 +240,13 @@ adjustUFM_Directly f (UFM m) u = UFM (M.adjust f (getKey u) m)
delFromUFM :: Uniquable key => UniqFM key elt -> key -> UniqFM key elt
delFromUFM (UFM m) k = UFM (M.delete (getKey $ getUnique k) m)
-delListFromUFM :: Uniquable key => UniqFM key elt -> [key] -> UniqFM key elt
+delListFromUFM :: (Uniquable key, Foldable f) => UniqFM key elt -> f key -> UniqFM key elt
delListFromUFM = foldl' delFromUFM
+{-# INLINE delListFromUFM #-}
-delListFromUFM_Directly :: UniqFM key elt -> [Unique] -> UniqFM key elt
+delListFromUFM_Directly :: Foldable f => UniqFM key elt -> f Unique -> UniqFM key elt
delListFromUFM_Directly = foldl' delFromUFM_Directly
+{-# INLINE delListFromUFM_Directly #-}
delFromUFM_Directly :: UniqFM key elt -> Unique -> UniqFM key elt
delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m)
diff --git a/compiler/GHC/Types/Var/Env.hs b/compiler/GHC/Types/Var/Env.hs
index bd5c2970ab05e117249827071c5d01b4fb2c54b1..f5f50f5458b82c34117242307434d83777e11ea0 100644
--- a/compiler/GHC/Types/Var/Env.hs
+++ b/compiler/GHC/Types/Var/Env.hs
@@ -517,7 +517,7 @@ varEnvDomain :: VarEnv elt -> UnVarSet
partitionVarEnv :: (a -> Bool) -> VarEnv a -> (VarEnv a, VarEnv a)
-- | Only keep variables contained in the VarSet
restrictVarEnv :: VarEnv a -> VarSet -> VarEnv a
-delVarEnvList :: VarEnv a -> [Var] -> VarEnv a
+delVarEnvList :: Foldable f => VarEnv a -> f Var -> VarEnv a
delVarEnv :: VarEnv a -> Var -> VarEnv a
minusVarEnv :: VarEnv a -> VarEnv b -> VarEnv a
plusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a
@@ -550,6 +550,8 @@ plusVarEnv_C = plusUFM_C
plusVarEnv_CD = plusUFM_CD
plusMaybeVarEnv_C = plusMaybeUFM_C
delVarEnvList = delListFromUFM
+-- INLINE due to polymorphism
+{-# INLINE delVarEnvList #-}
delVarEnv = delFromUFM
minusVarEnv = minusUFM
plusVarEnv = plusUFM