Compare revisions

jeffrey young · Marge Bot · Matthew Farkas-Dyck · Marge Bot · Matthew Farkas-Dyck · Marge Bot
--- a/.gitlab-ci.yml
+++ b/.gitlab-ci.yml
@@ -909,6 +909,7 @@ test-primops-label:
  extends: .test-primops-validate-template
  rules:
    - if: '$CI_MERGE_REQUEST_LABELS =~ /.*test-primops.*/'
+    - *full-ci

 test-primops-nightly:
  extends: .test-primops

--- a/compiler/GHC/Cmm/DebugBlock.hs
+++ b/compiler/GHC/Cmm/DebugBlock.hs
@@ -6,9 +6,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE LambdaCase #-}
-
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+{-# LANGUAGE EmptyCase #-}

 -----------------------------------------------------------------------------
 --
@@ -41,13 +39,13 @@ import GHC.Cmm.CLabel
 import GHC.Cmm
 import GHC.Cmm.Reg ( pprGlobalReg, pprGlobalRegUse )
 import GHC.Cmm.Utils
-import GHC.Data.FastString ( nilFS, mkFastString )
+import GHC.Data.FastString ( LexicalFastString, nilFS, mkFastString )
 import GHC.Unit.Module
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
 import GHC.Types.SrcLoc
 import GHC.Types.Tickish
-import GHC.Utils.Misc      ( partitionWith, seqList )
+import GHC.Utils.Misc      ( seqList )

 import GHC.Cmm.Dataflow.Block
 import GHC.Cmm.Dataflow.Graph
@@ -55,8 +53,13 @@ import GHC.Cmm.Dataflow.Label

 import Data.Maybe
 import Data.List     ( minimumBy, nubBy )
+import Data.List.NonEmpty ( NonEmpty (..), nonEmpty )
+import qualified Data.List.NonEmpty as NE
 import Data.Ord      ( comparing )
 import qualified Data.Map as Map
+import Data.Foldable ( toList )
+import Data.Either ( partitionEithers )
+import Data.Void

 -- | Debug information about a block of code. Ticks scope over nested
 -- blocks.
@@ -94,23 +97,32 @@ instance OutputableP Platform DebugBlock where

 -- | Intermediate data structure holding debug-relevant context information
 -- about a block.
-type BlockContext = (CmmBlock, RawCmmDecl)
+type BlockContext = (CmmBlock, RawCmmDeclNoStatics)
+
+-- Same as `RawCmmDecl`, but statically (in GHC) excludes the possibility of statics (in the CMM
+-- code). (The first argument is `Void` rather than `RawCmmStatics`.
+type RawCmmDeclNoStatics
+   = GenCmmDecl
+        Void
+        (LabelMap RawCmmStatics)
+        CmmGraph

 -- | Extract debug data from a group of procedures. We will prefer
 -- source notes that come from the given module (presumably the module
 -- that we are currently compiling).
-cmmDebugGen :: ModLocation -> RawCmmGroup -> [DebugBlock]
+cmmDebugGen :: ModLocation -> [RawCmmDecl] -> [DebugBlock]
 cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes
  where
-      blockCtxs :: Map.Map CmmTickScope [BlockContext]
+      blockCtxs :: Map.Map CmmTickScope (NonEmpty BlockContext)
      blockCtxs = blockContexts decls

      -- Analyse tick scope structure: Each one is either a top-level
      -- tick scope, or the child of another.
      (topScopes, childScopes)
-        = partitionWith (\a -> findP a a) $ Map.keys blockCtxs
+        = partitionEithers $ map (\(k, a) -> findP (k, a) k) $ Map.toList blockCtxs
+
      findP tsc GlobalScope = Left tsc -- top scope
-      findP tsc scp | scp' `Map.member` blockCtxs = Right (scp', tsc)
+      findP tsc scp | Just x <- Map.lookup scp' blockCtxs = Right (scp', tsc, x)
                    | otherwise                   = findP tsc scp'
        where -- Note that we only following the left parent of
              -- combined scopes. This loses us ticks, which we will
@@ -118,7 +130,7 @@ cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes
              scp' | SubScope _ scp' <- scp      = scp'
                   | CombinedScope scp' _ <- scp = scp'

-      scopeMap = foldl' (\acc (key, scope) -> insertMulti key scope acc) Map.empty childScopes
+      scopeMap = foldl' (\ acc (k, (k', a'), _) -> insertMulti k (k', a') acc) Map.empty childScopes

      -- This allows us to recover ticks that we lost by flattening
      -- the graph. Basically, if the parent is A but the child is
@@ -137,7 +149,7 @@ cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes
                   | SubScope _ s' <- s       = ticks ++ go s'
                   | CombinedScope s1 s2 <- s = ticks ++ go s1 ++ go s2
                   | otherwise                = panic "ticksToCopy impossible"
-                where ticks = bCtxsTicks $ fromMaybe [] $ Map.lookup s blockCtxs
+                where ticks = bCtxsTicks $ maybe [] toList $ Map.lookup s blockCtxs
      ticksToCopy _ = []
      bCtxsTicks = concatMap (blockTicks . fst)

@@ -147,21 +159,19 @@ cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes
      -- (if we generated one, we probably want debug information to
      -- refer to it).
      bestSrcTick = minimumBy (comparing rangeRating)
-      rangeRating (SourceNote span _)
+      rangeRating (span, _)
        | srcSpanFile span == thisFile = 1
        | otherwise                    = 2 :: Int
-      rangeRating note                 = pprPanic "rangeRating" (ppr note)
      thisFile = maybe nilFS mkFastString $ ml_hs_file modLoc

      -- Returns block tree for this scope as well as all nested
      -- scopes. Note that if there are multiple blocks in the (exact)
      -- same scope we elect one as the "branch" node and add the rest
      -- as children.
-      blocksForScope :: Maybe CmmTickish -> CmmTickScope -> DebugBlock
-      blocksForScope cstick scope = mkBlock True (head bctxs)
-        where bctxs = fromJust $ Map.lookup scope blockCtxs
-              nested = fromMaybe [] $ Map.lookup scope scopeMap
-              childs = map (mkBlock False) (tail bctxs) ++
+      blocksForScope :: Maybe (RealSrcSpan, LexicalFastString) -> (CmmTickScope, NonEmpty BlockContext) -> DebugBlock
+      blocksForScope cstick (scope, bctx:|bctxs) = mkBlock True bctx
+        where nested = fromMaybe [] $ Map.lookup scope scopeMap
+              childs = map (mkBlock False) bctxs ++
                       map (blocksForScope stick) nested

              mkBlock :: Bool -> BlockContext -> DebugBlock
@@ -173,11 +183,13 @@ cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes
                             , dblParent       = Nothing
                             , dblTicks        = ticks
                             , dblPosition     = Nothing -- see cmmDebugLink
-                             , dblSourceTick   = stick
+                             , dblSourceTick   = uncurry SourceNote <$> stick
                             , dblBlocks       = blocks
                             , dblUnwind       = []
                             }
-                where (CmmProc infos _entryLbl _ graph) = prc
+                where (infos, graph) = case prc of
+                          CmmProc infos _ _ graph -> (infos, graph)
+                          CmmData _ v -> case v of
                      label = entryLabel block
                      info = mapLookup label infos
                      blocks | top       = seqList childs childs
@@ -185,26 +197,26 @@ cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes

              -- A source tick scopes over all nested blocks. However
              -- their source ticks might take priority.
-              isSourceTick SourceNote {} = True
-              isSourceTick _             = False
+              isSourceTick (SourceNote span a) = Just (span, a)
+              isSourceTick _ = Nothing
              -- Collect ticks from all blocks inside the tick scope.
              -- We attempt to filter out duplicates while we're at it.
              ticks = nubBy (flip tickishContains) $
                      bCtxsTicks bctxs ++ ticksToCopy scope
-              stick = case filter isSourceTick ticks of
-                []     -> cstick
-                sticks -> Just $! bestSrcTick (sticks ++ maybeToList cstick)
+              stick = case nonEmpty $ mapMaybe isSourceTick ticks of
+                Nothing -> cstick
+                Just sticks -> Just $! bestSrcTick (sticks `NE.appendList` maybeToList cstick)

 -- | Build a map of blocks sorted by their tick scopes
 --
 -- This involves a pre-order traversal, as we want blocks in rough
 -- control flow order (so ticks have a chance to be sorted in the
 -- right order).
-blockContexts :: RawCmmGroup -> Map.Map CmmTickScope [BlockContext]
-blockContexts decls = Map.map reverse $ foldr walkProc Map.empty decls
-  where walkProc :: RawCmmDecl
-                 -> Map.Map CmmTickScope [BlockContext]
-                 -> Map.Map CmmTickScope [BlockContext]
+blockContexts :: [GenCmmDecl a (LabelMap RawCmmStatics) CmmGraph] -> Map.Map CmmTickScope (NonEmpty BlockContext)
+blockContexts = Map.map NE.reverse . foldr walkProc Map.empty
+  where walkProc :: GenCmmDecl a (LabelMap RawCmmStatics) CmmGraph
+                 -> Map.Map CmmTickScope (NonEmpty BlockContext)
+                 -> Map.Map CmmTickScope (NonEmpty BlockContext)
        walkProc CmmData{}                 m = m
        walkProc prc@(CmmProc _ _ _ graph) m
          | mapNull blocks = m
@@ -213,27 +225,28 @@ blockContexts decls = Map.map reverse $ foldr walkProc Map.empty decls
                entry  = [mapFind (g_entry graph) blocks]
                emptyLbls = setEmpty :: LabelSet

-        walkBlock :: RawCmmDecl -> [Block CmmNode C C]
-                  -> (LabelSet, Map.Map CmmTickScope [BlockContext])
-                  -> (LabelSet, Map.Map CmmTickScope [BlockContext])
+        walkBlock :: GenCmmDecl a (LabelMap RawCmmStatics) CmmGraph -> [Block CmmNode C C]
+                  -> (LabelSet, Map.Map CmmTickScope (NonEmpty BlockContext))
+                  -> (LabelSet, Map.Map CmmTickScope (NonEmpty BlockContext))
        walkBlock _   []             c            = c
-        walkBlock prc (block:blocks) (visited, m)
-          | lbl `setMember` visited
-          = walkBlock prc blocks (visited, m)
-          | otherwise
-          = walkBlock prc blocks $
-            walkBlock prc succs
-              (lbl `setInsert` visited,
-               insertMulti scope (block, prc) m)
+        walkBlock prc (block:blocks) (visited, m) = case (prc, setMember lbl visited) of
+            (CmmProc x y z graph, False) ->
+                let succs = flip mapFind (toBlockMap graph) <$>
+                        successors (lastNode block) in
+                walkBlock prc blocks $
+                walkBlock prc succs
+                  ( lbl `setInsert` visited
+                  , insertMultiNE scope (block, CmmProc x y z graph) m )
+            _ -> walkBlock prc blocks (visited, m)
          where CmmEntry lbl scope = firstNode block
-                (CmmProc _ _ _ graph) = prc
-                succs = map (flip mapFind (toBlockMap graph))
-                            (successors (lastNode block))
        mapFind = mapFindWithDefault (error "contextTree: block not found!")

 insertMulti :: Ord k => k -> a -> Map.Map k [a] -> Map.Map k [a]
 insertMulti k v = Map.insertWith (const (v:)) k [v]

+insertMultiNE :: Ord k => k -> a -> Map.Map k (NonEmpty a) -> Map.Map k (NonEmpty a)
+insertMultiNE k v = Map.insertWith (const (v NE.<|)) k (NE.singleton v)
+
 cmmDebugLabels :: (BlockId -> Bool) -> (i -> Bool) -> GenCmmGroup d g (ListGraph i) -> [Label]
 cmmDebugLabels is_valid_label isMeta nats = seqList lbls lbls
  where -- Find order in which procedures will be generated by the

--- a/compiler/GHC/Cmm/MachOp.hs
+++ b/compiler/GHC/Cmm/MachOp.hs
 {-# 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?

--- a/compiler/GHC/Cmm/ThreadSanitizer.hs
+++ b/compiler/GHC/Cmm/ThreadSanitizer.hs
@@ -145,7 +145,7 @@ mkUnsafeCall env ftgt formals args =
    -- arguments as Cmm-Lint checks this. To accomplish this we instead bind
    -- the arguments to local registers.
    arg_regs :: [CmmReg]
-    arg_regs = zipWith arg_reg (uniqsFromSupply arg_us) args
+    arg_regs = zipWith arg_reg (uniqListFromSupply arg_us) args
      where
        arg_reg :: Unique -> CmmExpr -> CmmReg
        arg_reg u expr = CmmLocal $ LocalReg u (cmmExprType (platform env) expr)
@@ -169,7 +169,7 @@ saveRestoreCallerRegs us platform =

    nodes :: [(CmmNode O O, CmmNode O O)]
    nodes =
-        zipWith mk_reg regs_to_save (uniqsFromSupply us)
+        zipWith mk_reg regs_to_save (uniqListFromSupply us)
      where
        mk_reg :: GlobalReg -> Unique -> (CmmNode O O, CmmNode O O)
        mk_reg reg u =

--- a/compiler/GHC/Cmm/Utils.hs
+++ b/compiler/GHC/Cmm/Utils.hs
 {-# 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 _ [] = []

--- a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
+++ b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
 {-# language GADTs, LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
 module GHC.CmmToAsm.AArch64.CodeGen (
      cmmTopCodeGen
    , generateJumpTableForInstr
@@ -50,7 +51,9 @@ import GHC.Types.Unique.DSM
 import GHC.Data.OrdList
 import GHC.Utils.Outputable

-import Control.Monad    ( mapAndUnzipM )
+import Control.Monad    ( join, mapAndUnzipM )
+import Data.List.NonEmpty ( NonEmpty (..), nonEmpty )
+import qualified Data.List.NonEmpty as NE
 import GHC.Float

 import GHC.Types.Basic
@@ -1587,7 +1590,7 @@ genCondJump bid expr = do
      _ -> pprPanic "AArch64.genCondJump: " (text $ show expr)

 -- A conditional jump with at least +/-128M jump range
-genCondFarJump :: MonadGetUnique m => Cond -> Target -> m InstrBlock
+genCondFarJump :: MonadGetUnique m => Cond -> Target -> m (NonEmpty Instr)
 genCondFarJump cond far_target = do
  skip_lbl_id <- newBlockId
  jmp_lbl_id <- newBlockId
@@ -1597,11 +1600,13 @@ genCondFarJump cond far_target = do
  -- need to consider float orderings.
  -- So we take the hit of the additional jump in the false
  -- case for now.
-  return $ toOL [ BCOND cond (TBlock jmp_lbl_id)
-                , B (TBlock skip_lbl_id)
-                , NEWBLOCK jmp_lbl_id
-                , B far_target
-                , NEWBLOCK skip_lbl_id]
+  pure
+    ( BCOND cond (TBlock jmp_lbl_id) :|
+      B (TBlock skip_lbl_id) :
+      NEWBLOCK jmp_lbl_id :
+      B far_target :
+      NEWBLOCK skip_lbl_id :
+      [] )

 genCondBranch :: BlockId      -- the true branch target
    -> BlockId      -- the false branch target
@@ -2457,48 +2462,49 @@ makeFarBranches {- only used when debugging -} _platform statics basic_blocks =

    -- Replace out of range conditional jumps with unconditional jumps.
    replace_blk :: LabelMap Int -> Int -> GenBasicBlock Instr -> UniqDSM (Int, [GenBasicBlock Instr])
-    replace_blk !m !pos (BasicBlock lbl instrs) = do
-      -- Account for a potential info table before the label.
-      let !block_pos = pos + infoTblSize_maybe lbl
-      (!pos', instrs') <- mapAccumLM (replace_jump m) block_pos instrs
-      let instrs'' = concat instrs'
-      -- We might have introduced new labels, so split the instructions into basic blocks again if neccesary.
-      let (top, split_blocks, no_data) = foldr mkBlocks ([],[],[]) instrs''
-      -- There should be no data in the instruction stream at this point
-      massert (null no_data)
-
-      let final_blocks = BasicBlock lbl top : split_blocks
-      pure (pos', final_blocks)
-
-    replace_jump :: LabelMap Int -> Int -> Instr -> UniqDSM (Int, [Instr])
+    replace_blk !m !pos (BasicBlock lbl instrs) = case nonEmpty instrs of
+      Nothing -> pure (0, [])
+      Just instrs -> do
+        -- Account for a potential info table before the label.
+        let !block_pos = pos + infoTblSize_maybe lbl
+        (!pos', instrs') <- mapAccumLM (replace_jump m) block_pos instrs
+        let instrs'' = join instrs'
+        -- We might have introduced new labels, so split the instructions into basic blocks again if neccesary.
+        let (top, split_blocks, no_data) = foldr mkBlocks ([],[],[]) instrs''
+        -- There should be no data in the instruction stream at this point
+        massert (null no_data)
+
+        let final_blocks = BasicBlock lbl top : split_blocks
+        pure (pos', final_blocks)
+
+    replace_jump :: LabelMap Int -> Int -> Instr -> UniqDSM (Int, NonEmpty Instr)
    replace_jump !m !pos instr = do
      case instr of
        ANN ann instr -> do
-          replace_jump m pos instr >>= \case
-            (idx,instr':instrs') ->
-              pure (idx, ANN ann instr':instrs')
-            (idx,[]) -> pprPanic "replace_jump" (text "empty return list for " <+> ppr idx)
+          replace_jump m pos instr >>= \
+            (idx,instr':|instrs') ->
+              pure (idx, ANN ann instr':|instrs')
        BCOND cond t
          -> case target_in_range m t pos of
-              InRange -> pure (pos+long_bc_jump_size,[instr])
+              InRange -> pure (pos+long_bc_jump_size, NE.singleton instr)
              NotInRange far_target -> do
                jmp_code <- genCondFarJump cond far_target
-                pure (pos+long_bc_jump_size, fromOL jmp_code)
+                pure (pos+long_bc_jump_size, jmp_code)
        CBZ op t -> long_zero_jump op t EQ
        CBNZ op t -> long_zero_jump op t NE
        instr
-          | isMetaInstr instr -> pure (pos,[instr])
-          | otherwise -> pure (pos+1, [instr])
+          | isMetaInstr instr -> pure (pos, NE.singleton instr)
+          | otherwise -> pure (pos+1, NE.singleton instr)

      where
        -- cmp_op: EQ = CBZ, NEQ = CBNZ
        long_zero_jump op t cmp_op =
          case target_in_range m t pos of
-              InRange -> pure (pos+long_bz_jump_size,[instr])
+              InRange -> pure (pos+long_bz_jump_size, NE.singleton instr)
              NotInRange far_target -> do
                jmp_code <- genCondFarJump cmp_op far_target
                -- TODO: Fix zero reg so we can use it here
-                pure (pos + long_bz_jump_size, CMP op (OpImm (ImmInt 0)) : fromOL jmp_code)
+                pure (pos + long_bz_jump_size, CMP op (OpImm (ImmInt 0)) NE.<| jmp_code)


    target_in_range :: LabelMap Int -> Target -> Int -> BlockInRange

--- 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


--- a/compiler/GHC/CmmToAsm/PPC/Instr.hs
+++ b/compiler/GHC/CmmToAsm/PPC/Instr.hs
-{-# 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

--- a/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs
+++ b/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs
-
-{-# 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)"

--- a/compiler/GHC/CmmToAsm/Reg/Linear.hs
+++ b/compiler/GHC/CmmToAsm/Reg/Linear.hs

-{-# 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)


--- a/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs
+++ b/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs
-{-# 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


--- a/compiler/GHC/CmmToAsm/Reg/Liveness.hs
+++ b/compiler/GHC/CmmToAsm/Reg/Liveness.hs
 {-# 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

--- a/compiler/GHC/CmmToAsm/X86/CodeGen.hs
+++ b/compiler/GHC/CmmToAsm/X86/CodeGen.hs
@@ -6,8 +6,6 @@
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE NondecreasingIndentation #-}

-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
 -----------------------------------------------------------------------------
 --
 -- Generating machine code (instruction selection)
@@ -1863,14 +1861,13 @@ getRegister' platform is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps
        VecFormat 4 FmtFloat
          -- indices 0 <= i <= 7
          | all ( (>= 0) <&&> (<= 7) ) is ->
-          case is of
-            [i1, i2, i3, i4]
+          case [(i, i-4) | i <- is] of
+            [(i1, j1), (i2, j2), (i3, j3), (i4, j4)]
              | all ( <= 3 ) is
              , let imm = i1 + i2 `shiftL` 2 + i3 `shiftL` 4 + i4 `shiftL` 6
              -> unitOL (VSHUF fmt (ImmInt imm) (OpReg v1) v1 dst)
              | all ( >= 4 ) is
-              , let [j1, j2, j3, j4] = map ( subtract 4 ) is
-                    imm = j1 + j2 `shiftL` 2 + j3 `shiftL` 4 + j4 `shiftL` 6
+              , let imm = j1 + j2 `shiftL` 2 + j3 `shiftL` 4 + j4 `shiftL` 6
              -> unitOL (VSHUF fmt (ImmInt imm) (OpReg v2) v2 dst)
              | i1 <= 3, i2 <= 3
              , i3 >= 4, i4 >= 4
@@ -2507,13 +2504,11 @@ x86_complex_amode base index shift offset
 -- (see trivialCode where this function is used for an example).

 getNonClobberedOperand :: CmmExpr -> NatM (Operand, InstrBlock)
-getNonClobberedOperand (CmmLit lit) =
-  if isSuitableFloatingPointLit lit
-  then do
-    let CmmFloat _ w = lit
+getNonClobberedOperand (CmmLit lit)
+  | Just w <- isSuitableFloatingPointLit_maybe lit = do
    Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit
    return (OpAddr addr, code)
-  else do
+  | otherwise = do
    platform <- getPlatform
    if is32BitLit platform lit && isIntFormat (cmmTypeFormat (cmmLitType platform lit))
    then return (OpImm (litToImm lit), nilOL)
@@ -2563,18 +2558,15 @@ regClobbered _ _ = False
 -- computation of an arbitrary expression.
 getOperand :: CmmExpr -> NatM (Operand, InstrBlock)

-getOperand (CmmLit lit) = do
-  if isSuitableFloatingPointLit lit
-    then do
-      let CmmFloat _ w = lit
-      Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit
-      return (OpAddr addr, code)
-    else do
-
-  platform <- getPlatform
-  if is32BitLit platform lit && (isIntFormat $ cmmTypeFormat (cmmLitType platform lit))
-    then return (OpImm (litToImm lit), nilOL)
-    else getOperand_generic (CmmLit lit)
+getOperand (CmmLit lit) = case isSuitableFloatingPointLit_maybe lit of
+    Just w -> do
+        Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit
+        return (OpAddr addr, code)
+    Nothing -> do
+        platform <- getPlatform
+        if is32BitLit platform lit && (isIntFormat $ cmmTypeFormat (cmmLitType platform lit))
+            then return (OpImm (litToImm lit), nilOL)
+            else getOperand_generic (CmmLit lit)

 getOperand (CmmLoad mem ty _) = do
  is32Bit <- is32BitPlatform
@@ -2645,8 +2637,11 @@ loadAmode fmt addr addr_code = do
 -- zero, we're better off generating it into a register using
 -- xor.
 isSuitableFloatingPointLit :: CmmLit -> Bool
-isSuitableFloatingPointLit (CmmFloat f _) = f /= 0.0
-isSuitableFloatingPointLit _ = False
+isSuitableFloatingPointLit = isJust . isSuitableFloatingPointLit_maybe
+
+isSuitableFloatingPointLit_maybe :: CmmLit -> Maybe Width
+isSuitableFloatingPointLit_maybe (CmmFloat f w) = w <$ guard (f /= 0.0)
+isSuitableFloatingPointLit_maybe _ = Nothing

 getRegOrMem :: CmmExpr -> NatM (Operand, InstrBlock)
 getRegOrMem e@(CmmLoad mem ty _) = do
@@ -3895,14 +3890,14 @@ padStackArgs platform (args0, data_args0) =
      let (this_arg, pads') =
            case stk_arg of
              RawStackArg arg -> (StackArg arg pad, pads)
-              RawStackArgRef ref size ->
-                let (Padding arg_pad : rest_pads) = pads
-                    arg =
-                      StackArgRef
-                        { stackRef = ref
-                        , stackRefArgSize = size
-                        , stackRefArgPadding = arg_pad }
-                in (arg, rest_pads)
+              RawStackArgRef ref size -> case pads of
+                  Padding arg_pad : rest_pads ->
+                    let arg = StackArgRef
+                          { stackRef = ref
+                          , stackRefArgSize = size
+                          , stackRefArgPadding = arg_pad }
+                    in (arg, rest_pads)
+                  _ -> panic "padStackArgs: no padding info found for StackArgRef"
      in this_arg : resolve_args rest pads'

  in

--- a/compiler/GHC/CmmToLlvm/CodeGen.hs
+++ b/compiler/GHC/CmmToLlvm/CodeGen.hs
 {-# 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]

--- a/compiler/GHC/Core/Make.hs
+++ b/compiler/GHC/Core/Make.hs
-{-# 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

--- 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]) }

--- a/compiler/GHC/Core/Opt/SetLevels.hs
+++ b/compiler/GHC/Core/Opt/SetLevels.hs
 {-# LANGUAGE PatternSynonyms #-}

-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
 {-
 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998

@@ -120,12 +118,16 @@ import GHC.Builtin.Types
 import GHC.Builtin.Names      ( runRWKey )

 import GHC.Data.FastString
+import GHC.Data.Pair ( Pair (..) )

 import GHC.Utils.FV
 import GHC.Utils.Misc
 import GHC.Utils.Outputable
 import GHC.Utils.Panic

+import Data.Foldable ( toList )
+import Data.Functor.Identity ( Identity (..) )
+import Data.List.NonEmpty ( NonEmpty (..) )
 import Data.Maybe

 {-
@@ -451,14 +453,14 @@ lvlCase env scrut_fvs scrut' case_bndr ty alts
  , ManyTy <- idMult case_bndr     -- See Note [Floating linear case]
  =     -- Always float the case if possible
        -- Unlike lets we don't insist that it escapes a value lambda
-    do { (env1, (case_bndr' : bs')) <- cloneCaseBndrs env dest_lvl (case_bndr : bs)
+    do { (env1, case_bndr' :| bs') <- cloneCaseBndrs env dest_lvl (case_bndr :| bs)
       ; let rhs_env = extendCaseBndrEnv env1 case_bndr scrut'
       ; body' <- lvlMFE rhs_env True body
       ; let alt' = Alt con (map (stayPut dest_lvl) bs') body'
       ; return (Case scrut' (TB case_bndr' (FloatMe dest_lvl)) ty' [alt']) }

  | otherwise     -- Stays put
-  = do { let (alts_env1, [case_bndr']) = substAndLvlBndrs NonRecursive env incd_lvl [case_bndr]
+  = do { let (alts_env1, Identity case_bndr') = substAndLvlBndrs NonRecursive env incd_lvl (Identity case_bndr)
             alts_env = extendCaseBndrEnv alts_env1 case_bndr scrut'
       ; alts' <- mapM (lvl_alt alts_env) alts
       ; return (Case scrut' case_bndr' ty' alts') }
@@ -649,7 +651,7 @@ lvlMFE env strict_ctxt ann_expr
                         -- See Note [Test cheapness with exprOkForSpeculation]
  , BI_Box { bi_data_con = box_dc, bi_inst_con = boxing_expr
           , bi_boxed_type = box_ty } <- boxingDataCon expr_ty
-  , let [bx_bndr, ubx_bndr] = mkTemplateLocals [box_ty, expr_ty]
+  , let Pair bx_bndr ubx_bndr = mkTemplateLocals (Pair box_ty expr_ty)
  = do { expr1 <- lvlExpr rhs_env ann_expr
       ; let l1r       = incMinorLvlFrom rhs_env
             float_rhs = mkLams abs_vars_w_lvls $
@@ -1227,7 +1229,7 @@ lvlBind env (AnnNonRec bndr rhs)
  = -- No float
    do { rhs' <- lvlRhs env NonRecursive is_bot_lam mb_join_arity rhs
       ; let  bind_lvl        = incMinorLvl (le_ctxt_lvl env)
-              (env', [bndr']) = substAndLvlBndrs NonRecursive env bind_lvl [bndr]
+              (env', Identity bndr') = substAndLvlBndrs NonRecursive env bind_lvl (Identity bndr)
       ; return (NonRec bndr' rhs', env') }

  -- Otherwise we are going to float
@@ -1235,7 +1237,7 @@ lvlBind env (AnnNonRec bndr rhs)
  = do {  -- No type abstraction; clone existing binder
         rhs' <- lvlFloatRhs [] dest_lvl env NonRecursive
                             is_bot_lam NotJoinPoint rhs
-       ; (env', [bndr']) <- cloneLetVars NonRecursive env dest_lvl [bndr]
+       ; (env', Identity bndr') <- cloneLetVars NonRecursive env dest_lvl (Identity bndr)
       ; let bndr2 = annotateBotStr bndr' 0 mb_bot_str
       ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') }

@@ -1243,7 +1245,7 @@ lvlBind env (AnnNonRec bndr rhs)
  = do {  -- Yes, type abstraction; create a new binder, extend substitution, etc
         rhs' <- lvlFloatRhs abs_vars dest_lvl env NonRecursive
                             is_bot_lam NotJoinPoint rhs
-       ; (env', [bndr']) <- newPolyBndrs dest_lvl env abs_vars [bndr]
+       ; (env', Identity bndr') <- newPolyBndrs dest_lvl env abs_vars (Identity bndr)
       ; let bndr2 = annotateBotStr bndr' n_extra mb_bot_str
       ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') }

@@ -1301,13 +1303,13 @@ lvlBind env (AnnRec pairs)
    let (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars
        rhs_lvl = le_ctxt_lvl rhs_env

-    (rhs_env', [new_bndr]) <- cloneLetVars Recursive rhs_env rhs_lvl [bndr]
+    (rhs_env', Identity new_bndr) <- cloneLetVars Recursive rhs_env rhs_lvl (Identity bndr)
    let
        (lam_bndrs, rhs_body)   = collectAnnBndrs rhs
        (body_env1, lam_bndrs1) = substBndrsSL NonRecursive rhs_env' lam_bndrs
        (body_env2, lam_bndrs2) = lvlLamBndrs body_env1 rhs_lvl lam_bndrs1
    new_rhs_body <- lvlRhs body_env2 Recursive is_bot NotJoinPoint rhs_body
-    (poly_env, [poly_bndr]) <- newPolyBndrs dest_lvl env abs_vars [bndr]
+    (poly_env, Identity poly_bndr) <- newPolyBndrs dest_lvl env abs_vars (Identity bndr)
    return (Rec [(TB poly_bndr (FloatMe dest_lvl)
                 , mkLams abs_vars_w_lvls $
                   mkLams lam_bndrs2 $
@@ -1479,24 +1481,26 @@ Use lvlExpr otherwise.  A little subtle, and I got it wrong at least twice
 ************************************************************************
 -}

-substAndLvlBndrs :: RecFlag -> LevelEnv -> Level -> [InVar] -> (LevelEnv, [LevelledBndr])
+substAndLvlBndrs :: Traversable f => RecFlag -> LevelEnv -> Level -> f InVar -> (LevelEnv, f LevelledBndr)
 substAndLvlBndrs is_rec env lvl bndrs
  = lvlBndrs subst_env lvl subst_bndrs
  where
    (subst_env, subst_bndrs) = substBndrsSL is_rec env bndrs
+{-# INLINE substAndLvlBndrs #-}

-substBndrsSL :: RecFlag -> LevelEnv -> [InVar] -> (LevelEnv, [OutVar])
+substBndrsSL :: Traversable f => RecFlag -> LevelEnv -> f InVar -> (LevelEnv, f OutVar)
 -- So named only to avoid the name clash with GHC.Core.Subst.substBndrs
 substBndrsSL is_rec env@(LE { le_subst = subst, le_env = id_env }) bndrs
  = ( env { le_subst    = subst'
-          , le_env      = foldl' add_id  id_env (bndrs `zip` bndrs') }
+          , le_env      = foldl' add_id  id_env (toList bndrs `zip` toList bndrs') }
    , bndrs')
  where
    (subst', bndrs') = case is_rec of
                         NonRecursive -> substBndrs    subst bndrs
                         Recursive    -> substRecBndrs subst bndrs
+{-# INLINE substBndrsSL #-}

-lvlLamBndrs :: LevelEnv -> Level -> [OutVar] -> (LevelEnv, [LevelledBndr])
+lvlLamBndrs :: Traversable f => LevelEnv -> Level -> f OutVar -> (LevelEnv, f LevelledBndr)
 -- Compute the levels for the binders of a lambda group
 lvlLamBndrs env lvl bndrs
  = lvlBndrs env new_lvl bndrs
@@ -1510,17 +1514,18 @@ lvlLamBndrs env lvl bndrs
       -- true of a type variable -- there is no point in floating
       -- out of a big lambda.
       -- See Note [Computing one-shot info] in GHC.Types.Demand
+{-# INLINE lvlLamBndrs #-}

-lvlJoinBndrs :: LevelEnv -> Level -> RecFlag -> [OutVar]
-             -> (LevelEnv, [LevelledBndr])
-lvlJoinBndrs env lvl rec bndrs
-  = lvlBndrs env new_lvl bndrs
+lvlJoinBndrs :: Traversable f => LevelEnv -> Level -> RecFlag -> f OutVar
+             -> (LevelEnv, f LevelledBndr)
+lvlJoinBndrs env lvl rec = lvlBndrs env new_lvl
  where
    new_lvl | isRec rec = incMajorLvl lvl
            | otherwise = incMinorLvl lvl
      -- Non-recursive join points are one-shot; recursive ones are not
+{-# INLINE lvlJoinBndrs #-}

-lvlBndrs :: LevelEnv -> Level -> [CoreBndr] -> (LevelEnv, [LevelledBndr])
+lvlBndrs :: Traversable f => LevelEnv -> Level -> f CoreBndr -> (LevelEnv, f LevelledBndr)
 -- The binders returned are exactly the same as the ones passed,
 -- apart from applying the substitution, but they are now paired
 -- with a (StayPut level)
@@ -1533,7 +1538,8 @@ lvlBndrs :: LevelEnv -> Level -> [CoreBndr] -> (LevelEnv, [LevelledBndr])
 lvlBndrs env@(LE { le_lvl_env = lvl_env }) new_lvl bndrs
  = ( env { le_ctxt_lvl = new_lvl
          , le_lvl_env  = addLvls new_lvl lvl_env bndrs }
-    , map (stayPut new_lvl) bndrs)
+    , fmap (stayPut new_lvl) bndrs)
+{-# INLINE lvlBndrs #-}

 stayPut :: Level -> OutVar -> LevelledBndr
 stayPut new_lvl bndr = TB bndr (StayPut new_lvl)
@@ -1693,8 +1699,8 @@ initialEnv float_lams binds
 addLvl :: Level -> VarEnv Level -> OutVar -> VarEnv Level
 addLvl dest_lvl env v' = extendVarEnv env v' dest_lvl

-addLvls :: Level -> VarEnv Level -> [OutVar] -> VarEnv Level
-addLvls dest_lvl env vs = foldl' (addLvl dest_lvl) env vs
+addLvls :: Foldable f => Level -> VarEnv Level -> f OutVar -> VarEnv Level
+addLvls = foldl' . addLvl

 floatLams :: LevelEnv -> Maybe Int
 floatLams le = floatOutLambdas (le_switches le)
@@ -1792,17 +1798,15 @@ type LvlM result = UniqSM result
 initLvl :: UniqSupply -> UniqSM a -> a
 initLvl = initUs_

-newPolyBndrs :: Level -> LevelEnv -> [OutVar] -> [InId]
-             -> LvlM (LevelEnv, [OutId])
+newPolyBndrs :: (MonadUnique m, Traversable t) => Level -> LevelEnv -> [OutVar] -> t InId -> m (LevelEnv, t OutId)
 -- The envt is extended to bind the new bndrs to dest_lvl, but
 -- the le_ctxt_lvl is unaffected
 newPolyBndrs dest_lvl
             env@(LE { le_lvl_env = lvl_env, le_subst = subst, le_env = id_env })
             abs_vars bndrs
 = assert (all (not . isCoVar) bndrs) $   -- What would we add to the CoSubst in this case. No easy answer.
-   do { uniqs <- getUniquesM
-      ; let new_bndrs = zipWith mk_poly_bndr bndrs uniqs
-            bndr_prs  = bndrs `zip` new_bndrs
+   do { bndr_prs <- withUniquesM (\ uniq bndr -> (bndr, mk_poly_bndr bndr uniq)) bndrs
+      ; let new_bndrs = fmap snd bndr_prs
            env' = env { le_lvl_env = addLvls dest_lvl lvl_env new_bndrs
                       , le_subst   = foldl' add_subst subst   bndr_prs
                       , le_env     = foldl' add_id    id_env  bndr_prs }
@@ -1828,6 +1832,10 @@ newPolyBndrs dest_lvl
      = new_bndr `asJoinId` join_arity + length abs_vars
      | otherwise
      = new_bndr
+{-# SPECIALIZE newPolyBndrs :: (MonadUnique m) => Level -> LevelEnv -> [OutVar] -> [InId] -> m (LevelEnv, [OutId]) #-}
+{-# SPECIALIZE newPolyBndrs :: (MonadUnique m) => Level -> LevelEnv -> [OutVar] -> Identity InId -> m (LevelEnv, Identity OutId) #-}
+{-# SPECIALIZE newPolyBndrs :: (MonadUnique m) => Level -> LevelEnv -> [OutVar] -> NonEmpty InId -> m (LevelEnv, NonEmpty OutId) #-}
+{-# SPECIALIZE newPolyBndrs :: (MonadUnique m) => Level -> LevelEnv -> [OutVar] -> Pair InId -> m (LevelEnv, Pair OutId) #-}

 newLvlVar :: LevelledExpr        -- The RHS of the new binding
          -> JoinPointHood       -- Its join arity, if it is a join point
@@ -1851,21 +1859,20 @@ newLvlVar lvld_rhs join_arity_maybe is_mk_static
      = mkSysLocal (mkFastString "lvl") uniq ManyTy rhs_ty

 -- | Clone the binders bound by a single-alternative case.
-cloneCaseBndrs :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var])
+cloneCaseBndrs :: Traversable t => LevelEnv -> Level -> t Var -> LvlM (LevelEnv, t Var)
 cloneCaseBndrs env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env })
               new_lvl vs
-  = do { (subst', vs') <- cloneBndrs subst vs
+  = do { (subst', vs') <- cloneBndrsM subst vs
             -- N.B. We are not moving the body of the case, merely its case
             -- binders.  Consequently we should *not* set le_ctxt_lvl.
             -- See Note [Setting levels when floating single-alternative cases].
       ; let env' = env { le_lvl_env   = addLvls new_lvl lvl_env vs'
                        , le_subst     = subst'
-                        , le_env       = foldl' add_id id_env (vs `zip` vs') }
-
+                        , le_env       = foldl' add_id id_env (toList vs `zip` toList vs') }
       ; return (env', vs') }

-cloneLetVars :: RecFlag -> LevelEnv -> Level -> [InVar]
-             -> LvlM (LevelEnv, [OutVar])
+cloneLetVars
+ :: Traversable t => RecFlag -> LevelEnv -> Level -> t InVar -> LvlM (LevelEnv, t OutVar)
 -- See Note [Need for cloning during float-out]
 -- Works for Ids bound by let(rec)
 -- The dest_lvl is attributed to the binders in the new env,
@@ -1873,12 +1880,12 @@ cloneLetVars :: RecFlag -> LevelEnv -> Level -> [InVar]
 cloneLetVars is_rec
          env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env })
          dest_lvl vs
-  = do { let vs1  = map zap vs
+  = do { let vs1  = fmap zap vs
       ; (subst', vs2) <- case is_rec of
-                            NonRecursive -> cloneBndrs      subst vs1
-                            Recursive    -> cloneRecIdBndrs subst vs1
+                            NonRecursive -> cloneBndrsM      subst vs1
+                            Recursive    -> cloneRecIdBndrsM subst vs1

-       ; let prs  = vs `zip` vs2
+       ; let prs  = toList vs `zip` toList vs2
             env' = env { le_lvl_env = addLvls dest_lvl lvl_env vs2
                        , le_subst   = subst'
                        , le_env     = foldl' add_id id_env prs }
@@ -1894,6 +1901,10 @@ cloneLetVars is_rec
    -- See Note [Zapping JoinId when floating]
    zap_join | isTopLvl dest_lvl = zapJoinId
             | otherwise         = id
+{-# SPECIALIZE cloneLetVars :: RecFlag -> LevelEnv -> Level -> [InVar] -> LvlM (LevelEnv, [OutVar]) #-}
+{-# SPECIALIZE cloneLetVars :: RecFlag -> LevelEnv -> Level -> Identity InVar -> LvlM (LevelEnv, Identity OutVar) #-}
+{-# SPECIALIZE cloneLetVars :: RecFlag -> LevelEnv -> Level -> NonEmpty InVar -> LvlM (LevelEnv, NonEmpty OutVar) #-}
+{-# SPECIALIZE cloneLetVars :: RecFlag -> LevelEnv -> Level -> Pair InVar -> LvlM (LevelEnv, Pair OutVar) #-}

 add_id :: IdEnv ([Var], LevelledExpr) -> (Var, Var) -> IdEnv ([Var], LevelledExpr)
 add_id id_env (v, v1)

--- 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

--- a/compiler/GHC/Core/Opt/Simplify/Utils.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs
@@ -2414,7 +2414,7 @@ prepareAlts :: OutExpr -> InId -> [InAlt] -> SimplM ([AltCon], [InAlt])
 -- Note that case_bndr is an InId; see Note [Shadowing in prepareAlts]
 prepareAlts scrut case_bndr alts
  | Just (tc, tys) <- splitTyConApp_maybe (idType case_bndr)
-  = do { us <- getUniquesM
+  = do { us <- getUniqueListM
       ; let (idcs1, alts1) = filterAlts tc tys imposs_cons alts
             (yes2,  alts2) = refineDefaultAlt us (idMult case_bndr) tc tys idcs1 alts1
               -- The multiplicity on case_bndr's is the multiplicity of the
@@ -2765,7 +2765,7 @@ mkCase2 mode scrut bndr alts_ty alts
      | not (isNullaryRepDataCon dc)
      = -- For non-nullary data cons we must invent some fake binders
        -- See Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold
-        do { us <- getUniquesM
+        do { us <- getUniqueListM
           ; let (ex_tvs, arg_ids) = dataConRepInstPat us (idMult new_bndr) dc
                                        (tyConAppArgs (idType new_bndr))
           ; return (ex_tvs ++ arg_ids) }

--- 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
No results found